cleaning up my configuration directory.
Signed-off-by: Andreas Gerler <baronNOSPAMbundesbrandschatzamt.de>
--- /dev/null
+;;; apples-mode-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (autoloads nil nil ("apples-mode-pkg.el") (22813 44928 0 0))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; apples-mode-autoloads.el ends here
--- /dev/null
+(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:
--- /dev/null
+;;; apples-mode.el --- Major mode for editing and executing AppleScript code
+
+;; Copyright (C) 2011 tequilasunset
+
+;; Author: tequilasunset <tequilasunset.macNOSPAMgmail.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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\\>.+\\<then,\\<"
+ ;; tell foo to bar
+ "tell\\>.+\\<to,\\<"
+ ))
+ "Regexps match to previous line, which invoke the no-indentation of
+current line. It means that the indentation of current line will
+be same as previous line's one. This variable has priority over
+`apples-indent-regexps'.\n
+See also `apples-indenters' and `apples-deindenters'."
+ ;; It is also used in `apples-parse-statement'.
+ :type '(repeat regexp)
+ :group 'apples)
+
+(defcustom apples-keymap
+ '(("<S-tab>" . 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: <http://macscripter.net/viewtopic.php?id=26334>
+ (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: <http://macwiki.sourceforge.jp/wiki/index.php/AppleScript>
+ ;; <http://docs.info.apple.com/jarticle.html?path=AppleScript/2.1/en/as189>
+ '(("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))))
+ `(
+ ("\\<error\\>" 0 'apples-error )
+ (,(kws 'statements) 1 'apples-statements )
+ (,(cat "^\\s-*\\(?:on\\|to\\),\\(" i "\\)")
+ 1 font-lock-function-name-face )
+ (,(cat "\\<set,\\(" i "\\),to\\>") 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
--- /dev/null
+# -*- mode: snippet -*-
+# name: comment
+# --
+(*
+$0
+*)
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: considering
+# --
+considering $1
+$0
+end considering
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: considering-application-responses
+# --
+considering application responses
+$0
+end considering
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: display-dialog
+# --
+display dialog "$0"
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: if
+# --
+if $1 then
+$2
+else
+$0
+end if
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: ignoring
+# --
+ignoring $1
+$0
+end ignoring
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: ignoring-application-responses
+# --
+ignoring application responses
+$0
+end ignoring
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: on
+# --
+on $1
+$0
+end $1
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: repeat
+# --
+repeat $1
+$0
+end repeat
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: repeat-until
+# --
+repeat until $1
+$0
+end repeat
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: repeat-while
+# --
+repeat while $1
+$0
+end repeat
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: repeat-with
+# --
+repeat with $1
+$0
+end repeat
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: tell-application
+# --
+tell application "$1"
+$0
+end tell
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: tell-application-to-activate
+# --
+tell application "$1" to activate
+$0
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: try
+# --
+try
+$1
+on error $2
+$0
+end try
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: using-terms-from-application
+# --
+using terms from application "$1"
+$0
+end using terms from
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: with-timeout-of-seconds
+# --
+with timeout of $1 seconds
+$0
+end timeout
\ No newline at end of file
--- /dev/null
+# -*- mode: snippet -*-
+# name: with-transaction
+# --
+with transaction
+$0
+end transaction
\ No newline at end of file
--- /dev/null
+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'.
+++ /dev/null
-;;; async-autoloads.el --- automatically extracted autoloads
-;;
-;;; Code:
-(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
-\f
-;;;### (autoloads nil "async" "async.el" (22576 8239 0 0))
-;;; Generated autoloads from async.el
-
-(autoload 'async-start-process "async" "\
-Start the executable PROGRAM asynchronously. See `async-start'.
-PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the
-process object when done. If FINISH-FUNC is nil, the future
-object will return the process object when the program is
-finished. Set DEFAULT-DIRECTORY to change PROGRAM's current
-working directory.
-
-\(fn NAME PROGRAM FINISH-FUNC &rest PROGRAM-ARGS)" nil nil)
-
-(autoload 'async-start "async" "\
-Execute START-FUNC (often a lambda) in a subordinate Emacs process.
-When done, the return value is passed to FINISH-FUNC. Example:
-
- (async-start
- ;; What to do in the child process
- (lambda ()
- (message \"This is a test\")
- (sleep-for 3)
- 222)
-
- ;; What to do when it finishes
- (lambda (result)
- (message \"Async process done, result should be 222: %s\"
- result)))
-
-If FINISH-FUNC is nil or missing, a future is returned that can
-be inspected using `async-get', blocking until the value is
-ready. Example:
-
- (let ((proc (async-start
- ;; What to do in the child process
- (lambda ()
- (message \"This is a test\")
- (sleep-for 3)
- 222))))
-
- (message \"I'm going to do some work here\") ;; ....
-
- (message \"Waiting on async process, result should be 222: %s\"
- (async-get proc)))
-
-If you don't want to use a callback, and you don't care about any
-return value from the child process, pass the `ignore' symbol as
-the second argument (if you don't, and never call `async-get', it
-will leave *emacs* process buffers hanging around):
-
- (async-start
- (lambda ()
- (delete-file \"a remote file on a slow link\" nil))
- 'ignore)
-
-Note: Even when FINISH-FUNC is present, a future is still
-returned except that it yields no value (since the value is
-passed to FINISH-FUNC). Call `async-get' on such a future always
-returns nil. It can still be useful, however, as an argument to
-`async-ready' or `async-wait'.
-
-\(fn START-FUNC &optional FINISH-FUNC)" nil nil)
-
-;;;***
-\f
-;;;### (autoloads nil "async-bytecomp" "async-bytecomp.el" (22576
-;;;;;; 8239 0 0))
-;;; Generated autoloads from async-bytecomp.el
-
-(autoload 'async-byte-recompile-directory "async-bytecomp" "\
-Compile all *.el files in DIRECTORY asynchronously.
-All *.elc files are systematically deleted before proceeding.
-
-\(fn DIRECTORY &optional QUIET)" nil nil)
-
-(defvar async-bytecomp-package-mode nil "\
-Non-nil if Async-Bytecomp-Package mode is enabled.
-See the `async-bytecomp-package-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 `async-bytecomp-package-mode'.")
-
-(custom-autoload 'async-bytecomp-package-mode "async-bytecomp" nil)
-
-(autoload 'async-bytecomp-package-mode "async-bytecomp" "\
-Byte compile asynchronously packages installed with package.el.
-Async compilation of packages can be controlled by
-`async-bytecomp-allowed-packages'.
-
-\(fn &optional ARG)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "dired-async" "dired-async.el" (22576 8239
-;;;;;; 0 0))
-;;; Generated autoloads from dired-async.el
-
-(defvar dired-async-mode nil "\
-Non-nil if Dired-Async mode is enabled.
-See the `dired-async-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 `dired-async-mode'.")
-
-(custom-autoload 'dired-async-mode "dired-async" nil)
-
-(autoload 'dired-async-mode "dired-async" "\
-Do dired actions asynchronously.
-
-\(fn &optional ARG)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil nil ("async-pkg.el" "smtpmail-async.el") (22576
-;;;;;; 8239 0 0))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; End:
-;;; async-autoloads.el ends here
+++ /dev/null
-;;; async-bytecomp.el --- Compile elisp files asynchronously -*- lexical-binding: t -*-
-
-;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
-
-;; Authors: John Wiegley <jwiegleyNOSPAMgmail.com>
-;; Thierry Volpiatto <thierry.volpiattoNOSPAMgmail.com>
-
-;; Keywords: dired async byte-compile
-;; X-URL: https://github.com/jwiegley/dired-async
-
-;; This program is free software; you can 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 program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR 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 package provide the `async-byte-recompile-directory' function
-;; which allows, as the name says to recompile a directory outside of
-;; your running emacs.
-;; The benefit is your files will be compiled in a clean environment without
-;; the old *.el files loaded.
-;; Among other things, this fix a bug in package.el which recompile
-;; the new files in the current environment with the old files loaded, creating
-;; errors in most packages after upgrades.
-;;
-;; NB: This package is advicing the function `package--compile'.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'async)
-
-(defcustom async-bytecomp-allowed-packages
- '(async helm helm-core helm-ls-git helm-ls-hg magit)
- "Packages in this list will be compiled asynchronously by `package--compile'.
-All the dependencies of these packages will be compiled async too,
-so no need to add dependencies to this list.
-The value of this variable can also be a list with a single element,
-the symbol `all', in this case packages are always compiled asynchronously."
- :group 'async
- :type '(repeat (choice symbol)))
-
-(defvar async-byte-compile-log-file "~/.emacs.d/async-bytecomp.log")
-
-;;;###autoload
-(defun async-byte-recompile-directory (directory &optional quiet)
- "Compile all *.el files in DIRECTORY asynchronously.
-All *.elc files are systematically deleted before proceeding."
- (cl-loop with dir = (directory-files directory t "\\.elc\\'")
- unless dir return nil
- for f in dir
- when (file-exists-p f) do (delete-file f))
- ;; Ensure async is reloaded when async.elc is deleted.
- ;; This happen when recompiling its own directory.
- (load "async")
- (let ((call-back
- (lambda (&optional _ignore)
- (if (file-exists-p async-byte-compile-log-file)
- (let ((buf (get-buffer-create byte-compile-log-buffer))
- (n 0))
- (with-current-buffer buf
- (goto-char (point-max))
- (let ((inhibit-read-only t))
- (insert-file-contents async-byte-compile-log-file)
- (compilation-mode))
- (display-buffer buf)
- (delete-file async-byte-compile-log-file)
- (unless quiet
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward "^.*:Error:" nil t)
- (cl-incf n)))
- (if (> n 0)
- (message "Failed to compile %d files in directory `%s'" n directory)
- (message "Directory `%s' compiled asynchronously with warnings" directory)))))
- (unless quiet
- (message "Directory `%s' compiled asynchronously with success" directory))))))
- (async-start
- `(lambda ()
- (require 'bytecomp)
- ,(async-inject-variables "\\`\\(load-path\\)\\|byte\\'")
- (let ((default-directory (file-name-as-directory ,directory))
- error-data)
- (add-to-list 'load-path default-directory)
- (byte-recompile-directory ,directory 0 t)
- (when (get-buffer byte-compile-log-buffer)
- (setq error-data (with-current-buffer byte-compile-log-buffer
- (buffer-substring-no-properties (point-min) (point-max))))
- (unless (string= error-data "")
- (with-temp-file ,async-byte-compile-log-file
- (erase-buffer)
- (insert error-data))))))
- call-back)
- (unless quiet (message "Started compiling asynchronously directory %s" directory))))
-
-(defvar package-archive-contents)
-(defvar package-alist)
-(declare-function package-desc-reqs "package.el" (cl-x))
-
-(defun async-bytecomp--get-package-deps (pkg &optional only)
- ;; Same as `package--get-deps' but parse instead `package-archive-contents'
- ;; because PKG is not already installed and not present in `package-alist'.
- ;; However fallback to `package-alist' in case PKG no more present
- ;; in `package-archive-contents' due to modification to `package-archives'.
- ;; See issue #58.
- (let* ((pkg-desc (cadr (or (assq pkg package-archive-contents)
- (assq pkg package-alist))))
- (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc)
- for name = (car p)
- when (or (assq name package-archive-contents)
- (assq name package-alist))
- collect name))
- (indirect-deps (unless (eq only 'direct)
- (delete-dups
- (cl-loop for p in direct-deps append
- (async-bytecomp--get-package-deps p))))))
- (cl-case only
- (direct direct-deps)
- (separate (list direct-deps indirect-deps))
- (indirect indirect-deps)
- (t (delete-dups (append direct-deps indirect-deps))))))
-
-(defun async-bytecomp-get-allowed-pkgs ()
- (when (and async-bytecomp-allowed-packages
- (listp async-bytecomp-allowed-packages))
- (if package-archive-contents
- (cl-loop for p in async-bytecomp-allowed-packages
- when (assq p package-archive-contents)
- append (async-bytecomp--get-package-deps p) into reqs
- finally return
- (delete-dups
- (append async-bytecomp-allowed-packages reqs)))
- async-bytecomp-allowed-packages)))
-
-(defadvice package--compile (around byte-compile-async)
- (let ((cur-package (package-desc-name pkg-desc))
- (pkg-dir (package-desc-dir pkg-desc)))
- (if (or (equal async-bytecomp-allowed-packages '(all))
- (memq cur-package (async-bytecomp-get-allowed-pkgs)))
- (progn
- (when (eq cur-package 'async)
- (fmakunbound 'async-byte-recompile-directory))
- ;; Add to `load-path' the latest version of async and
- ;; reload it when reinstalling async.
- (when (string= cur-package "async")
- (cl-pushnew pkg-dir load-path)
- (load "async-bytecomp"))
- ;; `async-byte-recompile-directory' will add directory
- ;; as needed to `load-path'.
- (async-byte-recompile-directory (package-desc-dir pkg-desc) t))
- ad-do-it)))
-
-;;;###autoload
-(define-minor-mode async-bytecomp-package-mode
- "Byte compile asynchronously packages installed with package.el.
-Async compilation of packages can be controlled by
-`async-bytecomp-allowed-packages'."
- :group 'async
- :global t
- (if async-bytecomp-package-mode
- (ad-activate 'package--compile)
- (ad-deactivate 'package--compile)))
-
-(provide 'async-bytecomp)
-
-;;; async-bytecomp.el ends here
+++ /dev/null
-(define-package "async" "20161103.1036" "Asynchronous processing in Emacs" 'nil :keywords
- '("async")
- :url "https://github.com/jwiegley/emacs-async")
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+++ /dev/null
-;;; async.el --- Asynchronous processing in Emacs -*- lexical-binding: t -*-
-
-;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
-
-;; Author: John Wiegley <jwiegleyNOSPAMgmail.com>
-;; Created: 18 Jun 2012
-;; Version: 1.9
-
-;; Keywords: async
-;; X-URL: https://github.com/jwiegley/emacs-async
-
-;; This program is free software; you can 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 program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR 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.
-\f
-;;; Commentary:
-
-;; Adds the ability to call asynchronous functions and process with ease. See
-;; the documentation for `async-start' and `async-start-process'.
-\f
-;;; Code:
-
-(defgroup async nil
- "Simple asynchronous processing in Emacs"
- :group 'emacs)
-
-(defvar async-debug nil)
-(defvar async-send-over-pipe t)
-(defvar async-in-child-emacs nil)
-(defvar async-callback nil)
-(defvar async-callback-for-process nil)
-(defvar async-callback-value nil)
-(defvar async-callback-value-set nil)
-(defvar async-current-process nil)
-(defvar async--procvar nil)
-
-(defun async-inject-variables
- (include-regexp &optional predicate exclude-regexp)
- "Return a `setq' form that replicates part of the calling environment.
-It sets the value for every variable matching INCLUDE-REGEXP and
-also PREDICATE. It will not perform injection for any variable
-matching EXCLUDE-REGEXP (if present). It is intended to be used
-as follows:
-
- (async-start
- `(lambda ()
- (require 'smtpmail)
- (with-temp-buffer
- (insert ,(buffer-substring-no-properties (point-min) (point-max)))
- ;; Pass in the variable environment for smtpmail
- ,(async-inject-variables \"\\`\\(smtpmail\\|\\(user-\\)?mail\\)-\")
- (smtpmail-send-it)))
- 'ignore)"
- `(setq
- ,@(let (bindings)
- (mapatoms
- (lambda (sym)
- (if (and (boundp sym)
- (or (null include-regexp)
- (string-match include-regexp (symbol-name sym)))
- (not (string-match
- (or exclude-regexp "-syntax-table\\'")
- (symbol-name sym))))
- (let ((value (symbol-value sym)))
- (when (or (null predicate)
- (funcall predicate sym))
- (setq bindings (cons `(quote ,value) bindings)
- bindings (cons sym bindings)))))))
- bindings)))
-
-(defalias 'async-inject-environment 'async-inject-variables)
-
-(defun async-handle-result (func result buf)
- (if (null func)
- (progn
- (set (make-local-variable 'async-callback-value) result)
- (set (make-local-variable 'async-callback-value-set) t))
- (unwind-protect
- (if (and (listp result)
- (eq 'async-signal (nth 0 result)))
- (signal (car (nth 1 result))
- (cdr (nth 1 result)))
- (funcall func result))
- (unless async-debug
- (kill-buffer buf)))))
-
-(defun async-when-done (proc &optional _change)
- "Process sentinel used to retrieve the value from the child process."
- (when (eq 'exit (process-status proc))
- (with-current-buffer (process-buffer proc)
- (let ((async-current-process proc))
- (if (= 0 (process-exit-status proc))
- (if async-callback-for-process
- (if async-callback
- (prog1
- (funcall async-callback proc)
- (unless async-debug
- (kill-buffer (current-buffer))))
- (set (make-local-variable 'async-callback-value) proc)
- (set (make-local-variable 'async-callback-value-set) t))
- (goto-char (point-max))
- (backward-sexp)
- (async-handle-result async-callback (read (current-buffer))
- (current-buffer)))
- (set (make-local-variable 'async-callback-value)
- (list 'error
- (format "Async process '%s' failed with exit code %d"
- (process-name proc) (process-exit-status proc))))
- (set (make-local-variable 'async-callback-value-set) t))))))
-
-(defun async--receive-sexp (&optional stream)
- (let ((sexp (decode-coding-string (base64-decode-string
- (read stream)) 'utf-8-unix))
- ;; Parent expects UTF-8 encoded text.
- (coding-system-for-write 'utf-8-unix))
- (if async-debug
- (message "Received sexp {{{%s}}}" (pp-to-string sexp)))
- (setq sexp (read sexp))
- (if async-debug
- (message "Read sexp {{{%s}}}" (pp-to-string sexp)))
- (eval sexp)))
-
-(defun async--insert-sexp (sexp)
- (let (print-level
- print-length
- (print-escape-nonascii t)
- (print-circle t))
- (prin1 sexp (current-buffer))
- ;; Just in case the string we're sending might contain EOF
- (encode-coding-region (point-min) (point-max) 'utf-8-unix)
- (base64-encode-region (point-min) (point-max) t)
- (goto-char (point-min)) (insert ?\")
- (goto-char (point-max)) (insert ?\" ?\n)))
-
-(defun async--transmit-sexp (process sexp)
- (with-temp-buffer
- (if async-debug
- (message "Transmitting sexp {{{%s}}}" (pp-to-string sexp)))
- (async--insert-sexp sexp)
- (process-send-region process (point-min) (point-max))))
-
-(defun async-batch-invoke ()
- "Called from the child Emacs process' command-line."
- ;; Make sure 'message' and 'prin1' encode stuff in UTF-8, as parent
- ;; process expects.
- (let ((coding-system-for-write 'utf-8-unix))
- (setq async-in-child-emacs t
- debug-on-error async-debug)
- (if debug-on-error
- (prin1 (funcall
- (async--receive-sexp (unless async-send-over-pipe
- command-line-args-left))))
- (condition-case err
- (prin1 (funcall
- (async--receive-sexp (unless async-send-over-pipe
- command-line-args-left))))
- (error
- (prin1 (list 'async-signal err)))))))
-
-(defun async-ready (future)
- "Query a FUTURE to see if the ready 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)))
-
-(defun async-wait (future)
- "Wait for FUTURE to become ready."
- (while (not (async-ready future))
- (sit-for 0.05)))
-
-(defun async-get (future)
- "Get the value from an asynchronously function 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))))
-
-(defun async-message-p (value)
- "Return true of VALUE is an async.el message packet."
- (and (listp value)
- (plist-get value :async-message)))
-
-(defun async-send (&rest args)
- "Send the given messages to the asychronous Emacs PROCESS."
- (let ((args (append args '(:async-message t))))
- (if async-in-child-emacs
- (if async-callback
- (funcall async-callback args))
- (async--transmit-sexp (car args) (list 'quote (cdr args))))))
-
-(defun async-receive ()
- "Send the given messages to the asychronous Emacs PROCESS."
- (async--receive-sexp))
-
-;;;###autoload
-(defun async-start-process (name program finish-func &rest program-args)
- "Start the executable PROGRAM asynchronously. See `async-start'.
-PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the
-process object when done. If FINISH-FUNC is nil, the future
-object will return the process object when the program is
-finished. Set DEFAULT-DIRECTORY to change PROGRAM's current
-working directory."
- (let* ((buf (generate-new-buffer (concat "*" name "*")))
- (proc (let ((process-connection-type nil))
- (apply #'start-process name buf program program-args))))
- (with-current-buffer buf
- (set (make-local-variable 'async-callback) finish-func)
- (set-process-sentinel proc #'async-when-done)
- (unless (string= name "emacs")
- (set (make-local-variable 'async-callback-for-process) t))
- proc)))
-
-;;;###autoload
-(defun async-start (start-func &optional finish-func)
- "Execute START-FUNC (often a lambda) in a subordinate Emacs process.
-When done, the return value is passed to FINISH-FUNC. Example:
-
- (async-start
- ;; What to do in the child process
- (lambda ()
- (message \"This is a test\")
- (sleep-for 3)
- 222)
-
- ;; What to do when it finishes
- (lambda (result)
- (message \"Async process done, result should be 222: %s\"
- result)))
-
-If FINISH-FUNC is nil or missing, a future is returned that can
-be inspected using `async-get', blocking until the value is
-ready. Example:
-
- (let ((proc (async-start
- ;; What to do in the child process
- (lambda ()
- (message \"This is a test\")
- (sleep-for 3)
- 222))))
-
- (message \"I'm going to do some work here\") ;; ....
-
- (message \"Waiting on async process, result should be 222: %s\"
- (async-get proc)))
-
-If you don't want to use a callback, and you don't care about any
-return value from the child process, pass the `ignore' symbol as
-the second argument (if you don't, and never call `async-get', it
-will leave *emacs* process buffers hanging around):
-
- (async-start
- (lambda ()
- (delete-file \"a remote file on a slow link\" nil))
- 'ignore)
-
-Note: Even when FINISH-FUNC is present, a future is still
-returned except that it yields no value (since the value is
-passed to FINISH-FUNC). Call `async-get' on such a future always
-returns nil. It can still be useful, however, as an argument to
-`async-ready' or `async-wait'."
- (let ((sexp start-func)
- ;; Subordinate Emacs will send text encoded in UTF-8.
- (coding-system-for-read 'utf-8-unix))
- (setq async--procvar
- (async-start-process
- "emacs" (file-truename
- (expand-file-name invocation-name
- invocation-directory))
- finish-func
- "-Q" "-l"
- ;; Using `locate-library' ensure we use the right file
- ;; when the .elc have been deleted.
- (locate-library "async")
- "-batch" "-f" "async-batch-invoke"
- (if async-send-over-pipe
- "<none>"
- (with-temp-buffer
- (async--insert-sexp (list 'quote sexp))
- (buffer-string)))))
- (if async-send-over-pipe
- (async--transmit-sexp async--procvar (list 'quote sexp)))
- async--procvar))
-
-(defmacro async-sandbox(func)
- "Evaluate FUNC in a separate Emacs process, synchronously."
- `(async-get (async-start ,func)))
-
-(defun async--fold-left (fn forms bindings)
- (let ((res forms))
- (dolist (binding bindings)
- (setq res (funcall fn res
- (if (listp binding)
- binding
- (list binding)))))
- res))
-
-(defmacro async-let (bindings &rest forms)
- "Implements `let', but each binding is established asynchronously.
-For example:
-
- (async-let ((x (foo))
- (y (bar)))
- (message \"%s %s\" x y))
-
- expands to ==>
-
- (async-start (foo)
- (lambda (x)
- (async-start (bar)
- (lambda (y)
- (message \"%s %s\" x y)))))"
- (declare (indent 1))
- (async--fold-left
- (lambda (acc binding)
- (let ((fun (pcase (cadr binding)
- ((and (pred functionp) f) f)
- (f `(lambda () ,f)))))
- `(async-start ,fun
- (lambda (,(car binding))
- ,acc))))
- `(progn ,@forms)
- (reverse bindings)))
-
-(provide 'async)
-
-;;; async.el ends here
+++ /dev/null
-;;; dired-async.el --- Asynchronous dired actions -*- lexical-binding: t -*-
-
-;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
-
-;; Authors: John Wiegley <jwiegleyNOSPAMgmail.com>
-;; Thierry Volpiatto <thierry.volpiattoNOSPAMgmail.com>
-
-;; Keywords: dired async network
-;; X-URL: https://github.com/jwiegley/dired-async
-
-;; This program is free software; you can 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 program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR 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.
-\f
-;;; Commentary:
-
-;; This file provide a redefinition of `dired-create-file' function,
-;; performs copies, moves and all what is handled by `dired-create-file'
-;; in the background using a slave Emacs process,
-;; by means of the async.el module.
-;; To use it, put this in your .emacs:
-
-;; (dired-async-mode 1)
-
-;; This will enable async copy/rename etc...
-;; in dired and helm.
-
-;;; Code:
-\f
-(require 'cl-lib)
-(require 'dired-aux)
-(require 'async)
-
-(eval-when-compile
- (defvar async-callback))
-
-(defgroup dired-async nil
- "Copy rename files asynchronously from dired."
- :group 'dired)
-
-(defcustom dired-async-env-variables-regexp
- "\\`\\(tramp-\\(default\\|connection\\|remote\\)\\|ange-ftp\\)-.*"
- "Variables matching this regexp will be loaded on Child Emacs."
- :type 'regexp
- :group 'dired-async)
-
-(defcustom dired-async-message-function 'dired-async-mode-line-message
- "Function to use to notify result when operation finish.
-Should take same args as `message'."
- :group 'dired-async
- :type 'function)
-
-(defcustom dired-async-log-file "/tmp/dired-async.log"
- "File use to communicate errors from Child Emacs to host Emacs."
- :group 'dired-async
- :type 'string)
-
-(defface dired-async-message
- '((t (:foreground "yellow")))
- "Face used for mode-line message."
- :group 'dired-async)
-
-(defface dired-async-failures
- '((t (:foreground "red")))
- "Face used for mode-line message."
- :group 'dired-async)
-
-(defface dired-async-mode-message
- '((t (:foreground "Gold")))
- "Face used for `dired-async--modeline-mode' lighter."
- :group 'dired-async)
-
-(define-minor-mode dired-async--modeline-mode
- "Notify mode-line that an async process run."
- :group 'dired-async
- :global t
- :lighter (:eval (propertize (format " [%s Async job(s) running]"
- (length (dired-async-processes)))
- 'face 'dired-async-mode-message))
- (unless dired-async--modeline-mode
- (let ((visible-bell t)) (ding))))
-
-(defun dired-async-mode-line-message (text face &rest args)
- "Notify end of operation in `mode-line'."
- (message nil)
- (let ((mode-line-format (concat
- " " (propertize
- (if args
- (apply #'format text args)
- text)
- 'face face))))
- (force-mode-line-update)
- (sit-for 3)
- (force-mode-line-update)))
-
-(defun dired-async-processes ()
- (cl-loop for p in (process-list)
- when (cl-loop for c in (process-command p) thereis
- (string= "async-batch-invoke" c))
- collect p))
-
-(defun dired-async-kill-process ()
- (interactive)
- (let* ((processes (dired-async-processes))
- (proc (car (last processes))))
- (and proc (delete-process proc))
- (unless (> (length processes) 1)
- (dired-async--modeline-mode -1))))
-
-(defun dired-async-after-file-create (total operation failures skipped)
- "Callback function used for operation handled by `dired-create-file'."
- (unless (dired-async-processes)
- ;; Turn off mode-line notification
- ;; only when last process end.
- (dired-async--modeline-mode -1))
- (when operation
- (if (file-exists-p dired-async-log-file)
- (progn
- (pop-to-buffer (get-buffer-create dired-log-buffer))
- (goto-char (point-max))
- (setq inhibit-read-only t)
- (insert "Error: ")
- (insert-file-contents dired-async-log-file)
- (special-mode)
- (shrink-window-if-larger-than-buffer)
- (delete-file dired-async-log-file))
- (run-with-timer
- 0.1 nil
- (lambda ()
- ;; First send error messages.
- (cond (failures
- (funcall dired-async-message-function
- "%s failed for %d of %d file%s -- See *Dired log* buffer"
- 'dired-async-failures
- (car operation) (length failures)
- total (dired-plural-s total)))
- (skipped
- (funcall dired-async-message-function
- "%s: %d of %d file%s skipped -- See *Dired log* buffer"
- 'dired-async-failures
- (car operation) (length skipped) total
- (dired-plural-s total))))
- ;; Finally send the success message.
- (funcall dired-async-message-function
- "Asynchronous %s of %s on %s file%s done"
- 'dired-async-message
- (car operation) (cadr operation)
- total (dired-plural-s total)))))))
-
-(defun dired-async-maybe-kill-ftp ()
- "Return a form to kill ftp process in child emacs."
- (quote
- (progn
- (require 'cl-lib)
- (let ((buf (cl-loop for b in (buffer-list)
- thereis (and (string-match
- "\\`\\*ftp.*"
- (buffer-name b)) b))))
- (when buf (kill-buffer buf))))))
-
-(defvar overwrite-query)
-(defun dired-async-create-files (file-creator operation fn-list name-constructor
- &optional _marker-char)
- "Same as `dired-create-files' but asynchronous.
-
-See `dired-create-files' for the behavior of arguments."
- (setq overwrite-query nil)
- (let ((total (length fn-list))
- failures async-fn-list skipped callback)
- (let (to)
- (dolist (from fn-list)
- (setq to (funcall name-constructor from))
- (if (equal to from)
- (progn
- (setq to nil)
- (dired-log "Cannot %s to same file: %s\n"
- (downcase operation) from)))
- (if (not to)
- (setq skipped (cons (dired-make-relative from) skipped))
- (let* ((overwrite (and (null (eq file-creator 'backup-file))
- (file-exists-p to)))
- (dired-overwrite-confirmed ; for dired-handle-overwrite
- (and overwrite
- (let ((help-form `(format "\
-Type SPC or `y' to overwrite file `%s',
-DEL or `n' to skip to next,
-ESC or `q' to not overwrite any of the remaining files,
-`!' to overwrite all remaining files with no more questions." ,to)))
- (dired-query 'overwrite-query "Overwrite `%s'?" to)))))
- ;; Handle the `dired-copy-file' file-creator specially
- ;; When copying a directory to another directory or
- ;; possibly to itself or one of its subdirectories.
- ;; e.g "~/foo/" => "~/test/"
- ;; or "~/foo/" =>"~/foo/"
- ;; or "~/foo/ => ~/foo/bar/")
- ;; In this case the 'name-constructor' have set the destination
- ;; TO to "~/test/foo" because the old emacs23 behavior
- ;; of `copy-directory' was to not create the subdirectory
- ;; and instead copy the contents.
- ;; With the new behavior of `copy-directory'
- ;; (similar to the `cp' shell command) we don't
- ;; need such a construction of the target directory,
- ;; so modify the destination TO to "~/test/" instead of "~/test/foo/".
- (let ((destname (file-name-directory to)))
- (when (and (file-directory-p from)
- (file-directory-p to)
- (eq file-creator 'dired-copy-file))
- (setq to destname))
- ;; If DESTNAME is a subdirectory of FROM, not a symlink,
- ;; and the method in use is copying, signal an error.
- (and (eq t (car (file-attributes destname)))
- (eq file-creator 'dired-copy-file)
- (file-in-directory-p destname from)
- (error "Cannot copy `%s' into its subdirectory `%s'"
- from to)))
- (if overwrite
- (or (and dired-overwrite-confirmed
- (push (cons from to) async-fn-list))
- (progn
- (push (dired-make-relative from) failures)
- (dired-log "%s `%s' to `%s' failed\n"
- operation from to)))
- (push (cons from to) async-fn-list)))))
- ;; 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
- ;; had to be copied and user finally answer NO.
- ;; In this case async process will never start and callback
- ;; will have no chance to run, so notify failures here.
- (unless async-fn-list
- (cond (failures
- (funcall dired-async-message-function
- "%s failed for %d of %d file%s -- See *Dired log* buffer"
- 'dired-async-failures
- operation (length failures)
- total (dired-plural-s total)))
- (skipped
- (funcall dired-async-message-function
- "%s: %d of %d file%s skipped -- See *Dired log* buffer"
- 'dired-async-failures
- operation (length skipped) total
- (dired-plural-s total)))))
- ;; Setup callback.
- (setq callback
- (lambda (&optional _ignore)
- (dired-async-after-file-create
- total (list operation (length async-fn-list)) failures skipped)
- (when (string= (downcase operation) "rename")
- (cl-loop for (file . to) in async-fn-list
- for bf = (get-file-buffer file)
- for destp = (file-exists-p to)
- do (and bf destp
- (with-current-buffer bf
- (set-visited-file-name to t t))))))))
- ;; Start async process.
- (when async-fn-list
- (async-start `(lambda ()
- (require 'cl-lib) (require 'dired-aux) (require 'dired-x)
- ,(async-inject-variables dired-async-env-variables-regexp)
- (let ((dired-recursive-copies (quote always))
- (dired-copy-preserve-time
- ,dired-copy-preserve-time))
- (setq overwrite-backup-query nil)
- ;; Inline `backup-file' as long as it is not
- ;; available in emacs.
- (defalias 'backup-file
- ;; Same feature as "cp --backup=numbered from to"
- ;; Symlinks are copied as file from source unlike
- ;; `dired-copy-file' which is same as cp -d.
- ;; Directories are omitted.
- (lambda (from to ok)
- (cond ((file-directory-p from) (ignore))
- (t (let ((count 0))
- (while (let ((attrs (file-attributes to)))
- (and attrs (null (nth 0 attrs))))
- (cl-incf count)
- (setq to (concat (file-name-sans-versions to)
- (format ".~%s~" count)))))
- (condition-case err
- (copy-file from to ok dired-copy-preserve-time)
- (file-date-error
- (dired-log "Can't set date on %s:\n%s\n" from err)))))))
- ;; Now run the FILE-CREATOR function on files.
- (cl-loop with fn = (quote ,file-creator)
- for (from . dest) in (quote ,async-fn-list)
- do (condition-case err
- (funcall fn from dest t)
- (file-error
- (dired-log "%s: %s\n" (car err) (cdr err)))
- nil))
- (when (get-buffer dired-log-buffer)
- (dired-log t)
- (with-current-buffer dired-log-buffer
- (write-region (point-min) (point-max)
- ,dired-async-log-file))))
- ,(dired-async-maybe-kill-ftp))
- callback)
- ;; Run mode-line notifications while process running.
- (dired-async--modeline-mode 1)
- (message "%s proceeding asynchronously..." operation))))
-
-(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."
- :group 'dired-async
- :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))
- (if (fboundp 'advice-remove)
- (advice-remove 'dired-create-files #'dired-async-create-files)
- (ad-deactivate 'dired-create-files))))
-
-
-(provide 'dired-async)
-
-;;; dired-async.el ends here
+++ /dev/null
-;;; smtpmail-async.el --- Send e-mail with smtpmail.el asynchronously -*- lexical-binding: t -*-
-
-;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
-
-;; Author: John Wiegley <jwiegleyNOSPAMgmail.com>
-;; Created: 18 Jun 2012
-
-;; Keywords: email async
-;; X-URL: https://github.com/jwiegley/emacs-async
-
-;; This program is free software; you can 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 program is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR 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.
-\f
-;;; Commentary:
-
-;; Send e-mail with smtpmail.el asynchronously. To use:
-;;
-;; (require 'smtpmail-async)
-;;
-;; (setq send-mail-function 'async-smtpmail-send-it
-;; message-send-mail-function 'async-smtpmail-send-it)
-;;
-;; This assumes you already have smtpmail.el working.
-
-;;; Code:
-
-(defgroup smtpmail-async nil
- "Send e-mail with smtpmail.el asynchronously"
- :group 'smptmail)
-
-(require 'async)
-(require 'smtpmail)
-(require 'message)
-
-(defvar async-smtpmail-before-send-hook nil
- "Hook running in the child emacs in `async-smtpmail-send-it'.
-It is called just before calling `smtpmail-send-it'.")
-
-(defun async-smtpmail-send-it ()
- (let ((to (message-field-value "To"))
- (buf-content (buffer-substring-no-properties
- (point-min) (point-max))))
- (message "Delivering message to %s..." to)
- (async-start
- `(lambda ()
- (require 'smtpmail)
- (with-temp-buffer
- (insert ,buf-content)
- (set-buffer-multibyte nil)
- ;; Pass in the variable environment for smtpmail
- ,(async-inject-variables
- "\\`\\(smtpmail\\|async-smtpmail\\|\\(user-\\)?mail\\)-\\|auth-sources\\|epg"
- nil "\\`\\(mail-header-format-function\\|smtpmail-address-buffer\\|mail-mode-abbrev-table\\)")
- (run-hooks 'async-smtpmail-before-send-hook)
- (smtpmail-send-it)))
- (lambda (&optional _ignore)
- (message "Delivering message to %s...done" to)))))
-
-(provide 'smtpmail-async)
-
-;;; smtpmail-async.el ends here
--- /dev/null
+;;; async-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
+\f
+;;;### (autoloads nil "async" "async.el" (22975 34388 0 0))
+;;; Generated autoloads from async.el
+
+(autoload 'async-start-process "async" "\
+Start the executable PROGRAM asynchronously. See `async-start'.
+PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the
+process object when done. If FINISH-FUNC is nil, the future
+object will return the process object when the program is
+finished. Set DEFAULT-DIRECTORY to change PROGRAM's current
+working directory.
+
+\(fn NAME PROGRAM FINISH-FUNC &rest PROGRAM-ARGS)" nil nil)
+
+(autoload 'async-start "async" "\
+Execute START-FUNC (often a lambda) in a subordinate Emacs process.
+When done, the return value is passed to FINISH-FUNC. Example:
+
+ (async-start
+ ;; What to do in the child process
+ (lambda ()
+ (message \"This is a test\")
+ (sleep-for 3)
+ 222)
+
+ ;; What to do when it finishes
+ (lambda (result)
+ (message \"Async process done, result should be 222: %s\"
+ result)))
+
+If FINISH-FUNC is nil or missing, a future is returned that can
+be inspected using `async-get', blocking until the value is
+ready. Example:
+
+ (let ((proc (async-start
+ ;; What to do in the child process
+ (lambda ()
+ (message \"This is a test\")
+ (sleep-for 3)
+ 222))))
+
+ (message \"I'm going to do some work here\") ;; ....
+
+ (message \"Waiting on async process, result should be 222: %s\"
+ (async-get proc)))
+
+If you don't want to use a callback, and you don't care about any
+return value from the child process, pass the `ignore' symbol as
+the second argument (if you don't, and never call `async-get', it
+will leave *emacs* process buffers hanging around):
+
+ (async-start
+ (lambda ()
+ (delete-file \"a remote file on a slow link\" nil))
+ 'ignore)
+
+Note: Even when FINISH-FUNC is present, a future is still
+returned except that it yields no value (since the value is
+passed to FINISH-FUNC). Call `async-get' on such a future always
+returns nil. It can still be useful, however, as an argument to
+`async-ready' or `async-wait'.
+
+\(fn START-FUNC &optional FINISH-FUNC)" nil nil)
+
+;;;***
+\f
+;;;### (autoloads nil "async-bytecomp" "async-bytecomp.el" (22975
+;;;;;; 34388 0 0))
+;;; Generated autoloads from async-bytecomp.el
+
+(autoload 'async-byte-recompile-directory "async-bytecomp" "\
+Compile all *.el files in DIRECTORY asynchronously.
+All *.elc files are systematically deleted before proceeding.
+
+\(fn DIRECTORY &optional QUIET)" nil nil)
+
+(defvar async-bytecomp-package-mode nil "\
+Non-nil if Async-Bytecomp-Package mode is enabled.
+See the `async-bytecomp-package-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 `async-bytecomp-package-mode'.")
+
+(custom-autoload 'async-bytecomp-package-mode "async-bytecomp" nil)
+
+(autoload 'async-bytecomp-package-mode "async-bytecomp" "\
+Byte compile asynchronously packages installed with package.el.
+Async compilation of packages can be controlled by
+`async-bytecomp-allowed-packages'.
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "dired-async" "dired-async.el" (22975 34388
+;;;;;; 0 0))
+;;; Generated autoloads from dired-async.el
+
+(defvar dired-async-mode nil "\
+Non-nil if Dired-Async mode is enabled.
+See the `dired-async-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 `dired-async-mode'.")
+
+(custom-autoload 'dired-async-mode "dired-async" nil)
+
+(autoload 'dired-async-mode "dired-async" "\
+Do dired actions asynchronously.
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil nil ("async-pkg.el" "smtpmail-async.el") (22975
+;;;;;; 34388 0 0))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; async-autoloads.el ends here
--- /dev/null
+;;; async-bytecomp.el --- Compile elisp files asynchronously -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
+
+;; Authors: John Wiegley <jwiegleyNOSPAMgmail.com>
+;; Thierry Volpiatto <thierry.volpiattoNOSPAMgmail.com>
+
+;; Keywords: dired async byte-compile
+;; X-URL: https://github.com/jwiegley/dired-async
+
+;; This program is free software; you can 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 program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR 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 package provide the `async-byte-recompile-directory' function
+;; which allows, as the name says to recompile a directory outside of
+;; your running emacs.
+;; The benefit is your files will be compiled in a clean environment without
+;; the old *.el files loaded.
+;; Among other things, this fix a bug in package.el which recompile
+;; the new files in the current environment with the old files loaded, creating
+;; errors in most packages after upgrades.
+;;
+;; NB: This package is advicing the function `package--compile'.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'async)
+
+(defcustom async-bytecomp-allowed-packages
+ '(async helm helm-core helm-ls-git helm-ls-hg magit)
+ "Packages in this list will be compiled asynchronously by `package--compile'.
+All the dependencies of these packages will be compiled async too,
+so no need to add dependencies to this list.
+The value of this variable can also be a list with a single element,
+the symbol `all', in this case packages are always compiled asynchronously."
+ :group 'async
+ :type '(repeat (choice symbol)))
+
+(defvar async-byte-compile-log-file "~/.emacs.d/async-bytecomp.log")
+
+;;;###autoload
+(defun async-byte-recompile-directory (directory &optional quiet)
+ "Compile all *.el files in DIRECTORY asynchronously.
+All *.elc files are systematically deleted before proceeding."
+ (cl-loop with dir = (directory-files directory t "\\.elc\\'")
+ unless dir return nil
+ for f in dir
+ when (file-exists-p f) do (delete-file f))
+ ;; Ensure async is reloaded when async.elc is deleted.
+ ;; This happen when recompiling its own directory.
+ (load "async")
+ (let ((call-back
+ (lambda (&optional _ignore)
+ (if (file-exists-p async-byte-compile-log-file)
+ (let ((buf (get-buffer-create byte-compile-log-buffer))
+ (n 0))
+ (with-current-buffer buf
+ (goto-char (point-max))
+ (let ((inhibit-read-only t))
+ (insert-file-contents async-byte-compile-log-file)
+ (compilation-mode))
+ (display-buffer buf)
+ (delete-file async-byte-compile-log-file)
+ (unless quiet
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^.*:Error:" nil t)
+ (cl-incf n)))
+ (if (> n 0)
+ (message "Failed to compile %d files in directory `%s'" n directory)
+ (message "Directory `%s' compiled asynchronously with warnings" directory)))))
+ (unless quiet
+ (message "Directory `%s' compiled asynchronously with success" directory))))))
+ (async-start
+ `(lambda ()
+ (require 'bytecomp)
+ ,(async-inject-variables "\\`\\(load-path\\)\\|byte\\'")
+ (let ((default-directory (file-name-as-directory ,directory))
+ error-data)
+ (add-to-list 'load-path default-directory)
+ (byte-recompile-directory ,directory 0 t)
+ (when (get-buffer byte-compile-log-buffer)
+ (setq error-data (with-current-buffer byte-compile-log-buffer
+ (buffer-substring-no-properties (point-min) (point-max))))
+ (unless (string= error-data "")
+ (with-temp-file ,async-byte-compile-log-file
+ (erase-buffer)
+ (insert error-data))))))
+ call-back)
+ (unless quiet (message "Started compiling asynchronously directory %s" directory))))
+
+(defvar package-archive-contents)
+(defvar package-alist)
+(declare-function package-desc-reqs "package.el" (cl-x))
+
+(defun async-bytecomp--get-package-deps (pkg &optional only)
+ ;; Same as `package--get-deps' but parse instead `package-archive-contents'
+ ;; because PKG is not already installed and not present in `package-alist'.
+ ;; However fallback to `package-alist' in case PKG no more present
+ ;; in `package-archive-contents' due to modification to `package-archives'.
+ ;; See issue #58.
+ (let* ((pkg-desc (cadr (or (assq pkg package-archive-contents)
+ (assq pkg package-alist))))
+ (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc)
+ for name = (car p)
+ when (or (assq name package-archive-contents)
+ (assq name package-alist))
+ collect name))
+ (indirect-deps (unless (eq only 'direct)
+ (delete-dups
+ (cl-loop for p in direct-deps append
+ (async-bytecomp--get-package-deps p))))))
+ (cl-case only
+ (direct direct-deps)
+ (separate (list direct-deps indirect-deps))
+ (indirect indirect-deps)
+ (t (delete-dups (append direct-deps indirect-deps))))))
+
+(defun async-bytecomp-get-allowed-pkgs ()
+ (when (and async-bytecomp-allowed-packages
+ (listp async-bytecomp-allowed-packages))
+ (if package-archive-contents
+ (cl-loop for p in async-bytecomp-allowed-packages
+ when (assq p package-archive-contents)
+ append (async-bytecomp--get-package-deps p) into reqs
+ finally return
+ (delete-dups
+ (append async-bytecomp-allowed-packages reqs)))
+ async-bytecomp-allowed-packages)))
+
+(defadvice package--compile (around byte-compile-async)
+ (let ((cur-package (package-desc-name pkg-desc))
+ (pkg-dir (package-desc-dir pkg-desc)))
+ (if (or (equal async-bytecomp-allowed-packages '(all))
+ (memq cur-package (async-bytecomp-get-allowed-pkgs)))
+ (progn
+ (when (eq cur-package 'async)
+ (fmakunbound 'async-byte-recompile-directory))
+ ;; Add to `load-path' the latest version of async and
+ ;; reload it when reinstalling async.
+ (when (string= cur-package "async")
+ (cl-pushnew pkg-dir load-path)
+ (load "async-bytecomp"))
+ ;; `async-byte-recompile-directory' will add directory
+ ;; as needed to `load-path'.
+ (async-byte-recompile-directory (package-desc-dir pkg-desc) t))
+ ad-do-it)))
+
+;;;###autoload
+(define-minor-mode async-bytecomp-package-mode
+ "Byte compile asynchronously packages installed with package.el.
+Async compilation of packages can be controlled by
+`async-bytecomp-allowed-packages'."
+ :group 'async
+ :global t
+ (if async-bytecomp-package-mode
+ (ad-activate 'package--compile)
+ (ad-deactivate 'package--compile)))
+
+(provide 'async-bytecomp)
+
+;;; async-bytecomp.el ends here
--- /dev/null
+(define-package "async" "20170916.2256" "Asynchronous processing in Emacs" 'nil :keywords
+ '("async")
+ :url "https://github.com/jwiegley/emacs-async")
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
--- /dev/null
+;;; async.el --- Asynchronous processing in Emacs -*- lexical-binding: t -*-
+
+;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
+
+;; Author: John Wiegley <jwiegleyNOSPAMgmail.com>
+;; Created: 18 Jun 2012
+;; Version: 1.9.2
+
+;; Keywords: async
+;; X-URL: https://github.com/jwiegley/emacs-async
+
+;; This program is free software; you can 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 program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR 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.
+\f
+;;; Commentary:
+
+;; Adds the ability to call asynchronous functions and process with ease. See
+;; the documentation for `async-start' and `async-start-process'.
+\f
+;;; Code:
+
+(defgroup async nil
+ "Simple asynchronous processing in Emacs"
+ :group 'emacs)
+
+(defvar async-debug nil)
+(defvar async-send-over-pipe t)
+(defvar async-in-child-emacs nil)
+(defvar async-callback nil)
+(defvar async-callback-for-process nil)
+(defvar async-callback-value nil)
+(defvar async-callback-value-set nil)
+(defvar async-current-process nil)
+(defvar async--procvar nil)
+
+(defun async-inject-variables
+ (include-regexp &optional predicate exclude-regexp)
+ "Return a `setq' form that replicates part of the calling environment.
+It sets the value for every variable matching INCLUDE-REGEXP and
+also PREDICATE. It will not perform injection for any variable
+matching EXCLUDE-REGEXP (if present). It is intended to be used
+as follows:
+
+ (async-start
+ `(lambda ()
+ (require 'smtpmail)
+ (with-temp-buffer
+ (insert ,(buffer-substring-no-properties (point-min) (point-max)))
+ ;; Pass in the variable environment for smtpmail
+ ,(async-inject-variables \"\\`\\(smtpmail\\|\\(user-\\)?mail\\)-\")
+ (smtpmail-send-it)))
+ 'ignore)"
+ `(setq
+ ,@(let (bindings)
+ (mapatoms
+ (lambda (sym)
+ (if (and (boundp sym)
+ (or (null include-regexp)
+ (string-match include-regexp (symbol-name sym)))
+ (not (string-match
+ (or exclude-regexp "-syntax-table\\'")
+ (symbol-name sym))))
+ (let ((value (symbol-value sym)))
+ (when (or (null predicate)
+ (funcall predicate sym))
+ (setq bindings (cons `(quote ,value) bindings)
+ bindings (cons sym bindings)))))))
+ bindings)))
+
+(defalias 'async-inject-environment 'async-inject-variables)
+
+(defun async-handle-result (func result buf)
+ (if (null func)
+ (progn
+ (set (make-local-variable 'async-callback-value) result)
+ (set (make-local-variable 'async-callback-value-set) t))
+ (unwind-protect
+ (if (and (listp result)
+ (eq 'async-signal (nth 0 result)))
+ (signal (car (nth 1 result))
+ (cdr (nth 1 result)))
+ (funcall func result))
+ (unless async-debug
+ (kill-buffer buf)))))
+
+(defun async-when-done (proc &optional _change)
+ "Process sentinel used to retrieve the value from the child process."
+ (when (eq 'exit (process-status proc))
+ (with-current-buffer (process-buffer proc)
+ (let ((async-current-process proc))
+ (if (= 0 (process-exit-status proc))
+ (if async-callback-for-process
+ (if async-callback
+ (prog1
+ (funcall async-callback proc)
+ (unless async-debug
+ (kill-buffer (current-buffer))))
+ (set (make-local-variable 'async-callback-value) proc)
+ (set (make-local-variable 'async-callback-value-set) t))
+ (goto-char (point-max))
+ (backward-sexp)
+ (async-handle-result async-callback (read (current-buffer))
+ (current-buffer)))
+ (set (make-local-variable 'async-callback-value)
+ (list 'error
+ (format "Async process '%s' failed with exit code %d"
+ (process-name proc) (process-exit-status proc))))
+ (set (make-local-variable 'async-callback-value-set) t))))))
+
+(defun async--receive-sexp (&optional stream)
+ (let ((sexp (decode-coding-string (base64-decode-string
+ (read stream)) 'utf-8-unix))
+ ;; Parent expects UTF-8 encoded text.
+ (coding-system-for-write 'utf-8-unix))
+ (if async-debug
+ (message "Received sexp {{{%s}}}" (pp-to-string sexp)))
+ (setq sexp (read sexp))
+ (if async-debug
+ (message "Read sexp {{{%s}}}" (pp-to-string sexp)))
+ (eval sexp)))
+
+(defun async--insert-sexp (sexp)
+ (let (print-level
+ print-length
+ (print-escape-nonascii t)
+ (print-circle t))
+ (prin1 sexp (current-buffer))
+ ;; Just in case the string we're sending might contain EOF
+ (encode-coding-region (point-min) (point-max) 'utf-8-unix)
+ (base64-encode-region (point-min) (point-max) t)
+ (goto-char (point-min)) (insert ?\")
+ (goto-char (point-max)) (insert ?\" ?\n)))
+
+(defun async--transmit-sexp (process sexp)
+ (with-temp-buffer
+ (if async-debug
+ (message "Transmitting sexp {{{%s}}}" (pp-to-string sexp)))
+ (async--insert-sexp sexp)
+ (process-send-region process (point-min) (point-max))))
+
+(defun async-batch-invoke ()
+ "Called from the child Emacs process' command-line."
+ ;; Make sure 'message' and 'prin1' encode stuff in UTF-8, as parent
+ ;; process expects.
+ (let ((coding-system-for-write 'utf-8-unix))
+ (setq async-in-child-emacs t
+ debug-on-error async-debug)
+ (if debug-on-error
+ (prin1 (funcall
+ (async--receive-sexp (unless async-send-over-pipe
+ command-line-args-left))))
+ (condition-case err
+ (prin1 (funcall
+ (async--receive-sexp (unless async-send-over-pipe
+ command-line-args-left))))
+ (error
+ (prin1 (list 'async-signal err)))))))
+
+(defun async-ready (future)
+ "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))
+ (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))
+ (sleep-for 0.05)))
+
+(defun async-get (future)
+ "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."
+ (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."
+ (and (listp value)
+ (plist-get value :async-message)))
+
+(defun async-send (&rest args)
+ "Send the given messages to the asychronous Emacs PROCESS."
+ (let ((args (append args '(:async-message t))))
+ (if async-in-child-emacs
+ (if async-callback
+ (funcall async-callback args))
+ (async--transmit-sexp (car args) (list 'quote (cdr args))))))
+
+(defun async-receive ()
+ "Send the given messages to the asychronous Emacs PROCESS."
+ (async--receive-sexp))
+
+;;;###autoload
+(defun async-start-process (name program finish-func &rest program-args)
+ "Start the executable PROGRAM asynchronously. See `async-start'.
+PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the
+process object when done. If FINISH-FUNC is nil, the future
+object will return the process object when the program is
+finished. Set DEFAULT-DIRECTORY to change PROGRAM's current
+working directory."
+ (let* ((buf (generate-new-buffer (concat "*" name "*")))
+ (proc (let ((process-connection-type nil))
+ (apply #'start-process name buf program program-args))))
+ (with-current-buffer buf
+ (set (make-local-variable 'async-callback) finish-func)
+ (set-process-sentinel proc #'async-when-done)
+ (unless (string= name "emacs")
+ (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.
+When done, the return value is passed to FINISH-FUNC. Example:
+
+ (async-start
+ ;; What to do in the child process
+ (lambda ()
+ (message \"This is a test\")
+ (sleep-for 3)
+ 222)
+
+ ;; What to do when it finishes
+ (lambda (result)
+ (message \"Async process done, result should be 222: %s\"
+ result)))
+
+If FINISH-FUNC is nil or missing, a future is returned that can
+be inspected using `async-get', blocking until the value is
+ready. Example:
+
+ (let ((proc (async-start
+ ;; What to do in the child process
+ (lambda ()
+ (message \"This is a test\")
+ (sleep-for 3)
+ 222))))
+
+ (message \"I'm going to do some work here\") ;; ....
+
+ (message \"Waiting on async process, result should be 222: %s\"
+ (async-get proc)))
+
+If you don't want to use a callback, and you don't care about any
+return value from the child process, pass the `ignore' symbol as
+the second argument (if you don't, and never call `async-get', it
+will leave *emacs* process buffers hanging around):
+
+ (async-start
+ (lambda ()
+ (delete-file \"a remote file on a slow link\" nil))
+ 'ignore)
+
+Note: Even when FINISH-FUNC is present, a future is still
+returned except that it yields no value (since the value is
+passed to FINISH-FUNC). Call `async-get' on such a future always
+returns nil. It can still be useful, however, as an argument to
+`async-ready' or `async-wait'."
+ (let ((sexp start-func)
+ ;; Subordinate Emacs will send text encoded in UTF-8.
+ (coding-system-for-read 'utf-8-unix))
+ (setq async--procvar
+ (async-start-process
+ "emacs" (file-truename
+ (expand-file-name invocation-name
+ invocation-directory))
+ finish-func
+ async-quiet-switch "-l"
+ ;; Using `locate-library' ensure we use the right file
+ ;; when the .elc have been deleted.
+ (locate-library "async")
+ "-batch" "-f" "async-batch-invoke"
+ (if async-send-over-pipe
+ "<none>"
+ (with-temp-buffer
+ (async--insert-sexp (list 'quote sexp))
+ (buffer-string)))))
+ (if async-send-over-pipe
+ (async--transmit-sexp async--procvar (list 'quote sexp)))
+ async--procvar))
+
+(defmacro async-sandbox(func)
+ "Evaluate FUNC in a separate Emacs process, synchronously."
+ `(async-get (async-start ,func)))
+
+(defun async--fold-left (fn forms bindings)
+ (let ((res forms))
+ (dolist (binding bindings)
+ (setq res (funcall fn res
+ (if (listp binding)
+ binding
+ (list binding)))))
+ res))
+
+(defmacro async-let (bindings &rest forms)
+ "Implements `let', but each binding is established asynchronously.
+For example:
+
+ (async-let ((x (foo))
+ (y (bar)))
+ (message \"%s %s\" x y))
+
+ expands to ==>
+
+ (async-start (foo)
+ (lambda (x)
+ (async-start (bar)
+ (lambda (y)
+ (message \"%s %s\" x y)))))"
+ (declare (indent 1))
+ (async--fold-left
+ (lambda (acc binding)
+ (let ((fun (pcase (cadr binding)
+ ((and (pred functionp) f) f)
+ (f `(lambda () ,f)))))
+ `(async-start ,fun
+ (lambda (,(car binding))
+ ,acc))))
+ `(progn ,@forms)
+ (reverse bindings)))
+
+(provide 'async)
+
+;;; async.el ends here
--- /dev/null
+;;; dired-async.el --- Asynchronous dired actions -*- lexical-binding: t -*-
+
+;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
+
+;; Authors: John Wiegley <jwiegleyNOSPAMgmail.com>
+;; Thierry Volpiatto <thierry.volpiattoNOSPAMgmail.com>
+
+;; Keywords: dired async network
+;; X-URL: https://github.com/jwiegley/dired-async
+
+;; This program is free software; you can 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 program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR 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.
+\f
+;;; Commentary:
+
+;; This file provide a redefinition of `dired-create-file' function,
+;; performs copies, moves and all what is handled by `dired-create-file'
+;; in the background using a slave Emacs process,
+;; by means of the async.el module.
+;; To use it, put this in your .emacs:
+
+;; (dired-async-mode 1)
+
+;; This will enable async copy/rename etc...
+;; in dired and helm.
+
+;;; Code:
+\f
+(require 'cl-lib)
+(require 'dired-aux)
+(require 'async)
+
+(eval-when-compile
+ (defvar async-callback))
+
+(defgroup dired-async nil
+ "Copy rename files asynchronously from dired."
+ :group 'dired)
+
+(defcustom dired-async-env-variables-regexp
+ "\\`\\(tramp-\\(default\\|connection\\|remote\\)\\|ange-ftp\\)-.*"
+ "Variables matching this regexp will be loaded on Child Emacs."
+ :type 'regexp
+ :group 'dired-async)
+
+(defcustom dired-async-message-function 'dired-async-mode-line-message
+ "Function to use to notify result when operation finish.
+Should take same args as `message'."
+ :group 'dired-async
+ :type 'function)
+
+(defcustom dired-async-log-file "/tmp/dired-async.log"
+ "File use to communicate errors from Child Emacs to host Emacs."
+ :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."
+ :group 'dired-async)
+
+(defface dired-async-failures
+ '((t (:foreground "red")))
+ "Face used for mode-line message."
+ :group 'dired-async)
+
+(defface dired-async-mode-message
+ '((t (:foreground "Gold")))
+ "Face used for `dired-async--modeline-mode' lighter."
+ :group 'dired-async)
+
+(define-minor-mode dired-async--modeline-mode
+ "Notify mode-line that an async process run."
+ :group 'dired-async
+ :global t
+ :lighter (:eval (propertize (format " [%s Async job(s) running]"
+ (length (dired-async-processes)))
+ 'face 'dired-async-mode-message))
+ (unless dired-async--modeline-mode
+ (let ((visible-bell t)) (ding))))
+
+(defun dired-async-mode-line-message (text face &rest args)
+ "Notify end of operation in `mode-line'."
+ (message nil)
+ (let ((mode-line-format (concat
+ " " (propertize
+ (if args
+ (apply #'format text args)
+ text)
+ 'face face))))
+ (force-mode-line-update)
+ (sit-for 3)
+ (force-mode-line-update)))
+
+(defun dired-async-processes ()
+ (cl-loop for p in (process-list)
+ when (cl-loop for c in (process-command p) thereis
+ (string= "async-batch-invoke" c))
+ collect p))
+
+(defun dired-async-kill-process ()
+ (interactive)
+ (let* ((processes (dired-async-processes))
+ (proc (car (last processes))))
+ (and proc (delete-process proc))
+ (unless (> (length processes) 1)
+ (dired-async--modeline-mode -1))))
+
+(defun dired-async-after-file-create (total operation failures skipped)
+ "Callback function used for operation handled by `dired-create-file'."
+ (unless (dired-async-processes)
+ ;; Turn off mode-line notification
+ ;; only when last process end.
+ (dired-async--modeline-mode -1))
+ (when operation
+ (if (file-exists-p dired-async-log-file)
+ (progn
+ (pop-to-buffer (get-buffer-create dired-log-buffer))
+ (goto-char (point-max))
+ (setq inhibit-read-only t)
+ (insert "Error: ")
+ (insert-file-contents dired-async-log-file)
+ (special-mode)
+ (shrink-window-if-larger-than-buffer)
+ (delete-file dired-async-log-file))
+ (run-with-timer
+ 0.1 nil
+ (lambda ()
+ ;; First send error messages.
+ (cond (failures
+ (funcall dired-async-message-function
+ "%s failed for %d of %d file%s -- See *Dired log* buffer"
+ 'dired-async-failures
+ (car operation) (length failures)
+ total (dired-plural-s total)))
+ (skipped
+ (funcall dired-async-message-function
+ "%s: %d of %d file%s skipped -- See *Dired log* buffer"
+ 'dired-async-failures
+ (car operation) (length skipped) total
+ (dired-plural-s total))))
+ ;; Finally send the success message.
+ (funcall dired-async-message-function
+ "Asynchronous %s of %s on %s file%s done"
+ 'dired-async-message
+ (car operation) (cadr operation)
+ total (dired-plural-s total)))))))
+
+(defun dired-async-maybe-kill-ftp ()
+ "Return a form to kill ftp process in child emacs."
+ (quote
+ (progn
+ (require 'cl-lib)
+ (let ((buf (cl-loop for b in (buffer-list)
+ thereis (and (string-match
+ "\\`\\*ftp.*"
+ (buffer-name b)) b))))
+ (when buf (kill-buffer buf))))))
+
+(defvar overwrite-query)
+(defun dired-async-create-files (file-creator operation fn-list name-constructor
+ &optional _marker-char)
+ "Same as `dired-create-files' but asynchronous.
+
+See `dired-create-files' for the behavior of arguments."
+ (setq overwrite-query nil)
+ (let ((total (length fn-list))
+ failures async-fn-list skipped callback
+ async-quiet-switch)
+ (let (to)
+ (dolist (from fn-list)
+ (setq to (funcall name-constructor 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"
+ (downcase operation) from)))
+ (if (not to)
+ (setq skipped (cons (dired-make-relative from) skipped))
+ (let* ((overwrite (and (null (eq file-creator 'backup-file))
+ (file-exists-p to)))
+ (dired-overwrite-confirmed ; for dired-handle-overwrite
+ (and overwrite
+ (let ((help-form `(format "\
+Type SPC or `y' to overwrite file `%s',
+DEL or `n' to skip to next,
+ESC or `q' to not overwrite any of the remaining files,
+`!' to overwrite all remaining files with no more questions." ,to)))
+ (dired-query 'overwrite-query "Overwrite `%s'?" to)))))
+ ;; Handle the `dired-copy-file' file-creator specially
+ ;; When copying a directory to another directory or
+ ;; possibly to itself or one of its subdirectories.
+ ;; e.g "~/foo/" => "~/test/"
+ ;; or "~/foo/" =>"~/foo/"
+ ;; or "~/foo/ => ~/foo/bar/")
+ ;; In this case the 'name-constructor' have set the destination
+ ;; TO to "~/test/foo" because the old emacs23 behavior
+ ;; of `copy-directory' was to not create the subdirectory
+ ;; and instead copy the contents.
+ ;; With the new behavior of `copy-directory'
+ ;; (similar to the `cp' shell command) we don't
+ ;; need such a construction of the target directory,
+ ;; so modify the destination TO to "~/test/" instead of "~/test/foo/".
+ (let ((destname (file-name-directory to)))
+ (when (and (file-directory-p from)
+ (file-directory-p to)
+ (eq file-creator 'dired-copy-file))
+ (setq to destname))
+ ;; If DESTNAME is a subdirectory of FROM, not a symlink,
+ ;; and the method in use is copying, signal an error.
+ (and (eq t (car (file-attributes destname)))
+ (eq file-creator 'dired-copy-file)
+ (file-in-directory-p destname from)
+ (error "Cannot copy `%s' into its subdirectory `%s'"
+ from to)))
+ (if overwrite
+ (or (and dired-overwrite-confirmed
+ (push (cons from to) async-fn-list))
+ (progn
+ (push (dired-make-relative from) failures)
+ (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
+ ;; had to be copied and user finally answer NO.
+ ;; In this case async process will never start and callback
+ ;; will have no chance to run, so notify failures here.
+ (unless async-fn-list
+ (cond (failures
+ (funcall dired-async-message-function
+ "%s failed for %d of %d file%s -- See *Dired log* buffer"
+ 'dired-async-failures
+ operation (length failures)
+ total (dired-plural-s total)))
+ (skipped
+ (funcall dired-async-message-function
+ "%s: %d of %d file%s skipped -- See *Dired log* buffer"
+ 'dired-async-failures
+ operation (length skipped) total
+ (dired-plural-s total)))))
+ ;; Setup callback.
+ (setq callback
+ (lambda (&optional _ignore)
+ (dired-async-after-file-create
+ total (list operation (length async-fn-list)) failures skipped)
+ (when (string= (downcase operation) "rename")
+ (cl-loop for (file . to) in async-fn-list
+ for bf = (get-file-buffer file)
+ for destp = (file-exists-p to)
+ do (and bf destp
+ (with-current-buffer bf
+ (set-visited-file-name to t t))))))))
+ ;; Start async process.
+ (when async-fn-list
+ (async-start `(lambda ()
+ (require 'cl-lib) (require 'dired-aux) (require 'dired-x)
+ ,(async-inject-variables dired-async-env-variables-regexp)
+ (let ((dired-recursive-copies (quote always))
+ (dired-copy-preserve-time
+ ,dired-copy-preserve-time))
+ (setq overwrite-backup-query nil)
+ ;; Inline `backup-file' as long as it is not
+ ;; available in emacs.
+ (defalias 'backup-file
+ ;; 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.
+ (lambda (from to ok)
+ (cond ((file-directory-p from) (ignore))
+ (t (let ((count 0))
+ (while (let ((attrs (file-attributes to)))
+ (and attrs (null (nth 0 attrs))))
+ (cl-incf count)
+ (setq to (concat (file-name-sans-versions to)
+ (format ".~%s~" count)))))
+ (condition-case err
+ (copy-file from to ok dired-copy-preserve-time)
+ (file-date-error
+ (dired-log "Can't set date on %s:\n%s\n" from err)))))))
+ ;; Now run the FILE-CREATOR function on files.
+ (cl-loop with fn = (quote ,file-creator)
+ for (from . dest) in (quote ,async-fn-list)
+ do (condition-case err
+ (funcall fn from dest t)
+ (file-error
+ (dired-log "%s: %s\n" (car err) (cdr err)))
+ nil))
+ (when (get-buffer dired-log-buffer)
+ (dired-log t)
+ (with-current-buffer dired-log-buffer
+ (write-region (point-min) (point-max)
+ ,dired-async-log-file))))
+ ,(dired-async-maybe-kill-ftp))
+ callback)
+ ;; Run mode-line notifications while process running.
+ (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."
+ :group 'dired-async
+ :lighter dired-async-mode-lighter
+ :global t
+ (if dired-async-mode
+ (if (fboundp 'advice-add)
+ (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)
+ (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)
+
+;;; dired-async.el ends here
--- /dev/null
+;;; smtpmail-async.el --- Send e-mail with smtpmail.el asynchronously -*- lexical-binding: t -*-
+
+;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
+
+;; Author: John Wiegley <jwiegleyNOSPAMgmail.com>
+;; Created: 18 Jun 2012
+
+;; Keywords: email async
+;; X-URL: https://github.com/jwiegley/emacs-async
+
+;; This program is free software; you can 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 program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR 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.
+\f
+;;; Commentary:
+
+;; Send e-mail with smtpmail.el asynchronously. To use:
+;;
+;; (require 'smtpmail-async)
+;;
+;; (setq send-mail-function 'async-smtpmail-send-it
+;; message-send-mail-function 'async-smtpmail-send-it)
+;;
+;; This assumes you already have smtpmail.el working.
+
+;;; Code:
+
+(defgroup smtpmail-async nil
+ "Send e-mail with smtpmail.el asynchronously"
+ :group 'smptmail)
+
+(require 'async)
+(require 'smtpmail)
+(require 'message)
+
+(defvar async-smtpmail-before-send-hook nil
+ "Hook running in the child emacs in `async-smtpmail-send-it'.
+It is called just before calling `smtpmail-send-it'.")
+
+(defun async-smtpmail-send-it ()
+ (let ((to (message-field-value "To"))
+ (buf-content (buffer-substring-no-properties
+ (point-min) (point-max))))
+ (message "Delivering message to %s..." to)
+ (async-start
+ `(lambda ()
+ (require 'smtpmail)
+ (with-temp-buffer
+ (insert ,buf-content)
+ (set-buffer-multibyte nil)
+ ;; Pass in the variable environment for smtpmail
+ ,(async-inject-variables
+ "\\`\\(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)))
+ (lambda (&optional _ignore)
+ (message "Delivering message to %s...done" to)))))
+
+(provide 'smtpmail-async)
+
+;;; smtpmail-async.el ends here
--- /dev/null
+;;; cider-apropos.el --- Apropos functionality for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2017 Jeff Valk, Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Apropos functionality for Clojure.
+
+;;; Code:
+
+(require 'cider-doc)
+(require 'cider-util)
+(require 'subr-x)
+(require 'cider-compat)
+
+(require 'cider-client)
+(require 'cider-popup)
+(require 'nrepl-dict)
+
+(require 'clojure-mode)
+(require 'apropos)
+(require 'button)
+
+(defconst cider-apropos-buffer "*cider-apropos*")
+
+(push cider-apropos-buffer cider-ancillary-buffers)
+
+(defcustom cider-apropos-actions '(("display-doc" . cider-doc-lookup)
+ ("find-def" . cider--find-var)
+ ("lookup-on-grimoire" . cider-grimoire-lookup))
+ "Controls the actions to be applied on the symbol found by an apropos search.
+The first action key in the list will be selected as default. If the list
+contains only one action key, the associated action function will be
+applied automatically. An action function can be any function that receives
+the symbol found by the apropos search as argument."
+ :type '(alist :key-type string :value-type function)
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defun cider-apropos-doc (button)
+ "Display documentation for the symbol represented at BUTTON."
+ (cider-doc-lookup (button-get button 'apropos-symbol)))
+
+(defun cider-apropos-summary (query ns docs-p include-private-p case-sensitive-p)
+ "Return a short description for the performed apropos search.
+
+QUERY can be a regular expression list of space-separated words
+\(e.g take while) which will be converted to a regular expression
+\(like take.+while) automatically behind the scenes. The search may be
+limited to the namespace NS, and may optionally search doc strings
+\(based on DOCS-P), include private vars (based on INCLUDE-PRIVATE-P),
+and be case-sensitive (based on CASE-SENSITIVE-P)."
+ (concat (if case-sensitive-p "Case-sensitive " "")
+ (if docs-p "Documentation " "")
+ (format "Apropos for %S" query)
+ (if ns (format " in namespace %S" ns) "")
+ (if include-private-p
+ " (public and private symbols)"
+ " (public symbols only)")))
+
+(defun cider-apropos-highlight (doc query)
+ "Return the DOC string propertized to highlight QUERY matches."
+ (let ((pos 0))
+ (while (string-match query doc pos)
+ (setq pos (match-end 0))
+ (put-text-property (match-beginning 0)
+ (match-end 0)
+ 'font-lock-face apropos-match-face doc)))
+ doc)
+
+(defun cider-apropos-result (result query docs-p)
+ "Emit a RESULT matching QUERY into current buffer, formatted for DOCS-P."
+ (nrepl-dbind-response result (name type doc)
+ (let* ((label (capitalize (if (string= type "variable") "var" type)))
+ (help (concat "Display doc for this " (downcase label))))
+ (cider-propertize-region (list 'apropos-symbol name
+ 'action 'cider-apropos-doc
+ 'help-echo help)
+ (insert-text-button name 'type 'apropos-symbol)
+ (insert "\n ")
+ (insert-text-button label 'type (intern (concat "apropos-" type)))
+ (insert ": ")
+ (let ((beg (point)))
+ (if docs-p
+ (insert (cider-apropos-highlight doc query) "\n")
+ (insert doc)
+ (fill-region beg (point))))
+ (insert "\n")))))
+
+(declare-function cider-mode "cider-mode")
+
+(defun cider-show-apropos (summary results query docs-p)
+ "Show SUMMARY and RESULTS for QUERY in a pop-up buffer, formatted for DOCS-P."
+ (with-current-buffer (cider-popup-buffer cider-apropos-buffer t)
+ (let ((inhibit-read-only t))
+ (apropos-mode)
+ (if (boundp 'header-line-format)
+ (setq-local header-line-format summary)
+ (insert summary "\n\n"))
+ (dolist (result results)
+ (cider-apropos-result result query docs-p))
+ (goto-char (point-min)))))
+
+;;;###autoload
+(defun cider-apropos (query &optional ns docs-p privates-p case-sensitive-p)
+ "Show all symbols whose names match QUERY, a regular expression.
+QUERY can also be a list of space-separated words (e.g. take while) which
+will be converted to a regular expression (like take.+while) automatically
+behind the scenes. The search may be limited to the namespace NS, and may
+optionally search doc strings (based on DOCS-P), include private vars
+\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P)."
+ (interactive
+ (cons (read-string "Search for Clojure symbol (a regular expression): ")
+ (when current-prefix-arg
+ (list (let ((ns (completing-read "Namespace (default is all): " (cider-sync-request:ns-list))))
+ (if (string= ns "") nil ns))
+ (y-or-n-p "Search doc strings? ")
+ (y-or-n-p "Include private symbols? ")
+ (y-or-n-p "Case-sensitive? ")))))
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "apropos")
+ (if-let ((summary (cider-apropos-summary
+ query ns docs-p privates-p case-sensitive-p))
+ (results (cider-sync-request:apropos query ns docs-p privates-p case-sensitive-p)))
+ (cider-show-apropos summary results query docs-p)
+ (message "No apropos matches for %S" query)))
+
+;;;###autoload
+(defun cider-apropos-documentation ()
+ "Shortcut for (cider-apropos <query> nil t)."
+ (interactive)
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "apropos")
+ (cider-apropos (read-string "Search for Clojure documentation (a regular expression): ") nil t))
+
+(defun cider-apropos-act-on-symbol (symbol)
+ "Apply selected action on SYMBOL."
+ (let* ((first-action-key (car (car cider-apropos-actions)))
+ (action-key (if (= 1 (length cider-apropos-actions))
+ first-action-key
+ (completing-read (format "Choose action to apply to `%s` (default %s): "
+ symbol first-action-key)
+ cider-apropos-actions nil nil nil nil first-action-key)))
+ (action-fn (cdr (assoc action-key cider-apropos-actions))))
+ (if action-fn
+ (funcall action-fn symbol)
+ (user-error "Unknown action `%s`" action-key))))
+
+;;;###autoload
+(defun cider-apropos-select (query &optional ns docs-p privates-p case-sensitive-p)
+ "Similar to `cider-apropos', but presents the results in a completing read.
+
+Show all symbols whose names match QUERY, a regular expression.
+QUERY can also be a list of space-separated words (e.g. take while) which
+will be converted to a regular expression (like take.+while) automatically
+behind the scenes. The search may be limited to the namespace NS, and may
+optionally search doc strings (based on DOCS-P), include private vars
+\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P)."
+ (interactive
+ (cons (read-string "Search for Clojure symbol (a regular expression): ")
+ (when current-prefix-arg
+ (list (let ((ns (completing-read "Namespace (default is all): " (cider-sync-request:ns-list))))
+ (if (string= ns "") nil ns))
+ (y-or-n-p "Search doc strings? ")
+ (y-or-n-p "Include private symbols? ")
+ (y-or-n-p "Case-sensitive? ")))))
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "apropos")
+ (if-let ((summary (cider-apropos-summary
+ query ns docs-p privates-p case-sensitive-p))
+ (results (mapcar (lambda (r) (nrepl-dict-get r "name"))
+ (cider-sync-request:apropos query ns docs-p privates-p case-sensitive-p))))
+ (cider-apropos-act-on-symbol (completing-read (concat summary ": ") results))
+ (message "No apropos matches for %S" query)))
+
+;;;###autoload
+(defun cider-apropos-documentation-select ()
+ "Shortcut for (cider-apropos-select <query> nil t)."
+ (interactive)
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "apropos")
+ (cider-apropos-select (read-string "Search for Clojure documentation (a regular expression): ") nil t))
+
+(provide 'cider-apropos)
+
+;;; cider-apropos.el ends here
--- /dev/null
+;;; cider-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
+\f
+;;;### (autoloads nil "cider" "cider.el" (22692 30287 0 0))
+;;; Generated autoloads from cider.el
+
+(autoload 'cider-version "cider" "\
+Display CIDER's version.
+
+\(fn)" t nil)
+
+(autoload 'cider-jack-in "cider" "\
+Start an nREPL server for the current project and connect to it.
+If PROMPT-PROJECT is t, then prompt for the project for which to
+start the server.
+If CLJS-TOO is non-nil, also start a ClojureScript REPL session with its
+own buffer.
+
+\(fn &optional PROMPT-PROJECT CLJS-TOO)" t nil)
+
+(autoload 'cider-jack-in-clojurescript "cider" "\
+Start an nREPL server and connect to it both Clojure and ClojureScript REPLs.
+If PROMPT-PROJECT is t, then prompt for the project for which to
+start the server.
+
+\(fn &optional PROMPT-PROJECT)" t nil)
+
+(autoload 'cider-connect "cider" "\
+Connect to an nREPL server identified by HOST and PORT.
+Create REPL buffer and start an nREPL client connection.
+
+When the optional param PROJECT-DIR is present, the connection
+gets associated with it.
+
+\(fn HOST PORT &optional PROJECT-DIR)" t nil)
+
+(eval-after-load 'clojure-mode '(progn (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in) (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-clojurescript) (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect)))
+
+;;;***
+\f
+;;;### (autoloads nil "cider-apropos" "cider-apropos.el" (22692 30287
+;;;;;; 0 0))
+;;; Generated autoloads from cider-apropos.el
+
+(autoload 'cider-apropos "cider-apropos" "\
+Show all symbols whose names match QUERY, a regular expression.
+QUERY can also be a list of space-separated words (e.g. take while) which
+will be converted to a regular expression (like take.+while) automatically
+behind the scenes. The search may be limited to the namespace NS, and may
+optionally search doc strings (based on DOCS-P), include private vars
+\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P).
+
+\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil)
+
+(autoload 'cider-apropos-documentation "cider-apropos" "\
+Shortcut for (cider-apropos <query> nil t).
+
+\(fn)" t nil)
+
+(autoload 'cider-apropos-select "cider-apropos" "\
+Similar to `cider-apropos', but presents the results in a completing read.
+
+Show all symbols whose names match QUERY, a regular expression.
+QUERY can also be a list of space-separated words (e.g. take while) which
+will be converted to a regular expression (like take.+while) automatically
+behind the scenes. The search may be limited to the namespace NS, and may
+optionally search doc strings (based on DOCS-P), include private vars
+\(based on PRIVATES-P), and be case-sensitive (based on CASE-SENSITIVE-P).
+
+\(fn QUERY &optional NS DOCS-P PRIVATES-P CASE-SENSITIVE-P)" t nil)
+
+(autoload 'cider-apropos-documentation-select "cider-apropos" "\
+Shortcut for (cider-apropos-select <query> nil t).
+
+\(fn)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-browse-ns" "cider-browse-ns.el" (22692
+;;;;;; 30287 0 0))
+;;; Generated autoloads from cider-browse-ns.el
+
+(autoload 'cider-browse-ns "cider-browse-ns" "\
+List all NAMESPACE's vars in BUFFER.
+
+\(fn NAMESPACE)" t nil)
+
+(autoload 'cider-browse-ns-all "cider-browse-ns" "\
+List all loaded namespaces in BUFFER.
+
+\(fn)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-classpath" "cider-classpath.el" (22692
+;;;;;; 30287 0 0))
+;;; Generated autoloads from cider-classpath.el
+
+(autoload 'cider-classpath "cider-classpath" "\
+List all classpath entries.
+
+\(fn)" t nil)
+
+(autoload 'cider-open-classpath-entry "cider-classpath" "\
+Open a classpath entry.
+
+\(fn)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-debug" "cider-debug.el" (22692 30287
+;;;;;; 0 0))
+;;; Generated autoloads from cider-debug.el
+
+(autoload 'cider-debug-defun-at-point "cider-debug" "\
+Instrument the \"top-level\" expression at point.
+If it is a defn, dispatch the instrumented definition. Otherwise,
+immediately evaluate the instrumented expression.
+
+While debugged code is being evaluated, the user is taken through the
+source code and displayed the value of various expressions. At each step,
+a number of keys will be prompted to the user.
+
+\(fn)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-grimoire" "cider-grimoire.el" (22692
+;;;;;; 30287 0 0))
+;;; Generated autoloads from cider-grimoire.el
+
+(autoload 'cider-grimoire-web "cider-grimoire" "\
+Open grimoire documentation in the default web browser.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'cider-grimoire "cider-grimoire" "\
+Open grimoire documentation in a popup buffer.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates.
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-inspector" "cider-inspector.el" (22692
+;;;;;; 30287 0 0))
+;;; Generated autoloads from cider-inspector.el
+
+(autoload 'cider-inspect-last-sexp "cider-inspector" "\
+Inspect the result of the the expression preceding point.
+
+\(fn)" t nil)
+
+(autoload 'cider-inspect-defun-at-point "cider-inspector" "\
+Inspect the result of the \"top-level\" expression at point.
+
+\(fn)" t nil)
+
+(autoload 'cider-inspect-last-result "cider-inspector" "\
+Inspect the most recent eval result.
+
+\(fn)" t nil)
+
+(autoload 'cider-inspect "cider-inspector" "\
+Inspect the result of the preceding sexp.
+
+With a prefix argument ARG it inspects the result of the \"top-level\" form.
+With a second prefix argument it prompts for an expression to eval and inspect.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'cider-inspect-expr "cider-inspector" "\
+Evaluate EXPR in NS and inspect its value.
+Interactively, EXPR is read from the minibuffer, and NS the
+current buffer's namespace.
+
+\(fn EXPR NS)" t nil)
+
+(define-obsolete-function-alias 'cider-inspect-read-and-inspect 'cider-inspect-expr "0.13.0")
+
+;;;***
+\f
+;;;### (autoloads nil "cider-macroexpansion" "cider-macroexpansion.el"
+;;;;;; (22692 30287 0 0))
+;;; Generated autoloads from cider-macroexpansion.el
+
+(autoload 'cider-macroexpand-1 "cider-macroexpansion" "\
+Invoke \\=`macroexpand-1\\=` on the expression preceding point.
+If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of
+\\=`macroexpand-1\\=`.
+
+\(fn &optional PREFIX)" t nil)
+
+(autoload 'cider-macroexpand-all "cider-macroexpansion" "\
+Invoke \\=`clojure.walk/macroexpand-all\\=` on the expression preceding point.
+
+\(fn)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-mode" "cider-mode.el" (22692 30287 0
+;;;;;; 0))
+;;; Generated autoloads from cider-mode.el
+
+(defvar cider-mode-line '(:eval (format " cider[%s]" (cider--modeline-info))) "\
+Mode line lighter for `cider-mode'.
+
+The value of this variable is a mode line template as in
+`mode-line-format'. See Info Node `(elisp)Mode Line Format' for
+details about mode line templates.
+
+Customize this variable to change how `cider-mode' displays its
+status in the mode line. The default value displays the current connection.
+Set this variable to nil to disable the mode line
+entirely.")
+
+(custom-autoload 'cider-mode-line "cider-mode" t)
+
+(eval-after-load 'clojure-mode '(easy-menu-define cider-clojure-mode-menu-open clojure-mode-map "Menu for Clojure mode.\n This is displayed in `clojure-mode' buffers, if `cider-mode' is not active." `("CIDER" :visible (not cider-modeanual])))
+
+(autoload 'cider-mode "cider-mode" "\
+Minor mode for REPL interaction from a Clojure buffer.
+
+\\{cider-mode-map}
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-repl-history" "cider-repl-history.el"
+;;;;;; (22692 30287 0 0))
+;;; Generated autoloads from cider-repl-history.el
+
+(autoload 'cider-repl-history "cider-repl-history" "\
+Display items in the CIDER command history in another buffer.
+
+\(fn)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-scratch" "cider-scratch.el" (22692 30287
+;;;;;; 0 0))
+;;; Generated autoloads from cider-scratch.el
+
+(autoload 'cider-scratch "cider-scratch" "\
+Go to the scratch buffer named `cider-scratch-buffer-name'.
+
+\(fn)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-selector" "cider-selector.el" (22692
+;;;;;; 30287 0 0))
+;;; Generated autoloads from cider-selector.el
+
+(autoload 'cider-selector "cider-selector" "\
+Select a new buffer by type, indicated by a single character.
+The user is prompted for a single character indicating the method by
+which to choose a new buffer. The `?' character describes then
+available methods. OTHER-WINDOW provides an optional target.
+
+See `def-cider-selector-method' for defining new methods.
+
+\(fn &optional OTHER-WINDOW)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-test" "cider-test.el" (22692 30287 0
+;;;;;; 0))
+;;; Generated autoloads from cider-test.el
+
+(defvar cider-auto-test-mode nil "\
+Non-nil if Cider-Auto-Test mode is enabled.
+See the `cider-auto-test-mode' command
+for a description of this minor mode.
+Setting this variable directly does not take effect;
+either customize it (see the info node `Easy Customization')
+or call the function `cider-auto-test-mode'.")
+
+(custom-autoload 'cider-auto-test-mode "cider-test" nil)
+
+(autoload 'cider-auto-test-mode "cider-test" "\
+Toggle automatic testing of Clojure files.
+
+When enabled this reruns tests every time a Clojure file is loaded.
+Only runs tests corresponding to the loaded file's namespace and does
+nothing if no tests are defined or if the file failed to load.
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil "cider-util" "cider-util.el" (22692 30287 0
+;;;;;; 0))
+;;; Generated autoloads from cider-util.el
+
+(autoload 'cider-view-manual "cider-util" "\
+View the manual in your default browser.
+
+\(fn)" t nil)
+
+;;;***
+\f
+;;;### (autoloads nil nil ("cider-client.el" "cider-common.el" "cider-compat.el"
+;;;;;; "cider-doc.el" "cider-eldoc.el" "cider-interaction.el" "cider-overlays.el"
+;;;;;; "cider-pkg.el" "cider-popup.el" "cider-repl.el" "cider-resolve.el"
+;;;;;; "cider-stacktrace.el" "nrepl-client.el" "nrepl-dict.el")
+;;;;;; (22692 30287 0 0))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; cider-autoloads.el ends here
--- /dev/null
+;;; cider-browse-ns.el --- CIDER namespace browser
+
+;; Copyright © 2014-2017 John Andrews, Bozhidar Batsov and CIDER contributors
+
+;; Author: John Andrews <john.m.andrewsNOSPAMgmail.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; M-x cider-browse-ns
+;;
+;; Display a list of all vars in a namespace.
+;; Pressing <enter> will take you to the cider-doc buffer for that var.
+;; Pressing ^ will take you to a list of all namespaces (akin to `dired-mode').
+
+;; M-x cider-browse-ns-all
+;;
+;; Explore Clojure namespaces by browsing a list of all namespaces.
+;; Pressing <enter> expands into a list of that namespace's vars as if by
+;; executing the command (cider-browse-ns "my.ns").
+
+;;; Code:
+
+(require 'cider-interaction)
+(require 'cider-client)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-util)
+(require 'nrepl-dict)
+
+(defconst cider-browse-ns-buffer "*cider-ns-browser*")
+
+(push cider-browse-ns-buffer cider-ancillary-buffers)
+
+(defvar-local cider-browse-ns-current-ns nil)
+
+;; Mode Definition
+
+(defvar cider-browse-ns-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map cider-popup-buffer-mode-map)
+ (define-key map "d" #'cider-browse-ns-doc-at-point)
+ (define-key map "s" #'cider-browse-ns-find-at-point)
+ (define-key map (kbd "RET") #'cider-browse-ns-operate-at-point)
+ (define-key map "^" #'cider-browse-ns-all)
+ (define-key map "n" #'next-line)
+ (define-key map "p" #'previous-line)
+ map))
+
+(defvar cider-browse-ns-mouse-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] #'cider-browse-ns-handle-mouse)
+ map))
+
+(define-derived-mode cider-browse-ns-mode special-mode "browse-ns"
+ "Major mode for browsing Clojure namespaces.
+
+\\{cider-browse-ns-mode-map}"
+ (setq buffer-read-only t)
+ (setq-local electric-indent-chars nil)
+ (when cider-special-mode-truncate-lines
+ (setq-local truncate-lines t))
+ (setq-local cider-browse-ns-current-ns nil))
+
+(defun cider-browse-ns--text-face (var-meta)
+ "Return font-lock-face for a var.
+VAR-META contains the metadata information used to decide a face.
+Presence of \"arglists-str\" and \"macro\" indicates a macro form.
+Only \"arglists-str\" indicates a function. Otherwise, its a variable.
+If the NAMESPACE is not loaded in the REPL, assume TEXT is a fn."
+ (cond
+ ((not var-meta) 'font-lock-function-name-face)
+ ((and (nrepl-dict-contains var-meta "arglists")
+ (string= (nrepl-dict-get var-meta "macro") "true"))
+ 'font-lock-keyword-face)
+ ((nrepl-dict-contains var-meta "arglists") 'font-lock-function-name-face)
+ (t 'font-lock-variable-name-face)))
+
+(defun cider-browse-ns--properties (var var-meta)
+ "Decorate VAR with a clickable keymap and a face.
+VAR-META is used to decide a font-lock face."
+ (let ((face (cider-browse-ns--text-face var-meta)))
+ (propertize var
+ 'font-lock-face face
+ 'mouse-face 'highlight
+ 'keymap cider-browse-ns-mouse-map)))
+
+(defun cider-browse-ns--list (buffer title items &optional ns noerase)
+ "Reset contents of BUFFER.
+Display TITLE at the top and ITEMS are indented underneath.
+If NS is non-nil, it is added to each item as the
+`cider-browse-ns-current-ns' text property. If NOERASE is non-nil, the
+contents of the buffer are not reset before inserting TITLE and ITEMS."
+ (with-current-buffer buffer
+ (cider-browse-ns-mode)
+ (let ((inhibit-read-only t))
+ (unless noerase (erase-buffer))
+ (goto-char (point-max))
+ (insert (cider-propertize title 'ns) "\n")
+ (dolist (item items)
+ (insert (propertize (concat " " item "\n")
+ 'cider-browse-ns-current-ns ns)))
+ (goto-char (point-min)))))
+
+(defun cider-browse-ns--first-doc-line (doc)
+ "Return the first line of the given DOC string.
+If the first line of the DOC string contains multiple sentences, only
+the first sentence is returned. If the DOC string is nil, a Not documented
+string is returned."
+ (if doc
+ (let* ((split-newline (split-string doc "\n"))
+ (first-line (car split-newline)))
+ (cond
+ ((string-match "\\. " first-line) (substring first-line 0 (match-end 0)))
+ ((= 1 (length split-newline)) first-line)
+ (t (concat first-line "..."))))
+ "Not documented."))
+
+(defun cider-browse-ns--items (namespace)
+ "Return the items to show in the namespace browser of the given NAMESPACE.
+Each item consists of a ns-var and the first line of its docstring."
+ (let* ((ns-vars-with-meta (cider-sync-request:ns-vars-with-meta namespace))
+ (propertized-ns-vars (nrepl-dict-map #'cider-browse-ns--properties ns-vars-with-meta)))
+ (mapcar (lambda (ns-var)
+ (let* ((doc (nrepl-dict-get-in ns-vars-with-meta (list ns-var "doc")))
+ ;; to avoid (read nil)
+ ;; it prompts the user for a Lisp expression
+ (doc (when doc (read doc)))
+ (first-doc-line (cider-browse-ns--first-doc-line doc)))
+ (concat ns-var " " (propertize first-doc-line 'font-lock-face 'font-lock-doc-face))))
+ propertized-ns-vars)))
+
+;; Interactive Functions
+
+;;;###autoload
+(defun cider-browse-ns (namespace)
+ "List all NAMESPACE's vars in BUFFER."
+ (interactive (list (completing-read "Browse namespace: " (cider-sync-request:ns-list))))
+ (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t)
+ (cider-browse-ns--list (current-buffer)
+ namespace
+ (cider-browse-ns--items namespace))
+ (setq-local cider-browse-ns-current-ns namespace)))
+
+;;;###autoload
+(defun cider-browse-ns-all ()
+ "List all loaded namespaces in BUFFER."
+ (interactive)
+ (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t)
+ (let ((names (cider-sync-request:ns-list)))
+ (cider-browse-ns--list (current-buffer)
+ "All loaded namespaces"
+ (mapcar (lambda (name)
+ (cider-browse-ns--properties name nil))
+ names))
+ (setq-local cider-browse-ns-current-ns nil))))
+
+(defun cider-browse-ns--thing-at-point ()
+ "Get the thing at point.
+Return a list of the type ('ns or 'var) and the value."
+ (let ((line (car (split-string (string-trim (thing-at-point 'line)) " "))))
+ (if (string-match "\\." line)
+ (list 'ns line)
+ (list 'var (format "%s/%s"
+ (or (get-text-property (point) 'cider-browse-ns-current-ns)
+ cider-browse-ns-current-ns)
+ line)))))
+
+(defun cider-browse-ns-doc-at-point ()
+ "Show the documentation for the thing at current point."
+ (interactive)
+ (let* ((thing (cider-browse-ns--thing-at-point))
+ (value (cadr thing)))
+ ;; value is either some ns or a var
+ (cider-doc-lookup value)))
+
+(defun cider-browse-ns-operate-at-point ()
+ "Expand browser according to thing at current point.
+If the thing at point is a ns it will be browsed,
+and if the thing at point is some var - its documentation will
+be displayed."
+ (interactive)
+ (let* ((thing (cider-browse-ns--thing-at-point))
+ (type (car thing))
+ (value (cadr thing)))
+ (if (eq type 'ns)
+ (cider-browse-ns value)
+ (cider-doc-lookup value))))
+
+(defun cider-browse-ns-find-at-point ()
+ "Find the definition of the thing at point."
+ (interactive)
+ (let* ((thing (cider-browse-ns--thing-at-point))
+ (type (car thing))
+ (value (cadr thing)))
+ (if (eq type 'ns)
+ (cider-find-ns nil value)
+ (cider-find-var current-prefix-arg value))))
+
+(defun cider-browse-ns-handle-mouse (event)
+ "Handle mouse click EVENT."
+ (interactive "e")
+ (cider-browse-ns-operate-at-point))
+
+(provide 'cider-browse-ns)
+
+;;; cider-browse-ns.el ends here
--- /dev/null
+;;; cider-classpath.el --- Basic Java classpath browser
+
+;; Copyright © 2014-2017 Bozhidar Batsov and CIDER contributors
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Basic Java classpath browser for CIDER.
+
+;;; Code:
+
+(require 'cider-client)
+(require 'cider-popup)
+(require 'subr-x)
+(require 'cider-compat)
+
+(defvar cider-classpath-buffer "*cider-classpath*")
+
+(push cider-classpath-buffer cider-ancillary-buffers)
+
+(defvar cider-classpath-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map cider-popup-buffer-mode-map)
+ (define-key map (kbd "RET") #'cider-classpath-operate-on-point)
+ (define-key map "n" #'next-line)
+ (define-key map "p" #'previous-line)
+ map))
+
+(defvar cider-classpath-mouse-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] #'cider-classpath-handle-mouse)
+ map))
+
+(define-derived-mode cider-classpath-mode special-mode "classpath"
+ "Major mode for browsing the entries in Java's classpath.
+
+\\{cider-classpath-mode-map}"
+ (setq buffer-read-only t)
+ (setq-local electric-indent-chars nil)
+ (when cider-special-mode-truncate-lines
+ (setq-local truncate-lines t)))
+
+(defun cider-classpath-list (buffer items)
+ "Populate BUFFER with ITEMS."
+ (with-current-buffer buffer
+ (cider-classpath-mode)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (dolist (item items)
+ (insert item "\n"))
+ (goto-char (point-min)))))
+
+(defun cider-classpath-properties (text)
+ "Decorate TEXT with a clickable keymap and function face."
+ (let ((face (cond
+ ((not (file-exists-p text)) 'font-lock-warning-face)
+ ((file-directory-p text) 'dired-directory)
+ (t 'default))))
+ (propertize text
+ 'font-lock-face face
+ 'mouse-face 'highlight
+ 'keymap cider-classpath-mouse-map)))
+
+(defun cider-classpath-operate-on-point ()
+ "Expand browser according to thing at current point."
+ (interactive)
+ (let* ((bol (line-beginning-position))
+ (eol (line-end-position))
+ (line (buffer-substring-no-properties bol eol)))
+ (find-file-other-window line)))
+
+(defun cider-classpath-handle-mouse (event)
+ "Handle mouse click EVENT."
+ (interactive "e")
+ (cider-classpath-operate-on-point))
+
+;;;###autoload
+(defun cider-classpath ()
+ "List all classpath entries."
+ (interactive)
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "classpath")
+ (with-current-buffer (cider-popup-buffer cider-classpath-buffer t)
+ (cider-classpath-list (current-buffer)
+ (mapcar (lambda (name)
+ (cider-classpath-properties name))
+ (cider-sync-request:classpath)))))
+
+;;;###autoload
+(defun cider-open-classpath-entry ()
+ "Open a classpath entry."
+ (interactive)
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "classpath")
+ (when-let ((entry (completing-read "Classpath entries: " (cider-sync-request:classpath))))
+ (find-file-other-window entry)))
+
+(provide 'cider-classpath)
+
+;;; cider-classpath.el ends here
--- /dev/null
+;;; cider-client.el --- A layer of abstraction above the actual client code. -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2017 Bozhidar Batsov
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; A layer of abstraction above the actual client code.
+
+;;; Code:
+
+(require 'spinner)
+(require 'ewoc)
+(require 'nrepl-client)
+(require 'cider-common)
+(require 'cider-util)
+(require 'clojure-mode)
+
+(require 'subr-x)
+(require 'cider-compat)
+(require 'seq)
+
+;;; Connection Buffer Management
+
+(defcustom cider-request-dispatch 'dynamic
+ "Controls the request dispatch mechanism when several connections are present.
+Dynamic dispatch tries to infer the connection based on the current project
+& currently visited file, while static dispatch simply uses the default
+connection.
+
+Project metadata is attached to connections when they are created with commands
+like `cider-jack-in' and `cider-connect'."
+ :type '(choice (const :tag "dynamic" dynamic)
+ (const :tag "static" static))
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-connection-message-fn #'cider-random-words-of-inspiration
+ "The function to use to generate the message displayed on connect.
+When set to nil no additional message will be displayed.
+
+A good alternative to the default is `cider-random-tip'."
+ :type 'function
+ :group 'cider
+ :package-version '(cider . "0.11.0"))
+
+(defvar cider-connections nil
+ "A list of connections.")
+
+(defun cider-connected-p ()
+ "Return t if CIDER is currently connected, nil otherwise."
+ (not (null (cider-connections))))
+
+(defun cider-ensure-connected ()
+ "Ensure there is a cider connection present.
+An error is signaled in the absence of a connection."
+ (unless (cider-connected-p)
+ (user-error "`%s' needs an active nREPL connection" this-command)))
+
+(defsubst cider--in-connection-buffer-p ()
+ "Return non-nil if current buffer is connected to a server."
+ (and (derived-mode-p 'cider-repl-mode)
+ (process-live-p
+ (get-buffer-process (current-buffer)))))
+
+(defun cider-default-connection (&optional no-error)
+ "The default (fallback) connection to use for nREPL interaction.
+When NO-ERROR is non-nil, don't throw an error when no connection has been
+found."
+ (or (car (cider-connections))
+ (unless no-error
+ (error "No nREPL connection buffer"))))
+
+(defun cider-connections ()
+ "Return the list of connection buffers.
+If the list is empty and buffer-local, return the global value."
+ (or (setq cider-connections
+ (seq-filter #'buffer-live-p cider-connections))
+ (when (local-variable-p 'cider-connect)
+ (kill-local-variable 'cider-connections)
+ (seq-filter #'buffer-live-p cider-connections))))
+
+(defun cider-repl-buffers ()
+ "Return the list of REPL buffers."
+ (seq-filter
+ (lambda (buffer)
+ (with-current-buffer buffer (derived-mode-p 'cider-repl-mode)))
+ (buffer-list)))
+
+(defun cider-make-connection-default (connection-buffer)
+ "Make the nREPL CONNECTION-BUFFER the default connection.
+Moves CONNECTION-BUFFER to the front of variable `cider-connections'."
+ (interactive (list (if (cider--in-connection-buffer-p)
+ (current-buffer)
+ (user-error "Not in a REPL buffer"))))
+ ;; maintain the connection list in most recently used order
+ (let ((buf (get-buffer connection-buffer)))
+ (setq cider-connections
+ (cons buf (delq buf cider-connections))))
+ (cider--connections-refresh))
+
+(declare-function cider--close-buffer "cider-interaction")
+(defun cider--close-connection-buffer (conn-buffer)
+ "Close CONN-BUFFER, removing it from variable `cider-connections'.
+Also close associated REPL and server buffers."
+ (let ((buffer (get-buffer conn-buffer))
+ (nrepl-messages-buffer (and nrepl-log-messages
+ (nrepl-messages-buffer conn-buffer))))
+ (setq cider-connections
+ (delq buffer cider-connections))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (when spinner-current (spinner-stop))
+ (when nrepl-tunnel-buffer
+ (cider--close-buffer nrepl-tunnel-buffer)))
+ ;; If this is the only (or last) REPL connected to its server, the
+ ;; kill-process hook will kill the server.
+ (cider--close-buffer buffer)
+ (when nrepl-messages-buffer
+ (kill-buffer nrepl-messages-buffer)))))
+
+\f
+;;; Current connection logic
+(defvar-local cider-repl-type "clj"
+ "The type of this REPL buffer, usually either \"clj\" or \"cljs\".")
+
+(defun cider-find-connection-buffer-for-project-directory (&optional project-directory all-connections)
+ "Return the most appropriate connection-buffer for the current project.
+
+By order of preference, this is any connection whose directory matches
+`clojure-project-dir', followed by any connection whose directory is nil,
+followed by any connection at all.
+
+If PROJECT-DIRECTORY is provided act on that project instead.
+
+Only return nil if variable `cider-connections' is empty,
+i.e there are no connections.
+
+If more than one connection satisfy a given level of preference, return the
+connection buffer closer to the start of variable `cider-connections'. This is
+usally the connection that was more recently created, but the order can be
+changed. For instance, the function `cider-make-connection-default' can be
+used to move a connection to the head of the list, so that it will take
+precedence over other connections associated with the same project.
+
+If ALL-CONNECTIONS is non-nil, the return value is a list and all matching
+connections are returned, instead of just the most recent."
+ (when-let ((project-directory (or project-directory
+ (clojure-project-dir (cider-current-dir))))
+ (fn (if all-connections #'seq-filter #'seq-find)))
+ (or (funcall fn (lambda (conn)
+ (when-let ((conn-proj-dir (with-current-buffer conn
+ nrepl-project-dir)))
+ (equal (file-truename project-directory)
+ (file-truename conn-proj-dir))))
+ cider-connections)
+ (funcall fn (lambda (conn)
+ (with-current-buffer conn
+ (not nrepl-project-dir)))
+ cider-connections)
+ (if all-connections
+ cider-connections
+ (car cider-connections)))))
+
+(defun cider-read-connection (prompt)
+ "Completing read for connections using PROMPT."
+ (get-buffer (completing-read prompt (mapcar #'buffer-name (cider-connections)))))
+
+(defun cider-assoc-project-with-connection (&optional project connection)
+ "Associate a Clojure PROJECT with an nREPL CONNECTION.
+
+Useful for connections created using `cider-connect', as for them
+such a link cannot be established automatically."
+ (interactive)
+ (cider-ensure-connected)
+ (let ((conn-buf (or connection (cider-read-connection "Connection: ")))
+ (project-dir (or project (read-directory-name "Project directory: " (clojure-project-dir)))))
+ (when conn-buf
+ (with-current-buffer conn-buf
+ (setq nrepl-project-dir project-dir)))))
+
+(defun cider-assoc-buffer-with-connection ()
+ "Associate the current buffer with a connection.
+
+Useful for connections created using `cider-connect', as for them
+such a link cannot be established automatically."
+ (interactive)
+ (cider-ensure-connected)
+ (let ((conn (cider-read-connection "Connection: ")))
+ (when conn
+ (setq-local cider-connections (list conn)))))
+
+(defun cider-toggle-buffer-connection ()
+ "Toggles the current buffer's connection between Clojure and ClojureScript."
+ (interactive)
+ (cider-ensure-connected)
+ (let ((other-conn (cider-other-connection)))
+ (if other-conn
+ (setq-local cider-connections (list other-conn))
+ (user-error "No other connection available"))))
+
+(defun cider-clear-buffer-local-connection ()
+ "Remove association between the current buffer and a connection."
+ (interactive)
+ (cider-ensure-connected)
+ (kill-local-variable 'cider-connections))
+
+(defun cider-connection-type-for-buffer ()
+ "Return the matching connection type (clj or cljs) for the current buffer."
+ (cond
+ ((derived-mode-p 'clojurescript-mode) "cljs")
+ ((derived-mode-p 'clojure-mode) "clj")
+ (cider-repl-type)
+ (t "clj")))
+
+(defun cider-toggle-request-dispatch ()
+ "Toggles the value of `cider-request-dispatch' between static and dynamic.
+
+Handy when you're using dynamic dispatch, but you want to quickly force all
+evaluation commands to use a particular connection."
+ (interactive)
+ (let ((new-value (if (eq cider-request-dispatch 'static) 'dynamic 'static)))
+ (setq cider-request-dispatch new-value)
+ (message "Toggled CIDER request dispatch to %s." new-value)))
+
+(defun cider-current-connection (&optional type)
+ "Return the REPL buffer relevant for the current Clojure source buffer.
+A REPL is relevant if its `nrepl-project-dir' is compatible with the
+current directory (see `cider-find-connection-buffer-for-project-directory').
+
+If TYPE is provided, it is either \"clj\" or \"cljs\", and only a
+connection of that type is returned. If no connections of that TYPE exist,
+return nil.
+
+If TYPE is nil, then connections whose type matches the current file
+extension are given preference, but if none exist, any connection is
+returned. In this case, only return nil if there are no active connections
+at all."
+ ;; If TYPE was specified, we only return that type (or nil). OW, we prefer
+ ;; that TYPE, but ultimately allow any type.
+ (cl-labels ((right-type-p
+ (c)
+ (when (or (not type)
+ (and (buffer-live-p c)
+ (with-current-buffer c (equal cider-repl-type type))))
+ c)))
+ (let ((connections (cider-connections)))
+ (cond
+ ((not connections) nil)
+ ;; if you're in a REPL buffer, it's the connection buffer
+ ((and (derived-mode-p 'cider-repl-mode) (right-type-p (current-buffer))))
+ ((eq cider-request-dispatch 'static) (car connections))
+ ((= 1 (length connections)) (right-type-p (car connections)))
+ (t (let ((project-connections (cider-find-connection-buffer-for-project-directory
+ nil :all-connections))
+ (guessed-type (or type (cider-connection-type-for-buffer))))
+ ;; So we have multiple connections. Look for the connection type we
+ ;; want, prioritizing the current project.
+ (or (seq-find (lambda (conn)
+ (equal (cider--connection-type conn) guessed-type))
+ project-connections)
+ (seq-find (lambda (conn)
+ (equal (cider--connection-type conn) guessed-type))
+ connections)
+ (right-type-p (car project-connections))
+ (right-type-p (car connections)))))))))
+
+(defun cider-other-connection (&optional connection)
+ "Return the first connection of another type than CONNECTION.
+Only return connections in the same project or nil.
+CONNECTION defaults to `cider-current-connection'."
+ (when-let ((connection (or connection (cider-current-connection)))
+ (connection-type (cider--connection-type connection)))
+ (cider-current-connection (pcase connection-type
+ (`"clj" "cljs")
+ (_ "clj")))))
+
+(defvar cider--has-warned-about-bad-repl-type nil)
+
+(defun cider--guess-cljs-connection ()
+ "Hacky way to find a ClojureScript REPL.
+DO NOT USE THIS FUNCTION.
+It was written only to be used in `cider-map-connections', as a workaround
+to a still-undetermined bug in the state-stracker backend."
+ (when-let ((project-connections (cider-find-connection-buffer-for-project-directory
+ nil :all-connections))
+ (cljs-conn
+ ;; So we have multiple connections. Look for the connection type we
+ ;; want, prioritizing the current project.
+ (or (seq-find (lambda (c) (string-match "\\bCLJS\\b" (buffer-name c)))
+ project-connections)
+ (seq-find (lambda (c) (string-match "\\bCLJS\\b" (buffer-name c)))
+ (cider-connections)))))
+ (unless cider--has-warned-about-bad-repl-type
+ (setq cider--has-warned-about-bad-repl-type t)
+ (read-key
+ (concat "The ClojureScript REPL seems to be is misbehaving."
+ (substitute-command-keys
+ "\nWe have applied a workaround, but please also file a bug report with `\\[cider-report-bug]'.")
+ "\nPress any key to continue.")))
+ cljs-conn))
+
+(defun cider-map-connections (function which &optional any-mode)
+ "Call FUNCTION once for each appropriate connection.
+The function is called with one argument, the connection buffer.
+The appropriate connections are found by inspecting the current buffer. If
+the buffer is associated with a .cljc or .cljx file, BODY will be executed
+multiple times.
+
+WHICH is one of the following keywords identifying which connections to map
+over.
+ :any - Act the connection whose type matches the current buffer.
+ :clj - Like :any, but signal a `user-error' in `clojurescript-mode' or if
+ there is no Clojure connection (use this for commands only
+ supported in Clojure).
+ :cljs - Like :clj, but demands a ClojureScript connection instead.
+ :both - In `clojurec-mode' or `clojurex-mode' act on both connections,
+ otherwise function like :any. Obviously, this option might run
+ FUNCTION twice.
+
+If ANY-MODE is non-nil, :clj and :cljs don't signal errors due to being in
+the wrong major mode (they still signal if the desired connection type
+doesn't exist). Use this for commands that only apply to a specific
+connection but can be invoked from any buffer (like `cider-refresh')."
+ (cl-labels ((err (msg) (user-error (concat "`%s' " msg) this-command)))
+ ;; :both in a clj or cljs buffer just means :any.
+ (let* ((which (if (and (eq which :both)
+ (not (cider--cljc-or-cljx-buffer-p)))
+ :any
+ which))
+ (curr
+ (pcase which
+ (`:any (let ((type (cider-connection-type-for-buffer)))
+ (or (cider-current-connection type)
+ (when (equal type "cljs")
+ (cider--guess-cljs-connection))
+ (err (substitute-command-keys
+ (format "needs a Clojure%s REPL.\nIf you don't know what that means, you probably need to jack-in (%s)."
+ (if (equal type "cljs") "Script" "")
+ (if (equal type "cljs") "`\\[cider-jack-in-clojurescript]'" "`\\[cider-jack-in]'")))))))
+ (`:both (or (cider-current-connection)
+ (err "needs an active REPL connection")))
+ (`:clj (cond ((and (not any-mode)
+ (derived-mode-p 'clojurescript-mode))
+ (err "doesn't support ClojureScript"))
+ ((cider-current-connection "clj"))
+ ((err "needs a Clojure REPL"))))
+ (`:cljs (cond ((and (not any-mode)
+ (eq major-mode 'clojure-mode))
+ (err "doesn't support Clojure"))
+ ((cider-current-connection "cljs"))
+ ((err "needs a ClojureScript REPL")))))))
+ (funcall function curr)
+ (when (eq which :both)
+ (when-let ((other-connection (cider-other-connection curr)))
+ (funcall function other-connection))))))
+
+\f
+;;; Connection Browser
+(defvar cider-connections-buffer-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "d" #'cider-connections-make-default)
+ (define-key map "g" #'cider-connection-browser)
+ (define-key map "k" #'cider-connections-close-connection)
+ (define-key map (kbd "RET") #'cider-connections-goto-connection)
+ (define-key map "?" #'describe-mode)
+ (define-key map "h" #'describe-mode)
+ map))
+
+(declare-function cider-popup-buffer-mode "cider-popup")
+(define-derived-mode cider-connections-buffer-mode cider-popup-buffer-mode
+ "CIDER Connections"
+ "CIDER Connections Buffer Mode.
+\\{cider-connections-buffer-mode-map}
+\\{cider-popup-buffer-mode-map}"
+ (when cider-special-mode-truncate-lines
+ (setq-local truncate-lines t)))
+
+(defvar cider--connection-ewoc)
+(defconst cider--connection-browser-buffer-name "*cider-connections*")
+
+(defun cider-connection-browser ()
+ "Open a browser buffer for nREPL connections."
+ (interactive)
+ (if-let ((buffer (get-buffer cider--connection-browser-buffer-name)))
+ (progn
+ (cider--connections-refresh-buffer buffer)
+ (unless (get-buffer-window buffer)
+ (select-window (display-buffer buffer))))
+ (cider--setup-connection-browser)))
+
+(defun cider--connections-refresh ()
+ "Refresh the connections buffer, if the buffer exists.
+The connections buffer is determined by
+`cider--connection-browser-buffer-name'"
+ (when-let ((buffer (get-buffer cider--connection-browser-buffer-name)))
+ (cider--connections-refresh-buffer buffer)))
+
+(add-hook 'nrepl-disconnected-hook #'cider--connections-refresh)
+
+(defun cider--connections-refresh-buffer (buffer)
+ "Refresh the connections BUFFER."
+ (cider--update-connections-display
+ (buffer-local-value 'cider--connection-ewoc buffer)
+ cider-connections))
+
+(defun cider--setup-connection-browser ()
+ "Create a browser buffer for nREPL connections."
+ (with-current-buffer (get-buffer-create cider--connection-browser-buffer-name)
+ (let ((ewoc (ewoc-create
+ 'cider--connection-pp
+ " REPL Host Port Project Type\n")))
+ (setq-local cider--connection-ewoc ewoc)
+ (cider--update-connections-display ewoc cider-connections)
+ (setq buffer-read-only t)
+ (cider-connections-buffer-mode)
+ (display-buffer (current-buffer)))))
+
+(defun cider-client-name-repl-type (type)
+ "Return a human-readable name for a connection TYPE.
+TYPE can be any of the possible values of `cider-repl-type'."
+ (pcase type
+ ("clj" "Clojure")
+ ("cljs" "ClojureScript")
+ (_ "Unknown")))
+
+(defun cider-project-name (project-dir)
+ "Extract the project name from PROJECT-DIR."
+ (if (and project-dir (not (equal project-dir "")))
+ (file-name-nondirectory (directory-file-name project-dir))
+ "-"))
+
+(defun cider--connection-pp (connection)
+ "Print an nREPL CONNECTION to the current buffer."
+ (let* ((buffer-read-only nil)
+ (buffer (get-buffer connection))
+ (project-name (cider-project-name (buffer-local-value 'nrepl-project-dir buffer)))
+ (repl-type (cider-client-name-repl-type (buffer-local-value 'cider-repl-type buffer)))
+ (endpoint (buffer-local-value 'nrepl-endpoint buffer)))
+ (insert
+ (format "%s %-30s %-16s %5s %-16s %s"
+ (if (equal connection (car cider-connections)) "*" " ")
+ (buffer-name connection)
+ (car endpoint)
+ (prin1-to-string (cadr endpoint))
+ project-name
+ repl-type))))
+
+(defun cider--update-connections-display (ewoc connections)
+ "Update the connections EWOC to show CONNECTIONS."
+ (ewoc-filter ewoc (lambda (n) (member n connections)))
+ (let ((existing))
+ (ewoc-map (lambda (n) (setq existing (cons n existing))) ewoc)
+ (let ((added (seq-difference connections existing)))
+ (mapc (apply-partially 'ewoc-enter-last ewoc) added)
+ (save-excursion (ewoc-refresh ewoc)))))
+
+(defun cider--ewoc-apply-at-point (f)
+ "Apply function F to the ewoc node at point.
+F is a function of two arguments, the ewoc and the data at point."
+ (let* ((ewoc cider--connection-ewoc)
+ (node (and ewoc (ewoc-locate ewoc))))
+ (when node
+ (funcall f ewoc (ewoc-data node)))))
+
+(defun cider-connections-make-default ()
+ "Make default the connection at point in the connection browser."
+ (interactive)
+ (save-excursion
+ (cider--ewoc-apply-at-point #'cider--connections-make-default)))
+
+(defun cider--connections-make-default (ewoc data)
+ "Make the connection in EWOC specified by DATA default.
+Refreshes EWOC."
+ (interactive)
+ (cider-make-connection-default data)
+ (ewoc-refresh ewoc))
+
+(defun cider-connections-close-connection ()
+ "Close connection at point in the connection browser."
+ (interactive)
+ (cider--ewoc-apply-at-point #'cider--connections-close-connection))
+
+(defun cider--connections-close-connection (ewoc data)
+ "Close the connection in EWOC specified by DATA."
+ (cider--close-connection-buffer (get-buffer data))
+ (cider--update-connections-display ewoc cider-connections))
+
+(defun cider-connections-goto-connection ()
+ "Goto connection at point in the connection browser."
+ (interactive)
+ (cider--ewoc-apply-at-point #'cider--connections-goto-connection))
+
+(defun cider--connections-goto-connection (_ewoc data)
+ "Goto the REPL for the connection in _EWOC specified by DATA."
+ (when (buffer-live-p data)
+ (select-window (display-buffer data))))
+
+
+(defun cider-display-connected-message ()
+ "Message displayed on successful connection."
+ (message
+ (concat "Connected."
+ (if cider-connection-message-fn
+ (format " %s" (funcall cider-connection-message-fn))
+ ""))))
+
+;; TODO: Replace direct usage of such hooks with CIDER hooks,
+;; that are connection type independent
+(add-hook 'nrepl-connected-hook 'cider-display-connected-message)
+
+\f
+;;; Eval spinner
+(defcustom cider-eval-spinner-type 'progress-bar
+ "Appearance of the evaluation spinner.
+
+Value is a symbol. The possible values are the symbols in the
+`spinner-types' variable."
+ :type 'symbol
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-show-eval-spinner t
+ "When true, show the evaluation spinner in the mode line."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-eval-spinner-delay 1
+ "Amount of time, in seconds, after which the evaluation spinner will be shown."
+ :type 'integer
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defun cider-spinner-start (buffer)
+ "Start the evaluation spinner in BUFFER.
+Do nothing if `cider-show-eval-spinner' is nil."
+ (when cider-show-eval-spinner
+ (with-current-buffer buffer
+ (spinner-start cider-eval-spinner-type nil
+ cider-eval-spinner-delay))))
+
+(defun cider-eval-spinner-handler (eval-buffer original-callback)
+ "Return a response handler to stop the spinner and call ORIGINAL-CALLBACK.
+EVAL-BUFFER is the buffer where the spinner was started."
+ (lambda (response)
+ ;; buffer still exists and
+ ;; we've got status "done" from nrepl
+ ;; stop the spinner
+ (when (and (buffer-live-p eval-buffer)
+ (let ((status (nrepl-dict-get response "status")))
+ (or (member "done" status)
+ (member "eval-error" status)
+ (member "error" status))))
+ (with-current-buffer eval-buffer
+ (when spinner-current (spinner-stop))))
+ (funcall original-callback response)))
+
+\f
+;;; Evaluation helpers
+(defun cider-ns-form-p (form)
+ "Check if FORM is an ns form."
+ (string-match-p "^[[:space:]]*\(ns\\([[:space:]]*$\\|[[:space:]]+\\)" form))
+
+(defvar-local cider-buffer-ns nil
+ "Current Clojure namespace of some buffer.
+
+Useful for special buffers (e.g. REPL, doc buffers) that have to
+keep track of a namespace.
+
+This should never be set in Clojure buffers, as there the namespace
+should be extracted from the buffer's ns form.")
+
+(defun cider-current-ns (&optional no-default)
+ "Return the current ns.
+The ns is extracted from the ns form for Clojure buffers and from
+`cider-buffer-ns' for all other buffers. If it's missing, use the current
+REPL's ns, otherwise fall back to \"user\".
+
+When NO-DEFAULT is non-nil, it will return nil instead of \"user\"."
+ (or cider-buffer-ns
+ (clojure-find-ns)
+ (when-let ((repl-buf (cider-current-connection)))
+ (buffer-local-value 'cider-buffer-ns repl-buf))
+ (if no-default nil "user")))
+
+(defun cider-expected-ns (&optional path)
+ "Return the namespace string matching PATH, or nil if not found.
+
+PATH is expected to be an absolute file path.
+If PATH is nil, use the path to the file backing the current buffer.
+
+The command falls back to `clojure-expected-ns' in the absence of an
+active nREPL connection."
+ (if (cider-connected-p)
+ (let* ((path (or path (file-truename (buffer-file-name))))
+ (relpath (thread-last (cider-sync-request:classpath)
+ (seq-map
+ (lambda (cp)
+ (when (string-prefix-p cp path)
+ (substring path (length cp)))))
+ (seq-filter #'identity)
+ (seq-sort (lambda (a b)
+ (< (length a) (length b))))
+ (car))))
+ (if relpath
+ (thread-last (substring relpath 1) ; remove leading /
+ (file-name-sans-extension)
+ (replace-regexp-in-string "/" ".")
+ (replace-regexp-in-string "_" "-"))
+ (clojure-expected-ns path)))
+ (clojure-expected-ns path)))
+
+(defun cider-nrepl-op-supported-p (op)
+ "Check whether the current connection supports the nREPL middleware OP."
+ (nrepl-op-supported-p op (cider-current-connection)))
+
+(defvar cider-version)
+(defun cider-ensure-op-supported (op)
+ "Check for support of middleware op OP.
+Signal an error if it is not supported."
+ (unless (cider-nrepl-op-supported-p op)
+ (user-error "`%s' requires the nREPL op \"%s\". Please, install (or update) cider-nrepl %s and restart CIDER" this-command op (upcase cider-version))))
+
+(defun cider-nrepl-send-request (request callback &optional connection)
+ "Send REQUEST and register response handler CALLBACK.
+REQUEST is a pair list of the form (\"op\" \"operation\" \"par1-name\"
+\"par1\" ... ).
+If CONNECTION is provided dispatch to that connection instead of
+the current connection.
+
+Return the id of the sent message."
+ (nrepl-send-request request callback (or connection (cider-current-connection))))
+
+(defun cider-nrepl-send-sync-request (request &optional connection abort-on-input)
+ "Send REQUEST to the nREPL server synchronously using CONNECTION.
+Hold till final \"done\" message has arrived and join all response messages
+of the same \"op\" that came along and return the accumulated response.
+If ABORT-ON-INPUT is non-nil, the function will return nil
+at the first sign of user input, so as not to hang the
+interface."
+ (nrepl-send-sync-request request
+ (or connection (cider-current-connection))
+ abort-on-input))
+
+(defun cider-nrepl-send-unhandled-request (request)
+ "Send REQUEST to the nREPL server and ignore any responses.
+Immediately mark the REQUEST as done.
+Return the id of the sent message."
+ (let* ((conn (cider-current-connection))
+ (id (nrepl-send-request request #'ignore conn)))
+ (with-current-buffer conn
+ (nrepl--mark-id-completed id))
+ id))
+
+(defun cider-nrepl-request:eval (input callback &optional ns line column additional-params)
+ "Send the request INPUT and register the CALLBACK as the response handler.
+If NS is non-nil, include it in the request. LINE and COLUMN, if non-nil,
+define the position of INPUT in its buffer. ADDITIONAL-PARAMS is a plist
+to be appended to the request message."
+ (let ((connection (cider-current-connection)))
+ (nrepl-request:eval input
+ (if cider-show-eval-spinner
+ (cider-eval-spinner-handler connection callback)
+ callback)
+ connection
+ ns line column additional-params)
+ (cider-spinner-start connection)))
+
+(defun cider-nrepl-sync-request:eval (input &optional ns)
+ "Send the INPUT to the nREPL server synchronously.
+If NS is non-nil, include it in the request."
+ (nrepl-sync-request:eval
+ input
+ (cider-current-connection)
+ ns))
+
+(defcustom cider-pprint-fn 'pprint
+ "Sets the function to use when pretty-printing evaluation results.
+
+The value must be one of the following symbols:
+
+ `pprint' - to use \\=`clojure.pprint/pprint\\=`
+
+ `fipp' - to use the Fast Idiomatic Pretty Printer, approximately 5-10x
+ faster than \\=`clojure.core/pprint\\=` (this is the default)
+
+ `puget' - to use Puget, which provides canonical serialization of data on
+ top of fipp, but at a slight performance cost
+
+Alternatively, can be the namespace-qualified name of a Clojure function of
+one argument. If the function cannot be resolved, an exception will be
+thrown.
+
+The function is assumed to respect the contract of \\=`clojure.pprint/pprint\\=`
+with respect to the bound values of \\=`*print-length*\\=`, \\=`*print-level*\\=`,
+\\=`*print-meta*\\=`, and \\=`clojure.pprint/*print-right-margin*\\=`."
+ :type '(choice (const pprint)
+ (const fipp)
+ (const puget)
+ string)
+ :group 'cider
+ :package-version '(cider . "0.11.0"))
+
+(defun cider--pprint-fn ()
+ "Return the value to send in the pprint-fn slot of messages."
+ (pcase cider-pprint-fn
+ (`pprint "clojure.pprint/pprint")
+ (`fipp "cider.nrepl.middleware.pprint/fipp-pprint")
+ (`puget "cider.nrepl.middleware.pprint/puget-pprint")
+ (_ cider-pprint-fn)))
+
+(defun cider--nrepl-pprint-request-plist (right-margin &optional pprint-fn)
+ "Plist to be appended to an eval request to make it use pprint.
+PPRINT-FN is the name of the Clojure function to use.
+RIGHT-MARGIN specifies the maximum column-width of the pretty-printed
+result, and is included in the request if non-nil."
+ (append (list "pprint" "true"
+ "pprint-fn" (or pprint-fn (cider--pprint-fn)))
+ (and right-margin (list "print-right-margin" right-margin))))
+
+(defun cider-tooling-eval (input callback &optional ns)
+ "Send the request INPUT and register the CALLBACK as the response handler.
+NS specifies the namespace in which to evaluate the request."
+ ;; namespace forms are always evaluated in the "user" namespace
+ (nrepl-request:eval input
+ callback
+ (cider-current-connection)
+ ns nil nil nil t ; tooling
+ ))
+
+(defalias 'cider-current-repl-buffer #'cider-current-connection
+ "The current REPL buffer.
+Return the REPL buffer given by `cider-current-connection'.")
+
+(declare-function cider-interrupt-handler "cider-interaction")
+(defun cider-interrupt ()
+ "Interrupt any pending evaluations."
+ (interactive)
+ (with-current-buffer (cider-current-connection)
+ (let ((pending-request-ids (cider-util--hash-keys nrepl-pending-requests)))
+ (dolist (request-id pending-request-ids)
+ (nrepl-request:interrupt
+ request-id
+ (cider-interrupt-handler (current-buffer))
+ (cider-current-connection))))))
+
+(defun cider-current-session ()
+ "Return the eval nREPL session id of the current connection."
+ (cider-session-for-connection (cider-current-connection)))
+
+(defun cider-session-for-connection (connection)
+ (with-current-buffer connection
+ nrepl-session))
+
+(defun cider-current-messages-buffer ()
+ "The nREPL messages buffer, matching the current connection."
+ (nrepl-messages-buffer (cider-current-connection)))
+
+(defun cider-current-tooling-session ()
+ "Return the tooling nREPL session id of the current connection."
+ (with-current-buffer (cider-current-connection)
+ nrepl-tooling-session))
+
+(defun cider--var-choice (var-info)
+ "Prompt to choose from among multiple VAR-INFO candidates, if required.
+This is needed only when the symbol queried is an unqualified host platform
+method, and multiple classes have a so-named member. If VAR-INFO does not
+contain a `candidates' key, it is returned as is."
+ (let ((candidates (nrepl-dict-get var-info "candidates")))
+ (if candidates
+ (let* ((classes (nrepl-dict-keys candidates))
+ (choice (completing-read "Member in class: " classes nil t))
+ (info (nrepl-dict-get candidates choice)))
+ info)
+ var-info)))
+
+(defun cider-var-info (var &optional all)
+ "Return VAR's info as an alist with list cdrs.
+When multiple matching vars are returned you'll be prompted to select one,
+unless ALL is truthy."
+ (when (and var (not (string= var "")))
+ (let ((var-info (cider-sync-request:info var)))
+ (if all var-info (cider--var-choice var-info)))))
+
+(defun cider-member-info (class member)
+ "Return the CLASS MEMBER's info as an alist with list cdrs."
+ (when (and class member)
+ (cider-sync-request:info nil class member)))
+
+(defun cider--find-var-other-window (var &optional line)
+ "Find the definition of VAR, optionally at a specific LINE.
+
+Display the results in a different window."
+ (if-let ((info (cider-var-info var)))
+ (progn
+ (if line (setq info (nrepl-dict-put info "line" line)))
+ (cider--jump-to-loc-from-info info t))
+ (user-error "Symbol %s not resolved" var)))
+
+(defun cider--find-var (var &optional line)
+ "Find the definition of VAR, optionally at a specific LINE."
+ (if-let ((info (cider-var-info var)))
+ (progn
+ (if line (setq info (nrepl-dict-put info "line" line)))
+ (cider--jump-to-loc-from-info info))
+ (user-error "Symbol %s not resolved" var)))
+
+(defun cider-find-var (&optional arg var line)
+ "Find definition for VAR at LINE.
+
+Prompt according to prefix ARG and `cider-prompt-for-symbol'.
+A single or double prefix argument inverts the meaning of
+`cider-prompt-for-symbol'. A prefix of `-` or a double prefix argument causes
+the results to be displayed in a different window. The default value is
+thing at point."
+ (interactive "P")
+ (cider-ensure-op-supported "info")
+ (if var
+ (cider--find-var var line)
+ (funcall (cider-prompt-for-symbol-function arg)
+ "Symbol"
+ (if (cider--open-other-window-p arg)
+ #'cider--find-var-other-window
+ #'cider--find-var))))
+
+\f
+;;; Requests
+
+(declare-function cider-load-file-handler "cider-interaction")
+(defun cider-request:load-file (file-contents file-path file-name &optional connection callback)
+ "Perform the nREPL \"load-file\" op.
+FILE-CONTENTS, FILE-PATH and FILE-NAME are details of the file to be
+loaded.
+
+If CONNECTION is nil, use `cider-current-connection'.
+If CALLBACK is nil, use `cider-load-file-handler'."
+ (cider-nrepl-send-request (list "op" "load-file"
+ "file" file-contents
+ "file-path" file-path
+ "file-name" file-name)
+ (or callback
+ (cider-load-file-handler (current-buffer)))
+ connection))
+
+\f
+;;; Sync Requests
+
+(defcustom cider-filtered-namespaces-regexps
+ '("^cider.nrepl" "^refactor-nrepl" "^clojure.tools.nrepl")
+ "List of regexps used to filter out some vars/symbols/namespaces.
+When nil, nothing is filtered out. Otherwise, all namespaces matching any
+regexp from this list are dropped out of the \"ns-list\" op.
+Also, \"apropos\" won't include vars from such namespaces.
+This list is passed on to the nREPL middleware without any pre-processing.
+So the regexps have to be in Clojure format (with twice the number of
+backslashes) and not Emacs Lisp."
+ :type '(repeat string)
+ :safe #'listp
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defun cider-sync-request:apropos (query &optional search-ns docs-p privates-p case-sensitive-p)
+ "Send \"apropos\" request for regexp QUERY.
+
+Optional arguments include SEARCH-NS, DOCS-P, PRIVATES-P, CASE-SENSITIVE-P."
+ (let* ((query (replace-regexp-in-string "[ \t]+" ".+" query))
+ (response (cider-nrepl-send-sync-request
+ `("op" "apropos"
+ "ns" ,(cider-current-ns)
+ "query" ,query
+ ,@(when search-ns `("search-ns" ,search-ns))
+ ,@(when docs-p '("docs?" "t"))
+ ,@(when privates-p '("privates?" "t"))
+ ,@(when case-sensitive-p '("case-sensitive?" "t"))
+ "filter-regexps" ,cider-filtered-namespaces-regexps))))
+ (if (member "apropos-regexp-error" (nrepl-dict-get response "status"))
+ (user-error "Invalid regexp: %s" (nrepl-dict-get response "error-msg"))
+ (nrepl-dict-get response "apropos-matches"))))
+
+(defun cider-sync-request:classpath ()
+ "Return a list of classpath entries."
+ (cider-ensure-op-supported "classpath")
+ (thread-first (list "op" "classpath")
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "classpath")))
+
+(defun cider-sync-request:complete (str context)
+ "Return a list of completions for STR using nREPL's \"complete\" op.
+CONTEXT represents a completion context for compliment."
+ (when-let ((dict (thread-first (list "op" "complete"
+ "ns" (cider-current-ns)
+ "symbol" str
+ "context" context)
+ (cider-nrepl-send-sync-request nil 'abort-on-input))))
+ (nrepl-dict-get dict "completions")))
+
+(defun cider-sync-request:info (symbol &optional class member)
+ "Send \"info\" op with parameters SYMBOL or CLASS and MEMBER."
+ (let ((var-info (thread-first `("op" "info"
+ "ns" ,(cider-current-ns)
+ ,@(when symbol (list "symbol" symbol))
+ ,@(when class (list "class" class))
+ ,@(when member (list "member" member)))
+ (cider-nrepl-send-sync-request))))
+ (if (member "no-info" (nrepl-dict-get var-info "status"))
+ nil
+ var-info)))
+
+(defun cider-sync-request:eldoc (symbol &optional class member)
+ "Send \"eldoc\" op with parameters SYMBOL or CLASS and MEMBER."
+ (when-let ((eldoc (thread-first `("op" "eldoc"
+ "ns" ,(cider-current-ns)
+ ,@(when symbol (list "symbol" symbol))
+ ,@(when class (list "class" class))
+ ,@(when member (list "member" member)))
+ (cider-nrepl-send-sync-request nil 'abort-on-input))))
+ (if (member "no-eldoc" (nrepl-dict-get eldoc "status"))
+ nil
+ eldoc)))
+
+(defun cider-sync-request:ns-list ()
+ "Get a list of the available namespaces."
+ (thread-first (list "op" "ns-list"
+ "filter-regexps" cider-filtered-namespaces-regexps)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "ns-list")))
+
+(defun cider-sync-request:ns-vars (ns)
+ "Get a list of the vars in NS."
+ (thread-first (list "op" "ns-vars"
+ "ns" ns)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "ns-vars")))
+
+(defun cider-sync-request:ns-vars-with-meta (ns)
+ "Get a map of the vars in NS to its metadata information."
+ (thread-first (list "op" "ns-vars-with-meta"
+ "ns" ns)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "ns-vars-with-meta")))
+
+(defun cider-sync-request:ns-load-all ()
+ "Load all project namespaces."
+ (thread-first (list "op" "ns-load-all")
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "loaded-ns")))
+
+(defun cider-sync-request:resource (name)
+ "Perform nREPL \"resource\" op with resource name NAME."
+ (thread-first (list "op" "resource"
+ "name" name)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "resource-path")))
+
+(defun cider-sync-request:resources-list ()
+ "Return a list of all resources on the classpath."
+ (thread-first (list "op" "resources-list")
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "resources-list")))
+
+(defun cider-sync-request:format-code (code)
+ "Perform nREPL \"format-code\" op with CODE."
+ (thread-first (list "op" "format-code"
+ "code" code)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "formatted-code")))
+
+(defun cider-sync-request:format-edn (edn right-margin)
+ "Perform \"format-edn\" op with EDN and RIGHT-MARGIN."
+ (let* ((response (thread-first (list "op" "format-edn"
+ "edn" edn)
+ (append (cider--nrepl-pprint-request-plist right-margin))
+ (cider-nrepl-send-sync-request)))
+ (err (nrepl-dict-get response "err")))
+ (when err
+ ;; err will be a stacktrace with a first line that looks like:
+ ;; "clojure.lang.ExceptionInfo: Unmatched delimiter ]"
+ (error (car (split-string err "\n"))))
+ (nrepl-dict-get response "formatted-edn")))
+
+\f
+;;; Connection info
+(defun cider--java-version ()
+ "Retrieve the underlying connection's Java version."
+ (with-current-buffer (cider-current-connection "clj")
+ (when nrepl-versions
+ (thread-first nrepl-versions
+ (nrepl-dict-get "java")
+ (nrepl-dict-get "version-string")))))
+
+(defun cider--clojure-version ()
+ "Retrieve the underlying connection's Clojure version."
+ (with-current-buffer (cider-current-connection "clj")
+ (when nrepl-versions
+ (thread-first nrepl-versions
+ (nrepl-dict-get "clojure")
+ (nrepl-dict-get "version-string")))))
+
+(defun cider--nrepl-version ()
+ "Retrieve the underlying connection's nREPL version."
+ (with-current-buffer (cider-current-connection "clj")
+ (when nrepl-versions
+ (thread-first nrepl-versions
+ (nrepl-dict-get "nrepl")
+ (nrepl-dict-get "version-string")))))
+
+(defun cider--connection-info (connection-buffer)
+ "Return info about CONNECTION-BUFFER.
+
+Info contains project name, current REPL namespace, host:port
+endpoint and Clojure version."
+ (with-current-buffer connection-buffer
+ (format "%s%s@%s:%s (Java %s, Clojure %s, nREPL %s)"
+ (upcase (concat cider-repl-type " "))
+ (or (cider--project-name nrepl-project-dir) "<no project>")
+ (car nrepl-endpoint)
+ (cadr nrepl-endpoint)
+ (cider--java-version)
+ (cider--clojure-version)
+ (cider--nrepl-version))))
+
+(defun cider--connection-properties (conn-buffer)
+ "Extract the essential properties of CONN-BUFFER."
+ (with-current-buffer conn-buffer
+ (list
+ :type cider-repl-type
+ :host (car nrepl-endpoint)
+ :port (cadr nrepl-endpoint)
+ :project-dir nrepl-project-dir)))
+
+(defun cider--connection-type (conn-buffer)
+ "Get CONN-BUFFER's type.
+
+Return value matches `cider-repl-type'."
+ (plist-get (cider--connection-properties conn-buffer) :type))
+
+(defun cider--connection-host (conn-buffer)
+ "Get CONN-BUFFER's host."
+ (plist-get (cider--connection-properties conn-buffer) :host))
+
+(defun cider--connection-port (conn-buffer)
+ "Get CONN-BUFFER's port."
+ (plist-get (cider--connection-properties conn-buffer) :port))
+
+(defun cider--connection-project-dir (conn-buffer)
+ "Get CONN-BUFFER's project dir."
+ (plist-get (cider--connection-properties conn-buffer) :project-dir))
+
+(defun cider-display-connection-info (&optional show-default)
+ "Display information about the current connection.
+
+With a prefix argument SHOW-DEFAULT it will display info about the
+default connection."
+ (interactive "P")
+ (message "%s" (cider--connection-info (if show-default
+ (cider-default-connection)
+ (cider-current-connection)))))
+
+(defun cider-rotate-default-connection ()
+ "Rotate and display the default nREPL connection."
+ (interactive)
+ (cider-ensure-connected)
+ (setq cider-connections
+ (append (cdr cider-connections)
+ (list (car cider-connections))))
+ (message "Default nREPL connection: %s"
+ (cider--connection-info (car cider-connections))))
+
+(defun cider-replicate-connection (&optional conn)
+ "Establish a new connection based on an existing connection.
+The new connection will use the same host and port.
+If CONN is not provided the user will be prompted to select a connection."
+ (interactive)
+ (let* ((conn (or conn (cider-read-connection "Select connection to replicate: ")))
+ (host (cider--connection-host conn))
+ (port (cider--connection-port conn))
+ (project-dir (cider--connection-project-dir conn)))
+ (cider-connect host port project-dir)))
+
+(defun cider-extract-designation-from-current-repl-buffer ()
+ "Extract the designation from the cider repl buffer name."
+ (let ((repl-buffer-name (buffer-name (cider-current-repl-buffer)))
+ (template (split-string nrepl-repl-buffer-name-template "%s")))
+ (string-match (format "^%s\\(.*\\)%s"
+ (regexp-quote (concat (car template) nrepl-buffer-name-separator))
+ (regexp-quote (cadr template)))
+ repl-buffer-name)
+ (or (match-string 1 repl-buffer-name) "<no designation>")))
+
+(defun cider-change-buffers-designation (designation)
+ "Change the DESIGNATION in cider buffer names.
+Buffer names changed are cider-repl and nrepl-server."
+ (interactive (list (read-string (format "Change CIDER buffer designation from '%s': "
+ (cider-extract-designation-from-current-repl-buffer)))))
+ (cider-ensure-connected)
+ (let ((new-repl-buffer-name (nrepl-format-buffer-name-template
+ nrepl-repl-buffer-name-template designation)))
+ (with-current-buffer (cider-current-repl-buffer)
+ (rename-buffer new-repl-buffer-name)
+ (when nrepl-server-buffer
+ (let ((new-server-buffer-name (nrepl-format-buffer-name-template
+ nrepl-server-buffer-name-template designation)))
+ (with-current-buffer nrepl-server-buffer
+ (rename-buffer new-server-buffer-name)))))
+ (message "CIDER buffer designation changed to: %s" designation)))
+
+(provide 'cider-client)
+
+;;; cider-client.el ends here
--- /dev/null
+;;; cider-common.el --- Common use functions -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2017 Artur Malabarba
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Common functions that are useful in both Clojure buffers and REPL
+;; buffers.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'cider-compat)
+(require 'nrepl-dict)
+(require 'cider-util)
+(require 'tramp)
+
+(defcustom cider-prompt-for-symbol t
+ "Controls when to prompt for symbol when a command requires one.
+
+When non-nil, always prompt, and use the symbol at point as the default
+value at the prompt.
+
+When nil, attempt to use the symbol at point for the command, and only
+prompt if that throws an error."
+ :type '(choice (const :tag "always" t)
+ (const :tag "dwim" nil))
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-special-mode-truncate-lines t
+ "If non-nil, contents of CIDER's special buffers will be line-truncated.
+Should be set before loading CIDER."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.15.0"))
+
+(defun cider--should-prompt-for-symbol (&optional invert)
+ "Return the value of the variable `cider-prompt-for-symbol'.
+Optionally invert the value, if INVERT is truthy."
+ (if invert (not cider-prompt-for-symbol) cider-prompt-for-symbol))
+
+(defun cider-prompt-for-symbol-function (&optional invert)
+ "Prompt for symbol if funcall `cider--should-prompt-for-symbol' is truthy.
+Otherwise attempt to use the symbol at point for the command, and only
+prompt if that throws an error.
+
+INVERT is used to invert the semantics of the function `cider--should-prompt-for-symbol'."
+ (if (cider--should-prompt-for-symbol invert)
+ #'cider-read-symbol-name
+ #'cider-try-symbol-at-point))
+
+(defun cider--kw-to-symbol (kw)
+ "Convert the keyword KW to a symbol."
+ (when kw
+ (replace-regexp-in-string "\\`:+" "" kw)))
+
+(declare-function cider-read-from-minibuffer "cider-interaction")
+
+(defun cider-read-symbol-name (prompt callback)
+ "Read a symbol name using PROMPT with a default of the one at point.
+Use CALLBACK as the completing read var callback."
+ (funcall callback (cider-read-from-minibuffer
+ prompt
+ ;; if the thing at point is a keyword we treat it as symbol
+ (cider--kw-to-symbol (cider-symbol-at-point 'look-back)))))
+
+(defun cider-try-symbol-at-point (prompt callback)
+ "Call CALLBACK with symbol at point.
+On failure, read a symbol name using PROMPT and call CALLBACK with that."
+ (condition-case nil (funcall callback (cider--kw-to-symbol (cider-symbol-at-point 'look-back)))
+ ('error (funcall callback (cider-read-from-minibuffer prompt)))))
+
+(declare-function cider-jump-to "cider-interaction")
+
+(defun cider--find-buffer-for-file (file)
+ "Return a buffer visiting FILE.
+If FILE is a temp buffer name, return that buffer."
+ (if (string-prefix-p "*" file)
+ file
+ (and file
+ (not (cider--tooling-file-p file))
+ (cider-find-file file))))
+
+(defun cider--jump-to-loc-from-info (info &optional other-window)
+ "Jump to location give by INFO.
+INFO object is returned by `cider-var-info' or `cider-member-info'.
+OTHER-WINDOW is passed to `cider-jump-to'."
+ (let* ((line (nrepl-dict-get info "line"))
+ (file (nrepl-dict-get info "file"))
+ (name (nrepl-dict-get info "name"))
+ ;; the filename might actually be a REPL buffer name
+ (buffer (cider--find-buffer-for-file file)))
+ (if buffer
+ (cider-jump-to buffer (if line (cons line nil) name) other-window)
+ (error "No source location"))))
+
+(declare-function url-filename "url-parse" (cl-x) t)
+
+(defun cider--url-to-file (url)
+ "Return the filename from the resource URL.
+Uses `url-generic-parse-url' to parse the url. The filename is extracted and
+then url decoded. If the decoded filename has a Windows device letter followed
+by a colon immediately after the leading '/' then the leading '/' is dropped to
+create a valid path."
+ (let ((filename (url-unhex-string (url-filename (url-generic-parse-url url)))))
+ (if (string-match "^/\\([a-zA-Z]:/.*\\)" filename)
+ (match-string 1 filename)
+ filename)))
+
+(defun cider-tramp-prefix (&optional buffer)
+ "Use the filename for BUFFER to determine a tramp prefix.
+Defaults to the current buffer.
+Return the tramp prefix, or nil if BUFFER is local."
+ (let* ((buffer (or buffer (current-buffer)))
+ (name (or (buffer-file-name buffer)
+ (with-current-buffer buffer
+ default-directory))))
+ (when (tramp-tramp-file-p name)
+ (let ((vec (tramp-dissect-file-name name)))
+ (tramp-make-tramp-file-name (tramp-file-name-method vec)
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ nil)))))
+
+(defun cider--client-tramp-filename (name &optional buffer)
+ "Return the tramp filename for path NAME relative to BUFFER.
+If BUFFER has a tramp prefix, it will be added as a prefix to NAME.
+If the resulting path is an existing tramp file, it returns the path,
+otherwise, nil."
+ (let* ((buffer (or buffer (current-buffer)))
+ (name (concat (cider-tramp-prefix buffer) name)))
+ (if (tramp-handle-file-exists-p name)
+ name)))
+
+(defun cider--server-filename (name)
+ "Return the nREPL server-relative filename for NAME."
+ (if (tramp-tramp-file-p name)
+ (with-parsed-tramp-file-name name nil
+ localname)
+ name))
+
+(defvar cider-from-nrepl-filename-function
+ (with-no-warnings
+ (if (eq system-type 'cygwin)
+ #'cygwin-convert-file-name-from-windows
+ #'identity))
+ "Function to translate nREPL namestrings to Emacs filenames.")
+
+(defcustom cider-prefer-local-resources nil
+ "Prefer local resources to remote (tramp) ones when both are available."
+ :type 'boolean
+ :group 'cider)
+
+(defun cider--file-path (path)
+ "Return PATH's local or tramp path using `cider-prefer-local-resources'.
+If no local or remote file exists, return nil."
+ (let* ((local-path (funcall cider-from-nrepl-filename-function path))
+ (tramp-path (and local-path (cider--client-tramp-filename local-path))))
+ (cond ((equal local-path "") "")
+ ((and cider-prefer-local-resources (file-exists-p local-path))
+ local-path)
+ ((and tramp-path (file-exists-p tramp-path))
+ tramp-path)
+ ((and local-path (file-exists-p local-path))
+ local-path))))
+
+(declare-function archive-extract "arc-mode")
+(declare-function archive-zip-extract "arc-mode")
+
+(defun cider-find-file (url)
+ "Return a buffer visiting the file URL if it exists, or nil otherwise.
+If URL has a scheme prefix, it must represent a fully-qualified file path
+or an entry within a zip/jar archive. If URL doesn't contain a scheme
+prefix and is an absolute path, it is treated as such. Finally, if URL is
+relative, it is expanded within each of the open Clojure buffers till an
+existing file ending with URL has been found."
+ (require 'arc-mode)
+ (cond ((string-match "^file:\\(.+\\)" url)
+ (when-let ((file (cider--url-to-file (match-string 1 url)))
+ (path (cider--file-path file)))
+ (find-file-noselect path)))
+ ((string-match "^\\(jar\\|zip\\):\\(file:.+\\)!/\\(.+\\)" url)
+ (when-let ((entry (match-string 3 url))
+ (file (cider--url-to-file (match-string 2 url)))
+ (path (cider--file-path file))
+ (name (format "%s:%s" path entry)))
+ (or (find-buffer-visiting name)
+ (if (tramp-tramp-file-p path)
+ (progn
+ ;; Use emacs built in archiving
+ (find-file path)
+ (goto-char (point-min))
+ ;; Make sure the file path is followed by a newline to
+ ;; prevent eg. clj matching cljs.
+ (search-forward (concat entry "\n"))
+ ;; moves up to matching line
+ (forward-line -1)
+ (archive-extract)
+ (current-buffer))
+ ;; Use external zip program to just extract the single file
+ (with-current-buffer (generate-new-buffer
+ (file-name-nondirectory entry))
+ (archive-zip-extract path entry)
+ (set-visited-file-name name)
+ (setq-local default-directory (file-name-directory path))
+ (setq-local buffer-read-only t)
+ (set-buffer-modified-p nil)
+ (set-auto-mode)
+ (current-buffer))))))
+ (t (if-let ((path (cider--file-path url)))
+ (find-file-noselect path)
+ (unless (file-name-absolute-p url)
+ (let ((cider-buffers (cider-util--clojure-buffers))
+ (url (file-name-nondirectory url)))
+ (or (cl-loop for bf in cider-buffers
+ for path = (with-current-buffer bf
+ (expand-file-name url))
+ if (and path (file-exists-p path))
+ return (find-file-noselect path))
+ (cl-loop for bf in cider-buffers
+ if (string= (buffer-name bf) url)
+ return bf))))))))
+
+(defun cider--open-other-window-p (arg)
+ "Test prefix value ARG to see if it indicates displaying results in other window."
+ (let ((narg (prefix-numeric-value arg)))
+ (pcase narg
+ (-1 t) ; -
+ (16 t) ; empty empty
+ (_ nil))))
+
+(defun cider-abbreviate-ns (namespace)
+ "Return a string that abbreviates NAMESPACE."
+ (when namespace
+ (let* ((names (reverse (split-string namespace "\\.")))
+ (lastname (car names)))
+ (concat (mapconcat (lambda (s) (concat (substring s 0 1) "."))
+ (reverse (cdr names))
+ "")
+ lastname))))
+
+(defun cider-last-ns-segment (namespace)
+ "Return the last segment of NAMESPACE."
+ (when namespace
+ (car (reverse (split-string namespace "\\.")))))
+
+
+(provide 'cider-common)
+;;; cider-common.el ends here
--- /dev/null
+;;; cider-compat.el --- Functions from newer Emacs versions for compatibility -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Pretty much everything here's copied from subr-x for compatibility with
+;; Emacs 24.4.
+
+;;; Code:
+
+(eval-and-compile
+
+ (unless (fboundp 'internal--thread-argument)
+ (defmacro internal--thread-argument (first? &rest forms)
+ "Internal implementation for `thread-first' and `thread-last'.
+When Argument FIRST? is non-nil argument is threaded first, else
+last. FORMS are the expressions to be threaded."
+ (pcase forms
+ (`(,x (,f . ,args) . ,rest)
+ `(internal--thread-argument
+ ,first? ,(if first? `(,f ,x ,@args) `(,f ,@args ,x)) ,@rest))
+ (`(,x ,f . ,rest) `(internal--thread-argument ,first? (,f ,x) ,@rest))
+ (_ (car forms)))))
+
+ (unless (fboundp 'thread-first)
+ (defmacro thread-first (&rest forms)
+ "Thread FORMS elements as the first argument of their successor.
+Example:
+ (thread-first
+ 5
+ (+ 20)
+ (/ 25)
+ -
+ (+ 40))
+Is equivalent to:
+ (+ (- (/ (+ 5 20) 25)) 40)
+Note how the single `-' got converted into a list before
+threading."
+ (declare (indent 1)
+ (debug (form &rest [&or symbolp (sexp &rest form)])))
+ `(internal--thread-argument t ,@forms)))
+
+ (unless (fboundp 'thread-last)
+ (defmacro thread-last (&rest forms)
+ "Thread FORMS elements as the last argument of their successor.
+Example:
+ (thread-last
+ 5
+ (+ 20)
+ (/ 25)
+ -
+ (+ 40))
+Is equivalent to:
+ (+ 40 (- (/ 25 (+ 20 5))))
+Note how the single `-' got converted into a list before
+threading."
+ (declare (indent 1) (debug thread-first))
+ `(internal--thread-argument nil ,@forms))))
+
+
+(eval-and-compile
+
+ (unless (fboundp 'internal--listify)
+
+ (defsubst internal--listify (elt)
+ "Wrap ELT in a list if it is not one."
+ (if (not (listp elt))
+ (list elt)
+ elt)))
+
+ (unless (fboundp 'internal--check-binding)
+
+ (defsubst internal--check-binding (binding)
+ "Check BINDING is properly formed."
+ (when (> (length binding) 2)
+ (signal
+ 'error
+ (cons "`let' bindings can have only one value-form" binding)))
+ binding))
+
+ (unless (fboundp 'internal--build-binding-value-form)
+
+ (defsubst internal--build-binding-value-form (binding prev-var)
+ "Build the conditional value form for BINDING using PREV-VAR."
+ `(,(car binding) (and ,prev-var ,(cadr binding)))))
+
+ (unless (fboundp 'internal--build-binding)
+
+ (defun internal--build-binding (binding prev-var)
+ "Check and build a single BINDING with PREV-VAR."
+ (thread-first
+ binding
+ internal--listify
+ internal--check-binding
+ (internal--build-binding-value-form prev-var))))
+
+ (unless (fboundp 'internal--build-bindings)
+
+ (defun internal--build-bindings (bindings)
+ "Check and build conditional value forms for BINDINGS."
+ (let ((prev-var t))
+ (mapcar (lambda (binding)
+ (let ((binding (internal--build-binding binding prev-var)))
+ (setq prev-var (car binding))
+ binding))
+ bindings)))))
+
+(eval-and-compile
+
+ (unless (fboundp 'if-let)
+ (defmacro if-let (bindings then &rest else)
+ "Process BINDINGS and if all values are non-nil eval THEN, else ELSE.
+Argument BINDINGS is a list of tuples whose car is a symbol to be
+bound and (optionally) used in THEN, and its cadr is a sexp to be
+evalled to set symbol's value. In the special case you only want
+to bind a single value, BINDINGS can just be a plain tuple."
+ (declare (indent 2)
+ (debug ([&or (&rest (symbolp form)) (symbolp form)] form body)))
+ (when (and (<= (length bindings) 2)
+ (not (listp (car bindings))))
+ ;; Adjust the single binding case
+ (setq bindings (list bindings)))
+ `(let* ,(internal--build-bindings bindings)
+ (if ,(car (internal--listify (car (last bindings))))
+ ,then
+ ,@else))))
+
+ (unless (fboundp 'when-let)
+ (defmacro when-let (bindings &rest body)
+ "Process BINDINGS and if all values are non-nil eval BODY.
+Argument BINDINGS is a list of tuples whose car is a symbol to be
+bound and (optionally) used in BODY, and its cadr is a sexp to be
+evalled to set symbol's value. In the special case you only want
+to bind a single value, BINDINGS can just be a plain tuple."
+ (declare (indent 1) (debug if-let))
+ (list 'if-let bindings (macroexp-progn body)))))
+
+(provide 'cider-compat)
+;;; cider-compat.el ends here
--- /dev/null
+;;; cider-debug.el --- CIDER interaction with the cider.debug nREPL middleware -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Instrument code with `cider-debug-defun-at-point', and when the code is
+;; executed cider-debug will kick in. See this function's doc for more
+;; information.
+
+;;; Code:
+
+(require 'nrepl-dict)
+(require 'nrepl-client) ; `nrepl--mark-id-completed'
+(require 'cider-interaction)
+(require 'cider-client)
+(require 'cider-util)
+(require 'cider-inspector)
+(require 'cider-browse-ns)
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'seq)
+(require 'spinner)
+
+\f
+;;; Customization
+(defgroup cider-debug nil
+ "Presentation and behaviour of the cider debugger."
+ :prefix "cider-debug-"
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defface cider-debug-code-overlay-face
+ '((((class color) (background light)) :background "grey80")
+ (((class color) (background dark)) :background "grey30"))
+ "Face used to mark code being debugged."
+ :group 'cider-debug
+ :package-version '(cider . "0.9.1"))
+
+(defface cider-debug-prompt-face
+ '((t :underline t :inherit font-lock-builtin-face))
+ "Face used to highlight keys in the debug prompt."
+ :group 'cider-debug
+ :package-version '(cider . "0.10.0"))
+
+(defface cider-enlightened-face
+ '((((class color) (background light)) :inherit cider-result-overlay-face
+ :box (:color "darkorange" :line-width -1))
+ (((class color) (background dark)) :inherit cider-result-overlay-face
+ ;; "#dd0" is a dimmer yellow.
+ :box (:color "#990" :line-width -1)))
+ "Face used to mark enlightened sexps and their return values."
+ :group 'cider-debug
+ :package-version '(cider . "0.11.0"))
+
+(defface cider-enlightened-local-face
+ '((((class color) (background light)) :weight bold :foreground "darkorange")
+ (((class color) (background dark)) :weight bold :foreground "yellow"))
+ "Face used to mark enlightened locals (not their values)."
+ :group 'cider-debug
+ :package-version '(cider . "0.11.0"))
+
+(defcustom cider-debug-prompt 'overlay
+ "If and where to show the keys while debugging.
+If `minibuffer', show it in the minibuffer along with the return value.
+If `overlay', show it in an overlay above the current function.
+If t, do both.
+If nil, don't list available keys at all."
+ :type '(choice (const :tag "Show in minibuffer" minibuffer)
+ (const :tag "Show above function" overlay)
+ (const :tag "Show in both places" t)
+ (const :tag "Don't list keys" nil))
+ :group 'cider-debug
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-debug-use-overlays t
+ "Whether to higlight debugging information with overlays.
+Takes the same possible values as `cider-use-overlays', but only applies to
+values displayed during debugging sessions.
+To control the overlay that lists possible keys above the current function,
+configure `cider-debug-prompt' instead."
+ :type '(choice (const :tag "End of line" t)
+ (const :tag "Bottom of screen" nil)
+ (const :tag "Both" both))
+ :group 'cider-debug
+ :package-version '(cider . "0.9.1"))
+
+(defcustom cider-debug-print-level 10
+ "The print-level for values displayed by the debugger.
+This variable must be set before starting the repl connection."
+ :type '(choice (const :tag "No limit" nil)
+ (integer :tag "Max depth" 10))
+ :group 'cider-debug
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-debug-print-length 10
+ "The print-length for values displayed by the debugger.
+This variable must be set before starting the repl connection."
+ :type '(choice (const :tag "No limit" nil)
+ (integer :tag "Max depth" 10))
+ :group 'cider-debug
+ :package-version '(cider . "0.10.0"))
+
+\f
+;;; Implementation
+(defun cider-browse-instrumented-defs ()
+ "List all instrumented definitions."
+ (interactive)
+ (if-let ((all (thread-first (cider-nrepl-send-sync-request (list "op" "debug-instrumented-defs"))
+ (nrepl-dict-get "list"))))
+ (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (dolist (list all)
+ (let* ((ns (car list))
+ (ns-vars-with-meta (cider-sync-request:ns-vars-with-meta ns))
+ ;; seq of metadata maps of the instrumented vars
+ (instrumented-meta (mapcar (apply-partially #'nrepl-dict-get ns-vars-with-meta)
+ (cdr list))))
+ (cider-browse-ns--list (current-buffer) ns
+ (seq-mapn #'cider-browse-ns--properties
+ (cdr list)
+ instrumented-meta)
+
+ ns 'noerase)
+ (goto-char (point-max))
+ (insert "\n"))))
+ (goto-char (point-min)))
+ (message "No currently instrumented definitions")))
+
+(defun cider--debug-response-handler (response)
+ "Handles RESPONSE from the cider.debug middleware."
+ (nrepl-dbind-response response (status id causes)
+ (when (member "enlighten" status)
+ (cider--handle-enlighten response))
+ (when (or (member "eval-error" status)
+ (member "stack" status))
+ ;; TODO: Make the error buffer a bit friendlier when we're just printing
+ ;; the stack.
+ (cider--render-stacktrace-causes causes))
+ (when (member "need-debug-input" status)
+ (cider--handle-debug response))
+ (when (member "done" status)
+ (nrepl--mark-id-completed id))))
+
+(defun cider--debug-init-connection ()
+ "Initialize a connection with the cider.debug middleware."
+ (cider-nrepl-send-request
+ (append '("op" "init-debugger")
+ (when cider-debug-print-level
+ (list "print-level" cider-debug-print-level))
+ (when cider-debug-print-length
+ (list "print-length" cider-debug-print-length)))
+ #'cider--debug-response-handler))
+
+\f
+;;; Debugging overlays
+(defconst cider--fringe-arrow-string
+ #("." 0 1 (display (left-fringe right-triangle)))
+ "Used as an overlay's before-string prop to place a fringe arrow.")
+
+(defun cider--debug-display-result-overlay (value)
+ "Place an overlay at point displaying VALUE."
+ (when cider-debug-use-overlays
+ ;; This is cosmetic, let's ensure it doesn't break the session no matter what.
+ (ignore-errors
+ ;; Result
+ (cider--make-result-overlay (cider-font-lock-as-clojure value)
+ :where (point-marker)
+ :type 'debug-result
+ 'before-string cider--fringe-arrow-string)
+ ;; Code
+ (cider--make-overlay (save-excursion (clojure-backward-logical-sexp 1) (point))
+ (point) 'debug-code
+ 'face 'cider-debug-code-overlay-face
+ ;; Higher priority than `show-paren'.
+ 'priority 2000))))
+
+\f
+;;; Minor mode
+(defvar-local cider--debug-mode-commands-dict nil
+ "An nrepl-dict from keys to debug commands.
+Autogenerated by `cider--turn-on-debug-mode'.")
+
+(defvar-local cider--debug-mode-response nil
+ "Response that triggered current debug session.
+Set by `cider--turn-on-debug-mode'.")
+
+(defcustom cider-debug-display-locals nil
+ "If non-nil, local variables are displayed while debugging.
+Can be toggled at any time with `\\[cider-debug-toggle-locals]'."
+ :type 'boolean
+ :group 'cider-debug
+ :package-version '(cider . "0.10.0"))
+
+(defun cider--debug-format-locals-list (locals)
+ "Return a string description of list LOCALS.
+Each element of LOCALS should be a list of at least two elements."
+ (if locals
+ (let ((left-col-width
+ ;; To right-indent the variable names.
+ (apply #'max (mapcar (lambda (l) (string-width (car l))) locals))))
+ ;; A format string to build a format string. :-P
+ (mapconcat (lambda (l) (format (format " %%%ds: %%s\n" left-col-width)
+ (propertize (car l) 'face 'font-lock-variable-name-face)
+ (cider-font-lock-as-clojure (cadr l))))
+ locals ""))
+ ""))
+
+(defun cider--debug-prompt (command-dict)
+ "Return prompt to display for COMMAND-DICT."
+ ;; Force `default' face, otherwise the overlay "inherits" the face of the text
+ ;; after it.
+ (format (propertize "%s\n" 'face 'default)
+ (string-join
+ (nrepl-dict-map (lambda (char cmd)
+ (when-let ((pos (cl-search char cmd)))
+ (put-text-property pos (1+ pos) 'face 'cider-debug-prompt-face cmd))
+ cmd)
+ command-dict)
+ " ")))
+
+(defvar-local cider--debug-prompt-overlay nil)
+
+(defun cider--debug-mode-redisplay ()
+ "Display the input prompt to the user."
+ (nrepl-dbind-response cider--debug-mode-response (debug-value input-type locals)
+ (when (or (eq cider-debug-prompt t)
+ (eq cider-debug-prompt 'overlay))
+ (if (overlayp cider--debug-prompt-overlay)
+ (overlay-put cider--debug-prompt-overlay
+ 'before-string (cider--debug-prompt input-type))
+ (setq cider--debug-prompt-overlay
+ (cider--make-overlay
+ (max (car (cider-defun-at-point 'bounds))
+ (window-start))
+ nil 'debug-prompt
+ 'before-string (cider--debug-prompt input-type)))))
+ (let* ((value (concat " " cider-eval-result-prefix
+ (cider-font-lock-as-clojure
+ (or debug-value "#unknown#"))))
+ (to-display
+ (concat (when cider-debug-display-locals
+ (cider--debug-format-locals-list locals))
+ (when (or (eq cider-debug-prompt t)
+ (eq cider-debug-prompt 'minibuffer))
+ (cider--debug-prompt input-type))
+ (when (or (not cider-debug-use-overlays)
+ (eq cider-debug-use-overlays 'both))
+ value))))
+ (if (> (string-width to-display) 0)
+ (message "%s" to-display)
+ ;; If there's nothing to display in the minibuffer. Just send the value
+ ;; to the Messages buffer.
+ (message "%s" value)
+ (message nil)))))
+
+(defun cider-debug-toggle-locals ()
+ "Toggle display of local variables."
+ (interactive)
+ (setq cider-debug-display-locals (not cider-debug-display-locals))
+ (cider--debug-mode-redisplay))
+
+(defun cider--debug-lexical-eval (key form &optional callback _point)
+ "Eval FORM in the lexical context of debug session given by KEY.
+Do nothing if CALLBACK is provided.
+Designed to be used as `cider-interactive-eval-override' and called instead
+of `cider-interactive-eval' in debug sessions."
+ ;; The debugger uses its own callback, so if the caller is passing a callback
+ ;; we return nil and let `cider-interactive-eval' do its thing.
+ (unless callback
+ (cider-debug-mode-send-reply (format "{:response :eval, :code %s}" form)
+ key)
+ t))
+
+(defvar cider--debug-mode-tool-bar-map
+ (let ((tool-bar-map (make-sparse-keymap)))
+ (tool-bar-add-item "right-arrow" #'cider-debug-mode-send-reply :next :label "Next step")
+ (tool-bar-add-item "next-node" #'cider-debug-mode-send-reply :continue :label "Continue non-stop")
+ (tool-bar-add-item "jump-to" #'cider-debug-mode-send-reply :out :label "Out of sexp")
+ (tool-bar-add-item "exit" #'cider-debug-mode-send-reply :quit :label "Quit")
+ tool-bar-map))
+
+(defvar cider--debug-mode-map)
+
+(define-minor-mode cider--debug-mode
+ "Mode active during debug sessions.
+In order to work properly, this mode must be activated by
+`cider--turn-on-debug-mode'."
+ nil " DEBUG" '()
+ (if cider--debug-mode
+ (if cider--debug-mode-response
+ (nrepl-dbind-response cider--debug-mode-response (input-type)
+ ;; A debug session is an ongoing eval, but it's annoying to have the
+ ;; spinner spinning while you debug.
+ (when spinner-current (spinner-stop))
+ (setq-local tool-bar-map cider--debug-mode-tool-bar-map)
+ (add-hook 'kill-buffer-hook #'cider--debug-quit nil 'local)
+ (add-hook 'before-revert-hook #'cider--debug-quit nil 'local)
+ (unless (consp input-type)
+ (error "Activated debug-mode on a message not asking for commands: %s" cider--debug-mode-response))
+ ;; Integrate with eval commands.
+ (setq cider-interactive-eval-override
+ (apply-partially #'cider--debug-lexical-eval
+ (nrepl-dict-get cider--debug-mode-response "key")))
+ ;; Set the keymap.
+ (nrepl-dict-map (lambda (char cmd)
+ (unless (string= char "h") ; `here' needs a special command.
+ (define-key cider--debug-mode-map char #'cider-debug-mode-send-reply))
+ (when (string= char "o")
+ (define-key cider--debug-mode-map (upcase char) #'cider-debug-mode-send-reply)))
+ input-type)
+ (setq cider--debug-mode-commands-dict input-type)
+ ;; Show the prompt.
+ (cider--debug-mode-redisplay)
+ ;; If a sync request is ongoing, the user can't act normally to
+ ;; provide input, so we enter `recursive-edit'.
+ (when nrepl-ongoing-sync-request
+ (recursive-edit)))
+ (cider--debug-mode -1)
+ (if (called-interactively-p 'any)
+ (user-error (substitute-command-keys "Don't call this mode manually, use `\\[universal-argument] \\[cider-eval-defun-at-point]' instead"))
+ (error "Attempt to activate `cider--debug-mode' without setting `cider--debug-mode-response' first")))
+ (setq cider-interactive-eval-override nil)
+ (setq cider--debug-mode-commands-dict nil)
+ (setq cider--debug-mode-response nil)
+ ;; We wait a moment before clearing overlays and the read-onlyness, so that
+ ;; cider-nrepl has a chance to send the next message, and so that the user
+ ;; doesn't accidentally hit `n' between two messages (thus editing the code).
+ (when-let ((proc (unless nrepl-ongoing-sync-request
+ (get-buffer-process (cider-current-connection)))))
+ (accept-process-output proc 1))
+ (unless cider--debug-mode
+ (setq buffer-read-only nil)
+ (cider--debug-remove-overlays (current-buffer)))
+ (when nrepl-ongoing-sync-request
+ (ignore-errors (exit-recursive-edit)))))
+
+;;; Bind the `:here` command to both h and H, because it behaves differently if
+;;; invoked with an uppercase letter.
+(define-key cider--debug-mode-map "h" #'cider-debug-move-here)
+(define-key cider--debug-mode-map "H" #'cider-debug-move-here)
+
+(defun cider--debug-remove-overlays (&optional buffer)
+ "Remove CIDER debug overlays from BUFFER if variable `cider--debug-mode' is nil."
+ (when (or (not buffer) (buffer-live-p buffer))
+ (with-current-buffer (or buffer (current-buffer))
+ (unless cider--debug-mode
+ (kill-local-variable 'tool-bar-map)
+ (remove-overlays nil nil 'category 'debug-result)
+ (remove-overlays nil nil 'category 'debug-code)
+ (setq cider--debug-prompt-overlay nil)
+ (remove-overlays nil nil 'category 'debug-prompt)))))
+
+(defun cider--debug-set-prompt (value)
+ "Set `cider-debug-prompt' to VALUE, then redisplay."
+ (setq cider-debug-prompt value)
+ (cider--debug-mode-redisplay))
+
+(easy-menu-define cider-debug-mode-menu cider--debug-mode-map
+ "Menu for CIDER debug mode"
+ `("CIDER Debugger"
+ ["Next step" (cider-debug-mode-send-reply ":next") :keys "n"]
+ ["Continue non-stop" (cider-debug-mode-send-reply ":continue") :keys "c"]
+ ["Move out of sexp" (cider-debug-mode-send-reply ":out") :keys "o"]
+ ["Quit" (cider-debug-mode-send-reply ":quit") :keys "q"]
+ "--"
+ ["Evaluate in current scope" (cider-debug-mode-send-reply ":eval") :keys "e"]
+ ["Inject value" (cider-debug-mode-send-reply ":inject") :keys "i"]
+ ["Inspect value" (cider-debug-mode-send-reply ":inspect")]
+ ["Inspect local variables" (cider-debug-mode-send-reply ":locals") :keys "l"]
+ "--"
+ ("Configure keys prompt"
+ ["Don't show keys" (cider--debug-set-prompt nil) :style toggle :selected (eq cider-debug-prompt nil)]
+ ["Show in minibuffer" (cider--debug-set-prompt 'minibuffer) :style toggle :selected (eq cider-debug-prompt 'minibuffer)]
+ ["Show above function" (cider--debug-set-prompt 'overlay) :style toggle :selected (eq cider-debug-prompt 'overlay)]
+ ["Show in both places" (cider--debug-set-prompt t) :style toggle :selected (eq cider-debug-prompt t)]
+ "--"
+ ["List locals" cider-debug-toggle-locals :style toggle :selected cider-debug-display-locals])
+ ["Customize" (customize-group 'cider-debug)]))
+
+(defun cider--uppercase-command-p ()
+ "Return true if the last command was uppercase letter."
+ (ignore-errors
+ (let ((case-fold-search nil))
+ (string-match "[[:upper:]]" (string last-command-event)))))
+
+(defun cider-debug-mode-send-reply (command &optional key force)
+ "Reply to the message that started current bufer's debugging session.
+COMMAND is sent as the input option. KEY can be provided to reply to a
+specific message. If FORCE is non-nil, send a \"force?\" argument in the
+message."
+ (interactive (list
+ (if (symbolp last-command-event)
+ (symbol-name last-command-event)
+ (ignore-errors
+ (concat ":" (nrepl-dict-get cider--debug-mode-commands-dict
+ (downcase (string last-command-event))))))
+ nil
+ (cider--uppercase-command-p)))
+ (when (and (string-prefix-p ":" command) force)
+ (setq command (format "{:response %s :force? true}" command)))
+ (cider-nrepl-send-unhandled-request
+ (list "op" "debug-input" "input" (or command ":quit")
+ "key" (or key (nrepl-dict-get cider--debug-mode-response "key"))))
+ (ignore-errors (cider--debug-mode -1)))
+
+(defun cider--debug-quit ()
+ "Send a :quit reply to the debugger. Used in hooks."
+ (when cider--debug-mode
+ (cider-debug-mode-send-reply ":quit")
+ (message "Quitting debug session")))
+
+\f
+;;; Movement logic
+(defconst cider--debug-buffer-format "*cider-debug %s*")
+
+(defun cider--debug-trim-code (code)
+ "Remove whitespace and reader macros from the start of the CODE.
+Return trimmed CODE."
+ (replace-regexp-in-string "\\`#[a-z]+[\n\r[:blank:]]*" "" code))
+
+(declare-function cider-set-buffer-ns "cider-mode")
+(defun cider--initialize-debug-buffer (code ns id &optional reason)
+ "Create a new debugging buffer with CODE and namespace NS.
+ID is the id of the message that instrumented CODE.
+REASON is a keyword describing why this buffer was necessary."
+ (let ((buffer-name (format cider--debug-buffer-format id)))
+ (if-let ((buffer (get-buffer buffer-name)))
+ (cider-popup-buffer-display buffer 'select)
+ (with-current-buffer (cider-popup-buffer buffer-name 'select
+ #'clojure-mode 'ancillary)
+ (cider-set-buffer-ns ns)
+ (setq buffer-undo-list nil)
+ (let ((inhibit-read-only t)
+ (buffer-undo-list t))
+ (erase-buffer)
+ (insert (format "%s" (cider--debug-trim-code code)))
+ (when code
+ (insert "\n\n\n;; We had to create this temporary buffer because we couldn't find the original definition. That probably happened because "
+ reason
+ ".")
+ (fill-paragraph))
+ (cider--font-lock-ensure)
+ (set-buffer-modified-p nil))))
+ (switch-to-buffer buffer-name)
+ (goto-char (point-min))))
+
+(defun cider--debug-goto-keyval (key)
+ "Find KEY in current sexp or return nil."
+ (when-let ((limit (ignore-errors (save-excursion (up-list) (point)))))
+ (search-forward-regexp (concat "\\_<" (regexp-quote key) "\\_>")
+ limit 'noerror)))
+
+(defun cider--debug-move-point (coordinates)
+ "Place point on after the sexp specified by COORDINATES.
+COORDINATES is a list of integers that specify how to navigate into the
+sexp that is after point when this function is called.
+
+As an example, a COORDINATES list of '(1 0 2) means:
+ - enter next sexp then `forward-sexp' once,
+ - enter next sexp,
+ - enter next sexp then `forward-sexp' twice.
+
+In the following snippet, this takes us to the (* x 2) sexp (point is left
+at the end of the given sexp).
+
+ (letfn [(twice [x]
+ (* x 2))]
+ (twice 15))
+
+In addition to numbers, a coordinate can be a string. This string names the
+key of a map, and it means \"go to the value associated with this key\"."
+ (condition-case-unless-debug nil
+ ;; Navigate through sexps inside the sexp.
+ (let ((in-syntax-quote nil))
+ (while coordinates
+ (while (clojure--looking-at-non-logical-sexp)
+ (forward-sexp))
+ ;; An `@x` is read as (deref x), so we pop coordinates once to account
+ ;; for the extra depth, and move past the @ char.
+ (if (eq ?@ (char-after))
+ (progn (forward-char 1)
+ (pop coordinates))
+ (down-list)
+ ;; Are we entering a syntax-quote?
+ (when (looking-back "`\\(#{\\|[{[(]\\)" (line-beginning-position))
+ ;; If we are, this affects all nested structures until the next `~',
+ ;; so we set this variable for all following steps in the loop.
+ (setq in-syntax-quote t))
+ (when in-syntax-quote
+ ;; A `(. .) is read as (seq (concat (list .) (list .))). This pops
+ ;; the `seq', since the real coordinates are inside the `concat'.
+ (pop coordinates)
+ ;; Non-list seqs like `[] and `{} are read with
+ ;; an extra (apply vector ...), so pop it too.
+ (unless (eq ?\( (char-before))
+ (pop coordinates)))
+ ;; #(...) is read as (fn* ([] ...)), so we patch that here.
+ (when (looking-back "#(" (line-beginning-position))
+ (pop coordinates))
+ (if coordinates
+ (let ((next (pop coordinates)))
+ (when in-syntax-quote
+ ;; We're inside the `concat' form, but we need to discard the
+ ;; actual `concat' symbol from the coordinate.
+ (setq next (1- next)))
+ ;; String coordinates are map keys.
+ (if (stringp next)
+ (cider--debug-goto-keyval next)
+ (clojure-forward-logical-sexp next)
+ (when in-syntax-quote
+ (clojure-forward-logical-sexp 1)
+ (forward-sexp -1)
+ ;; Here a syntax-quote is ending.
+ (let ((match (when (looking-at "~@?")
+ (match-string 0))))
+ (when match
+ (setq in-syntax-quote nil))
+ ;; A `~@' is read as the object itself, so we don't pop
+ ;; anything.
+ (unless (equal "~@" match)
+ ;; Anything else (including a `~') is read as a `list'
+ ;; form inside the `concat', so we need to pop the list
+ ;; from the coordinates.
+ (pop coordinates))))))
+ ;; If that extra pop was the last coordinate, this represents the
+ ;; entire #(...), so we should move back out.
+ (backward-up-list))))
+ ;; Place point at the end of instrumented sexp.
+ (clojure-forward-logical-sexp 1))
+ ;; Avoid throwing actual errors, since this happens on every breakpoint.
+ (error (message "Can't find instrumented sexp, did you edit the source?"))))
+
+(defun cider--debug-position-for-code (code)
+ "Return non-nil if point is roughly before CODE.
+This might move point one line above."
+ (or (looking-at-p (regexp-quote code))
+ (let ((trimmed (regexp-quote (cider--debug-trim-code code))))
+ (or (looking-at-p trimmed)
+ ;; If this is a fake #dbg injected by `C-u
+ ;; C-M-x', then the sexp we want is actually on
+ ;; the line above.
+ (progn (forward-line -1)
+ (looking-at-p trimmed))))))
+
+(defun cider--debug-find-source-position (response &optional create-if-needed)
+ "Return a marker of the position after the sexp specified in RESPONSE.
+This marker might be in a different buffer! If the sexp can't be
+found (file that contains the code is no longer visited or has been
+edited), return nil. However, if CREATE-IF-NEEDED is non-nil, a new buffer
+is created in this situation and the return value is never nil.
+
+Follow the \"line\" and \"column\" entries in RESPONSE, and check whether
+the code at point matches the \"code\" entry in RESPONSE. If it doesn't,
+assume that the code in this file has been edited, and create a temp buffer
+holding the original code.
+Either way, navigate inside the code by following the \"coor\" entry which
+is a coordinate measure in sexps."
+ (nrepl-dbind-response response (code file line column ns original-id coor)
+ (when (or code (and file line column))
+ ;; This is for restoring current-buffer.
+ (save-excursion
+ (let ((out))
+ ;; We prefer in-source debugging.
+ (when-let ((buf (and file line column
+ (ignore-errors
+ (cider--find-buffer-for-file file)))))
+ ;; The logic here makes it hard to use `with-current-buffer'.
+ (with-current-buffer buf
+ ;; This is for restoring point inside buf.
+ (save-excursion
+ ;; Get to the proper line & column in the file
+ (forward-line (- line (line-number-at-pos)))
+ (move-to-column column)
+ ;; Check if it worked
+ (when (cider--debug-position-for-code code)
+ ;; Find the desired sexp.
+ (cider--debug-move-point coor)
+ (setq out (point-marker))))))
+ ;; But we can create a temp buffer if that fails.
+ (or out
+ (when create-if-needed
+ (cider--initialize-debug-buffer
+ code ns original-id
+ (if (and line column)
+ "you edited the code"
+ "your tools.nrepl version is older than 0.2.11"))
+ (save-excursion
+ (cider--debug-move-point coor)
+ (point-marker)))))))))
+
+(defun cider--handle-debug (response)
+ "Handle debugging notification.
+RESPONSE is a message received from the nrepl describing the input
+needed. It is expected to contain at least \"key\", \"input-type\", and
+\"prompt\", and possibly other entries depending on the input-type."
+ (nrepl-dbind-response response (debug-value key input-type prompt inspect)
+ (condition-case-unless-debug e
+ (progn
+ (pcase input-type
+ ("expression" (cider-debug-mode-send-reply
+ (condition-case nil
+ (cider-read-from-minibuffer
+ (or prompt "Expression: "))
+ (quit "nil"))
+ key))
+ ((pred sequencep)
+ (let* ((marker (cider--debug-find-source-position response 'create-if-needed)))
+ (pop-to-buffer (marker-buffer marker))
+ (goto-char marker))
+ ;; The overlay code relies on window boundaries, but point could have been
+ ;; moved outside the window by some other code. Redisplay here to ensure the
+ ;; visible window includes point.
+ (redisplay)
+ ;; Remove overlays AFTER redisplaying! Otherwise there's a visible
+ ;; flicker even if we immediately recreate the overlays.
+ (cider--debug-remove-overlays)
+ (when cider-debug-use-overlays
+ (cider--debug-display-result-overlay debug-value))
+ (setq cider--debug-mode-response response)
+ (cider--debug-mode 1)))
+ (when inspect
+ (cider-inspector--render-value inspect)))
+ ;; If something goes wrong, we send a "quit" or the session hangs.
+ (error (cider-debug-mode-send-reply ":quit" key)
+ (message "Error encountered while handling the debug message: %S" e)))))
+
+(defun cider--handle-enlighten (response)
+ "Handle an enlighten notification.
+RESPONSE is a message received from the nrepl describing the value and
+coordinates of a sexp. Create an overlay after the specified sexp
+displaying its value."
+ (when-let ((marker (cider--debug-find-source-position response)))
+ (with-current-buffer (marker-buffer marker)
+ (save-excursion
+ (goto-char marker)
+ (clojure-backward-logical-sexp 1)
+ (nrepl-dbind-response response (debug-value erase-previous)
+ (when erase-previous
+ (remove-overlays (point) marker 'category 'enlighten))
+ (when debug-value
+ (if (memq (char-before marker) '(?\) ?\] ?}))
+ ;; Enlightening a sexp looks like a regular return value, except
+ ;; for a different border.
+ (cider--make-result-overlay (cider-font-lock-as-clojure debug-value)
+ :where (cons marker marker)
+ :type 'enlighten
+ :prepend-face 'cider-enlightened-face)
+ ;; Enlightening a symbol uses a more abbreviated format. The
+ ;; result face is the same as a regular result, but we also color
+ ;; the symbol with `cider-enlightened-local-face'.
+ (cider--make-result-overlay (cider-font-lock-as-clojure debug-value)
+ :format "%s"
+ :where (cons (point) marker)
+ :type 'enlighten
+ 'face 'cider-enlightened-local-face))))))))
+
+\f
+;;; Move here command
+;; This is the inverse of `cider--debug-move-point'. However, that algorithm is
+;; complicated, and trying to code its inverse would probably be insane.
+;; Instead, we find the coordinate by trial and error.
+(defun cider--debug-find-coordinates-for-point (target &optional list-so-far)
+ "Return the coordinates list for reaching TARGET.
+Assumes that the next thing after point is a logical Clojure sexp and that
+TARGET is inside it. The returned list is suitable for use in
+`cider--debug-move-point'. LIST-SO-FAR is for internal use."
+ (when (looking-at (rx (or "(" "[" "#{" "{")))
+ (let ((starting-point (point)))
+ (unwind-protect
+ (let ((x 0))
+ ;; Keep incrementing the last coordinate until we've moved
+ ;; past TARGET.
+ (while (condition-case nil
+ (progn (goto-char starting-point)
+ (cider--debug-move-point (append list-so-far (list x)))
+ (< (point) target))
+ ;; Not a valid coordinate. Move back a step and stop here.
+ (scan-error (setq x (1- x))
+ nil))
+ (setq x (1+ x)))
+ (setq list-so-far (append list-so-far (list x)))
+ ;; We have moved past TARGET, now determine whether we should
+ ;; stop, or if target is deeper inside the previous sexp.
+ (if (or (= target (point))
+ (progn (forward-sexp -1)
+ (<= target (point))))
+ list-so-far
+ (goto-char starting-point)
+ (cider--debug-find-coordinates-for-point target list-so-far)))
+ ;; `unwind-protect' clause.
+ (goto-char starting-point)))))
+
+(defun cider-debug-move-here (&optional force)
+ "Skip any breakpoints up to point."
+ (interactive (list (cider--uppercase-command-p)))
+ (unless cider--debug-mode
+ (user-error "`cider-debug-move-here' only makes sense during a debug session"))
+ (let ((here (point)))
+ (nrepl-dbind-response cider--debug-mode-response (line column)
+ (if (and line column (buffer-file-name))
+ (progn ;; Get to the proper line & column in the file
+ (forward-line (1- (- line (line-number-at-pos))))
+ (move-to-column column))
+ (beginning-of-defun))
+ ;; Is HERE inside the sexp being debugged?
+ (when (or (< here (point))
+ (save-excursion
+ (forward-sexp 1)
+ (> here (point))))
+ (user-error "Point is outside the sexp being debugged"))
+ ;; Move forward untill start of sexp.
+ (comment-normalize-vars)
+ (comment-forward (point-max))
+ ;; Find the coordinate and send it.
+ (cider-debug-mode-send-reply
+ (format "{:response :here, :coord %s :force? %s}"
+ (cider--debug-find-coordinates-for-point here)
+ (if force "true" "false"))))))
+
+\f
+;;; User commands
+;;;###autoload
+(defun cider-debug-defun-at-point ()
+ "Instrument the \"top-level\" expression at point.
+If it is a defn, dispatch the instrumented definition. Otherwise,
+immediately evaluate the instrumented expression.
+
+While debugged code is being evaluated, the user is taken through the
+source code and displayed the value of various expressions. At each step,
+a number of keys will be prompted to the user."
+ (interactive)
+ (cider-eval-defun-at-point 'debug-it))
+
+(provide 'cider-debug)
+;;; cider-debug.el ends here
--- /dev/null
+;;; cider-doc.el --- CIDER documentation functionality -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2017 Bozhidar Batsov, Jeff Valk and CIDER contributors
+
+;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Mode for formatting and presenting documentation
+
+;;; Code:
+
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-util)
+(require 'cider-popup)
+(require 'cider-client)
+(require 'cider-grimoire)
+(require 'nrepl-dict)
+(require 'org-table)
+(require 'button)
+(require 'easymenu)
+
+\f
+;;; Variables
+
+(defgroup cider-doc nil
+ "Documentation for CIDER."
+ :prefix "cider-doc-"
+ :group 'cider)
+
+
+(defvar cider-doc-map
+ (let (cider-doc-map)
+ (define-prefix-command 'cider-doc-map)
+ (define-key cider-doc-map (kbd "a") #'cider-apropos)
+ (define-key cider-doc-map (kbd "C-a") #'cider-apropos)
+ (define-key cider-doc-map (kbd "s") #'cider-apropos-select)
+ (define-key cider-doc-map (kbd "C-s") #'cider-apropos-select)
+ (define-key cider-doc-map (kbd "f") #'cider-apropos-documentation)
+ (define-key cider-doc-map (kbd "C-f") #'cider-apropos-documentation)
+ (define-key cider-doc-map (kbd "e") #'cider-apropos-documentation-select)
+ (define-key cider-doc-map (kbd "C-e") #'cider-apropos-documentation-select)
+ (define-key cider-doc-map (kbd "d") #'cider-doc)
+ (define-key cider-doc-map (kbd "C-d") #'cider-doc)
+ (define-key cider-doc-map (kbd "r") #'cider-grimoire)
+ (define-key cider-doc-map (kbd "C-r") #'cider-grimoire)
+ (define-key cider-doc-map (kbd "w") #'cider-grimoire-web)
+ (define-key cider-doc-map (kbd "C-w") #'cider-grimoire-web)
+ (define-key cider-doc-map (kbd "j") #'cider-javadoc)
+ (define-key cider-doc-map (kbd "C-j") #'cider-javadoc)
+ cider-doc-map)
+ "CIDER documentation keymap.")
+
+(defconst cider-doc-menu
+ '("Documentation"
+ ["CiderDoc" cider-doc]
+ ["JavaDoc in browser" cider-javadoc]
+ ["Grimoire" cider-grimoire]
+ ["Grimoire in browser" cider-grimoire-web]
+ ["Search symbols" cider-apropos]
+ ["Search symbols & select" cider-apropos-select]
+ ["Search documentation" cider-apropos-documentation]
+ ["Search documentation & select" cider-apropos-documentation-select]
+ "--"
+ ["Configure Doc buffer" (customize-group 'cider-docview-mode)])
+ "CIDER documentation submenu.")
+
+\f
+;;; cider-docview-mode
+
+(defgroup cider-docview-mode nil
+ "Formatting/fontifying documentation viewer."
+ :prefix "cider-docview-"
+ :group 'cider)
+
+(defcustom cider-docview-fill-column fill-column
+ "Fill column for docstrings in doc buffer."
+ :type 'list
+ :group 'cider-docview-mode
+ :package-version '(cider . "0.7.0"))
+
+
+\f
+;; Faces
+
+(defface cider-docview-emphasis-face
+ '((t (:inherit default :underline t)))
+ "Face for emphasized text"
+ :group 'cider-docview-mode
+ :package-version '(cider . "0.7.0"))
+
+(defface cider-docview-strong-face
+ '((t (:inherit default :underline t :weight bold)))
+ "Face for strongly emphasized text"
+ :group 'cider-docview-mode
+ :package-version '(cider . "0.7.0"))
+
+(defface cider-docview-literal-face
+ '((t (:inherit font-lock-string-face)))
+ "Face for literal text"
+ :group 'cider-docview-mode
+ :package-version '(cider . "0.7.0"))
+
+(defface cider-docview-table-border-face
+ '((t (:inherit shadow)))
+ "Face for table borders"
+ :group 'cider-docview-mode
+ :package-version '(cider . "0.7.0"))
+
+\f
+;; Colors & Theme Support
+
+(defvar cider-docview-code-background-color
+ (cider-scale-background-color)
+ "Background color for code blocks.")
+
+(defadvice enable-theme (after cider-docview-adapt-to-theme activate)
+ "When theme is changed, update `cider-docview-code-background-color'."
+ (setq cider-docview-code-background-color (cider-scale-background-color)))
+
+\f
+;; Mode & key bindings
+
+(defvar cider-docview-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "q" #'cider-popup-buffer-quit-function)
+ (define-key map "g" #'cider-docview-grimoire)
+ (define-key map "G" #'cider-docview-grimoire-web)
+ (define-key map "j" #'cider-docview-javadoc)
+ (define-key map "s" #'cider-docview-source)
+ (define-key map (kbd "<backtab>") #'backward-button)
+ (define-key map (kbd "TAB") #'forward-button)
+ (easy-menu-define cider-docview-mode-menu map
+ "Menu for CIDER's doc mode"
+ `("CiderDoc"
+ ["Look up in Grimoire" cider-docview-grimoire]
+ ["Look up in Grimoire (browser)" cider-docview-grimoire-web]
+ ["JavaDoc in browser" cider-docview-javadoc]
+ ["Jump to source" cider-docview-source]
+ "--"
+ ["Quit" cider-popup-buffer-quit-function]
+ ))
+ map))
+
+(defvar cider-docview-symbol)
+(defvar cider-docview-javadoc-url)
+(defvar cider-docview-file)
+(defvar cider-docview-line)
+
+(define-derived-mode cider-docview-mode help-mode "Doc"
+ "Major mode for displaying CIDER documentation
+
+\\{cider-docview-mode-map}"
+ (setq buffer-read-only t)
+ (when cider-special-mode-truncate-lines
+ (setq-local truncate-lines t))
+ (setq-local electric-indent-chars nil)
+ (setq-local cider-docview-symbol nil)
+ (setq-local cider-docview-javadoc-url nil)
+ (setq-local cider-docview-file nil)
+ (setq-local cider-docview-line nil))
+
+\f
+;;; Interactive functions
+
+(defun cider-docview-javadoc ()
+ "Open the Javadoc for the current class, if available."
+ (interactive)
+ (if cider-docview-javadoc-url
+ (browse-url cider-docview-javadoc-url)
+ (error "No Javadoc available for %s" cider-docview-symbol)))
+
+(defun cider-javadoc-handler (symbol-name)
+ "Invoke the nREPL \"info\" op on SYMBOL-NAME if available."
+ (when symbol-name
+ (let* ((info (cider-var-info symbol-name))
+ (url (nrepl-dict-get info "javadoc")))
+ (if url
+ (browse-url url)
+ (user-error "No Javadoc available for %s" symbol-name)))))
+
+(defun cider-javadoc (arg)
+ "Open Javadoc documentation in a popup buffer.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates."
+ (interactive "P")
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "info")
+ (funcall (cider-prompt-for-symbol-function arg)
+ "Javadoc for"
+ #'cider-javadoc-handler))
+
+(declare-function cider-find-file "cider-common")
+(declare-function cider-jump-to "cider-interaction")
+
+(defun cider-docview-source ()
+ "Open the source for the current symbol, if available."
+ (interactive)
+ (if cider-docview-file
+ (if-let ((buffer (and (not (cider--tooling-file-p cider-docview-file))
+ (cider-find-file cider-docview-file))))
+ (cider-jump-to buffer (if cider-docview-line
+ (cons cider-docview-line nil)
+ cider-docview-symbol)
+ nil)
+ (user-error
+ (substitute-command-keys
+ "Can't find the source because it wasn't defined with `cider-eval-buffer'")))
+ (error "No source location for %s" cider-docview-symbol)))
+
+(defvar cider-buffer-ns)
+
+(declare-function cider-grimoire-lookup "cider-grimoire")
+
+(defun cider-docview-grimoire ()
+ "Return the grimoire documentation for `cider-docview-symbol'."
+ (interactive)
+ (if cider-buffer-ns
+ (cider-grimoire-lookup cider-docview-symbol)
+ (error "%s cannot be looked up on Grimoire" cider-docview-symbol)))
+
+(declare-function cider-grimoire-web-lookup "cider-grimoire")
+
+(defun cider-docview-grimoire-web ()
+ "Open the grimoire documentation for `cider-docview-symbol' in a web browser."
+ (interactive)
+ (if cider-buffer-ns
+ (cider-grimoire-web-lookup cider-docview-symbol)
+ (error "%s cannot be looked up on Grimoire" cider-docview-symbol)))
+
+(defconst cider-doc-buffer "*cider-doc*")
+(add-to-list 'cider-ancillary-buffers cider-doc-buffer)
+
+(defun cider-create-doc-buffer (symbol)
+ "Populates *cider-doc* with the documentation for SYMBOL."
+ (when-let ((info (cider-var-info symbol)))
+ (cider-docview-render (cider-make-popup-buffer cider-doc-buffer) symbol info)))
+
+(defun cider-doc-lookup (symbol)
+ "Look up documentation for SYMBOL."
+ (if-let ((buffer (cider-create-doc-buffer symbol)))
+ (cider-popup-buffer-display buffer t)
+ (user-error "Symbol %s not resolved" symbol)))
+
+(defun cider-doc (&optional arg)
+ "Open Clojure documentation in a popup buffer.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates."
+ (interactive "P")
+ (cider-ensure-connected)
+ (funcall (cider-prompt-for-symbol-function arg)
+ "Doc for"
+ #'cider-doc-lookup))
+
+\f
+;;; Font Lock and Formatting
+
+(defun cider-docview-fontify-code-blocks (buffer mode)
+ "Font lock BUFFER code blocks using MODE and remove markdown characters.
+This processes the triple backtick GFM markdown extension. An overlay is used
+to shade the background. Blocks are marked to be ignored by other fonification
+and line wrap."
+ (with-current-buffer buffer
+ (save-excursion
+ (while (search-forward-regexp "```\n" nil t)
+ (replace-match "")
+ (let ((beg (point))
+ (bg `(:background ,cider-docview-code-background-color)))
+ (when (search-forward-regexp "```\n" nil t)
+ (replace-match "")
+ (cider-font-lock-region-as mode beg (point))
+ (overlay-put (make-overlay beg (point)) 'font-lock-face bg)
+ (put-text-property beg (point) 'block 'code)))))))
+
+(defun cider-docview-fontify-literals (buffer)
+ "Font lock BUFFER literal text and remove backtick markdown characters.
+Preformatted code text blocks are ignored."
+ (with-current-buffer buffer
+ (save-excursion
+ (while (search-forward "`" nil t)
+ (if (eq (get-text-property (point) 'block) 'code)
+ (forward-char)
+ (progn
+ (replace-match "")
+ (let ((beg (point)))
+ (when (search-forward "`" (line-end-position) t)
+ (replace-match "")
+ (put-text-property beg (point) 'font-lock-face 'cider-docview-literal-face)))))))))
+
+(defun cider-docview-fontify-emphasis (buffer)
+ "Font lock BUFFER emphasized text and remove markdown characters.
+One '*' represents emphasis, multiple '**'s represent strong emphasis.
+Preformatted code text blocks are ignored."
+ (with-current-buffer buffer
+ (save-excursion
+ (while (search-forward-regexp "\\(*+\\)\\(\\w\\)" nil t)
+ (if (eq (get-text-property (point) 'block) 'code)
+ (forward-char)
+ (progn
+ (replace-match "\\2")
+ (let ((beg (1- (point)))
+ (face (if (> (length (match-string 1)) 1)
+ 'cider-docview-strong-face
+ 'cider-docview-emphasis-face)))
+ (when (search-forward-regexp "\\(\\w\\)\\*+" (line-end-position) t)
+ (replace-match "\\1")
+ (put-text-property beg (point) 'font-lock-face face)))))))))
+
+(defun cider-docview-format-tables (buffer)
+ "Align BUFFER tables and dim borders.
+This processes the GFM table markdown extension using `org-table'.
+Tables are marked to be ignored by line wrap."
+ (with-current-buffer buffer
+ (save-excursion
+ (let ((border 'cider-docview-table-border-face))
+ (org-table-map-tables
+ (lambda ()
+ (org-table-align)
+ (goto-char (org-table-begin))
+ (while (search-forward-regexp "[+|-]" (org-table-end) t)
+ (put-text-property (match-beginning 0) (match-end 0) 'font-lock-face border))
+ (put-text-property (org-table-begin) (org-table-end) 'block 'table)))))))
+
+(defun cider-docview-wrap-text (buffer)
+ "For text in BUFFER not propertized as 'block', apply line wrap."
+ (with-current-buffer buffer
+ (save-excursion
+ (while (not (eobp))
+ (unless (get-text-property (point) 'block)
+ (fill-region (point) (line-end-position)))
+ (forward-line)))))
+
+\f
+;;; Rendering
+
+(defun cider-docview-render-java-doc (buffer text)
+ "Emit into BUFFER formatted doc TEXT for a Java class or member."
+ (with-current-buffer buffer
+ (let ((beg (point)))
+ (insert text)
+ (save-excursion
+ (goto-char beg)
+ (cider-docview-fontify-code-blocks buffer 'java-mode) ; left alone hereafter
+ (cider-docview-fontify-literals buffer)
+ (cider-docview-fontify-emphasis buffer)
+ (cider-docview-format-tables buffer) ; may contain literals, emphasis
+ (cider-docview-wrap-text buffer))))) ; ignores code, table blocks
+
+(defun cider--abbreviate-file-protocol (file-with-protocol)
+ "Abbreviate the file-path in `file:/path/to/file'."
+ (if (string-match "\\`file:\\(.*\\)" file-with-protocol)
+ (let ((file (match-string 1 file-with-protocol))
+ (proj-dir (clojure-project-dir)))
+ (if (and proj-dir
+ (file-in-directory-p file proj-dir))
+ (file-relative-name file proj-dir)
+ file))
+ file-with-protocol))
+
+(defun cider-docview-render-info (buffer info)
+ "Emit into BUFFER formatted INFO for the Clojure or Java symbol."
+ (let* ((ns (nrepl-dict-get info "ns"))
+ (name (nrepl-dict-get info "name"))
+ (added (nrepl-dict-get info "added"))
+ (depr (nrepl-dict-get info "deprecated"))
+ (macro (nrepl-dict-get info "macro"))
+ (special (nrepl-dict-get info "special-form"))
+ (forms (nrepl-dict-get info "forms-str"))
+ (args (nrepl-dict-get info "arglists-str"))
+ (doc (or (nrepl-dict-get info "doc")
+ "Not documented."))
+ (url (nrepl-dict-get info "url"))
+ (class (nrepl-dict-get info "class"))
+ (member (nrepl-dict-get info "member"))
+ (javadoc (nrepl-dict-get info "javadoc"))
+ (super (nrepl-dict-get info "super"))
+ (ifaces (nrepl-dict-get info "interfaces"))
+ (spec (nrepl-dict-get info "spec"))
+ (clj-name (if ns (concat ns "/" name) name))
+ (java-name (if member (concat class "/" member) class))
+ (see-also (nrepl-dict-get info "see-also")))
+ (cider--help-setup-xref (list #'cider-doc-lookup (format "%s/%s" ns name)) nil buffer)
+ (with-current-buffer buffer
+ (cl-flet ((emit (text &optional face)
+ (insert (if face
+ (propertize text 'font-lock-face face)
+ text)
+ "\n")))
+ (emit (if class java-name clj-name) 'font-lock-function-name-face)
+ (when super
+ (emit (concat " Extends: " (cider-font-lock-as 'java-mode super))))
+ (when ifaces
+ (emit (concat "Implements: " (cider-font-lock-as 'java-mode (car ifaces))))
+ (dolist (iface (cdr ifaces))
+ (emit (concat " "(cider-font-lock-as 'java-mode iface)))))
+ (when (or super ifaces)
+ (insert "\n"))
+ (when (or forms args)
+ (insert " ")
+ (save-excursion
+ (emit (cider-font-lock-as-clojure
+ ;; All `defn's use ([...] [...]), but some special forms use
+ ;; (...). We only remove the parentheses on the former.
+ (replace-regexp-in-string "\\`(\\(\\[.*\\]\\))\\'" "\\1"
+ (or forms args)))))
+ ;; It normally doesn't happen, but it's technically conceivable for
+ ;; the args string to contain unbalanced sexps, so `ignore-errors'.
+ (ignore-errors
+ (forward-sexp 1)
+ (while (not (looking-at "$"))
+ (insert "\n")
+ (forward-sexp 1)))
+ (forward-line 1))
+ (when (or special macro)
+ (emit (if special "Special Form" "Macro") 'font-lock-variable-name-face))
+ (when added
+ (emit (concat "Added in " added) 'font-lock-comment-face))
+ (when depr
+ (emit (concat "Deprecated in " depr) 'font-lock-keyword-face))
+ (if class
+ (cider-docview-render-java-doc (current-buffer) doc)
+ (emit (concat " " doc)))
+ (when url
+ (insert "\n Please see ")
+ (insert-text-button url
+ 'url url
+ 'follow-link t
+ 'action (lambda (x)
+ (browse-url (button-get x 'url))))
+ (insert "\n"))
+ (when javadoc
+ (insert "\n\nFor additional documentation, see the ")
+ (insert-text-button "Javadoc"
+ 'url javadoc
+ 'follow-link t
+ 'action (lambda (x)
+ (browse-url (button-get x 'url))))
+ (insert ".\n"))
+ (insert "\n")
+ (when spec
+ (emit "Spec: " 'font-lock-function-name-face)
+ (mapc (lambda (s) (insert s "\n")) spec)
+ (insert "\n"))
+ (if cider-docview-file
+ (progn
+ (insert (propertize (if class java-name clj-name)
+ 'font-lock-face 'font-lock-function-name-face)
+ " is defined in ")
+ (insert-text-button (cider--abbreviate-file-protocol cider-docview-file)
+ 'follow-link t
+ 'action (lambda (_x)
+ (cider-docview-source)))
+ (insert "."))
+ (insert "Definition location unavailable."))
+ (when see-also
+ (insert "\n\n Also see: ")
+ (mapc (lambda (ns-sym)
+ (let* ((ns-sym-split (split-string ns-sym "/"))
+ (see-also-ns (car ns-sym-split))
+ (see-also-sym (cadr ns-sym-split))
+ ;; if the var belongs to the same namespace,
+ ;; we omit the namespace to save some screen space
+ (symbol (if (equal ns see-also-ns) see-also-sym ns-sym)))
+ (insert-button symbol
+ 'type 'help-xref
+ 'help-function (apply-partially #'cider-doc-lookup symbol)))
+ (insert " "))
+ see-also))
+ (cider--doc-make-xrefs)
+ (let ((beg (point-min))
+ (end (point-max)))
+ (nrepl-dict-map (lambda (k v)
+ (put-text-property beg end k v))
+ info)))
+ (current-buffer))))
+
+(declare-function cider-set-buffer-ns "cider-mode")
+(defun cider-docview-render (buffer symbol info)
+ "Emit into BUFFER formatted documentation for SYMBOL's INFO."
+ (with-current-buffer buffer
+ (let ((javadoc (nrepl-dict-get info "javadoc"))
+ (file (nrepl-dict-get info "file"))
+ (line (nrepl-dict-get info "line"))
+ (ns (nrepl-dict-get info "ns"))
+ (inhibit-read-only t))
+ (cider-docview-mode)
+
+ (cider-set-buffer-ns ns)
+ (setq-local cider-docview-symbol symbol)
+ (setq-local cider-docview-javadoc-url javadoc)
+ (setq-local cider-docview-file file)
+ (setq-local cider-docview-line line)
+
+ (remove-overlays)
+ (cider-docview-render-info buffer info)
+
+ (goto-char (point-min))
+ (current-buffer))))
+
+
+(provide 'cider-doc)
+
+;;; cider-doc.el ends here
--- /dev/null
+;;; cider-eldoc.el --- eldoc support for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; eldoc support for Clojure.
+
+;;; Code:
+
+(require 'cider-client)
+(require 'cider-common) ; for cider-symbol-at-point
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-util)
+(require 'nrepl-dict)
+
+(require 'seq)
+
+(require 'eldoc)
+
+(defvar cider-extra-eldoc-commands '("yas-expand")
+ "Extra commands to be added to eldoc's safe commands list.")
+
+(defcustom cider-eldoc-max-num-sexps-to-skip 30
+ "The maximum number of sexps to skip while searching the beginning of current sexp."
+ :type 'integer
+ :group 'cider
+ :package-version '(cider . "0.10.1"))
+
+(defvar-local cider-eldoc-last-symbol nil
+ "The eldoc information for the last symbol we checked.")
+
+(defcustom cider-eldoc-ns-function #'identity
+ "A function that returns a ns string to be used by eldoc.
+Takes one argument, a namespace name.
+For convenience, some functions are already provided for this purpose:
+`cider-abbreviate-ns', and `cider-last-ns-segment'."
+ :type '(choice (const :tag "Full namespace" identity)
+ (const :tag "Abbreviated namespace" cider-abbreviate-ns)
+ (const :tag "Last name in namespace" cider-last-ns-segment)
+ (function :tag "Custom function"))
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defcustom cider-eldoc-max-class-names-to-display 3
+ "The maximum number of classes to display in an eldoc string.
+An eldoc string for Java interop forms can have a number of classes prefixed to
+it, when the form belongs to more than 1 class. When, not nil we only display
+the names of first `cider-eldoc-max-class-names-to-display' classes and add
+a \"& x more\" suffix. Otherwise, all the classes are displayed."
+ :type 'integer
+ :safe #'integerp
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defcustom cider-eldoc-display-for-symbol-at-point t
+ "When non-nil, display eldoc for symbol at point if available.
+So in (map inc ...) when the cursor is over inc its eldoc would be
+displayed. When nil, always display eldoc for first symbol of the sexp."
+ :type 'boolean
+ :safe 'booleanp
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defun cider--eldoc-format-class-names (class-names)
+ "Return a formatted CLASS-NAMES prefix string.
+CLASS-NAMES is a list of classes to which a Java interop form belongs.
+Only keep the first `cider-eldoc-max-class-names-to-display' names, and
+add a \"& x more\" suffix. Return nil if the CLASS-NAMES list is empty or
+mapping `cider-eldoc-ns-function' on it returns an empty list."
+ (when-let ((eldoc-class-names (seq-remove #'null (mapcar (apply-partially cider-eldoc-ns-function) class-names)))
+ (eldoc-class-names-length (length eldoc-class-names)))
+ (cond
+ ;; truncate class-names list and then format it
+ ((and cider-eldoc-max-class-names-to-display
+ (> eldoc-class-names-length cider-eldoc-max-class-names-to-display))
+ (format "(%s & %s more)"
+ (thread-first eldoc-class-names
+ (seq-take cider-eldoc-max-class-names-to-display)
+ (string-join " ")
+ (cider-propertize 'ns))
+ (- eldoc-class-names-length cider-eldoc-max-class-names-to-display)))
+
+ ;; format the whole list but add surrounding parentheses
+ ((> eldoc-class-names-length 1)
+ (format "(%s)"
+ (thread-first eldoc-class-names
+ (string-join " ")
+ (cider-propertize 'ns))))
+
+ ;; don't add the parentheses
+ (t (format "%s" (car eldoc-class-names))))))
+
+(defun cider-eldoc-format-thing (ns symbol thing type)
+ "Format the eldoc subject defined by NS, SYMBOL and THING.
+THING represents the thing at point which triggered eldoc. Normally NS and
+SYMBOL are used (they are derived from THING), but when empty we fallback to
+THING (e.g. for Java methods). Format it as a function, if FUNCTION-P
+is non-nil. Else format it as a variable."
+ (if-let ((method-name (if (and symbol (not (string= symbol "")))
+ symbol
+ thing))
+ (propertized-method-name (cider-propertize method-name type))
+ (ns-or-class (if (and ns (stringp ns))
+ (funcall cider-eldoc-ns-function ns)
+ (cider--eldoc-format-class-names ns))))
+ (format "%s/%s"
+ ;; we set font-lock properties of classes in `cider--eldoc-format-class-names'
+ ;; to avoid font locking the parentheses and "& x more"
+ ;; so we only propertize ns-or-class if not already done
+ (if (get-text-property 1 'face ns-or-class)
+ ;; it is already propertized
+ ns-or-class
+ (cider-propertize ns-or-class 'ns))
+ propertized-method-name)
+ ;; in case ns-or-class is nil
+ propertized-method-name))
+
+(defun cider-eldoc-format-sym-doc (var ns docstring)
+ "Return the formatted eldoc string for VAR and DOCSTRING.
+
+Consider the value of `eldoc-echo-area-use-multiline-p' while formatting.
+If the entire line cannot fit in the echo area, the var name may be
+truncated or eliminated entirely from the output to make room for the
+description.
+
+Try to truncate the var with various strategies, so that the var and
+the docstring can be displayed in the minibuffer without resizing the window.
+We start with `cider-abbreviate-ns' and `cider-last-ns-segment'.
+Next, if the var is in current namespace, we remove NS from the eldoc string.
+Otherwise, only the docstring is returned."
+ (let* ((ea-multi eldoc-echo-area-use-multiline-p)
+ ;; Subtract 1 from window width since emacs will not write
+ ;; any chars to the last column, or in later versions, will
+ ;; cause a wraparound and resize of the echo area.
+ (ea-width (1- (window-width (minibuffer-window))))
+ (strip (- (+ (length var) (length docstring)) ea-width))
+ (newline (string-match-p "\n" docstring))
+ ;; Truncated var can be ea-var long
+ ;; Subtract 2 to account for the : and / added when including
+ ;; the namespace prefixed form in eldoc string
+ (ea-var (- (- ea-width (length docstring)) 2)))
+ (cond
+ ((or (eq ea-multi t)
+ (and (<= strip 0) (null newline))
+ (and ea-multi (or (> (length docstring) ea-width) newline)))
+ (format "%s: %s" var docstring))
+
+ ;; Now we have to truncate either the docstring or the var
+ (newline (cider-eldoc-format-sym-doc var ns (substring docstring 0 newline)))
+
+ ;; Only return the truncated docstring
+ ((> (length docstring) ea-width)
+ (substring docstring 0 ea-width))
+
+ ;; Try to truncate the var with cider-abbreviate-ns
+ ((<= (length (cider-abbreviate-ns var)) ea-var)
+ (format "%s: %s" (cider-abbreviate-ns var) docstring))
+
+ ;; Try to truncate var with cider-last-ns-segment
+ ((<= (length (cider-last-ns-segment var)) ea-var)
+ (format "%s: %s" (cider-last-ns-segment var) docstring))
+
+ ;; If the var is in current namespace, we try to truncate the var by
+ ;; skipping the namespace from the returned eldoc string
+ ((and (string-equal ns (cider-current-ns))
+ (<= (- (length var) (length ns)) ea-var))
+ (format "%s: %s"
+ (replace-regexp-in-string (format "%s/" ns) "" var)
+ docstring))
+
+ ;; We couldn't fit the var and docstring in the available space,
+ ;; so we just display the docstring
+ (t docstring))))
+
+(defun cider-eldoc-format-variable (thing pos eldoc-info)
+ "Return the formatted eldoc string for a variable.
+THING is the variable name. POS will always be 0 here.
+ELDOC-INFO is a p-list containing the eldoc information."
+ (let* ((ns (lax-plist-get eldoc-info "ns"))
+ (symbol (lax-plist-get eldoc-info "symbol"))
+ (docstring (lax-plist-get eldoc-info "docstring"))
+ (formatted-var (cider-eldoc-format-thing ns symbol thing 'var)))
+ (when docstring
+ (cider-eldoc-format-sym-doc formatted-var ns docstring))))
+
+(defun cider-eldoc-format-function (thing pos eldoc-info)
+ "Return the formatted eldoc string for a function.
+THING is the function name. POS is the argument-index of the functions
+arglists. ELDOC-INFO is a p-list containing the eldoc information."
+ (let ((ns (lax-plist-get eldoc-info "ns"))
+ (symbol (lax-plist-get eldoc-info "symbol"))
+ (arglists (lax-plist-get eldoc-info "arglists")))
+ (format "%s: %s"
+ (cider-eldoc-format-thing ns symbol thing 'fn)
+ (cider-eldoc-format-arglist arglists pos))))
+
+(defun cider-highlight-args (arglist pos)
+ "Format the the function ARGLIST for eldoc.
+POS is the index of the currently highlighted argument."
+ (let* ((rest-pos (cider--find-rest-args-position arglist))
+ (i 0))
+ (mapconcat
+ (lambda (arg)
+ (let ((argstr (format "%s" arg)))
+ (if (string= arg "&")
+ argstr
+ (prog1
+ (if (or (= (1+ i) pos)
+ (and rest-pos
+ (> (1+ i) rest-pos)
+ (> pos rest-pos)))
+ (propertize argstr 'face
+ 'eldoc-highlight-function-argument)
+ argstr)
+ (setq i (1+ i)))))) arglist " ")))
+
+(defun cider--find-rest-args-position (arglist)
+ "Find the position of & in the ARGLIST vector."
+ (seq-position arglist "&"))
+
+(defun cider-highlight-arglist (arglist pos)
+ "Format the ARGLIST for eldoc.
+POS is the index of the argument to highlight."
+ (concat "[" (cider-highlight-args arglist pos) "]"))
+
+(defun cider-eldoc-format-arglist (arglist pos)
+ "Format all the ARGLIST for eldoc.
+POS is the index of current argument."
+ (concat "("
+ (mapconcat (lambda (args) (cider-highlight-arglist args pos))
+ arglist
+ " ")
+ ")"))
+
+(defun cider-eldoc-beginning-of-sexp ()
+ "Move to the beginning of current sexp.
+
+Return the number of nested sexp the point was over or after. Return nil
+if the maximum number of sexps to skip is exceeded."
+ (let ((parse-sexp-ignore-comments t)
+ (num-skipped-sexps 0))
+ (condition-case _
+ (progn
+ ;; First account for the case the point is directly over a
+ ;; beginning of a nested sexp.
+ (condition-case _
+ (let ((p (point)))
+ (forward-sexp -1)
+ (forward-sexp 1)
+ (when (< (point) p)
+ (setq num-skipped-sexps 1)))
+ (error))
+ (while
+ (let ((p (point)))
+ (forward-sexp -1)
+ (when (< (point) p)
+ (setq num-skipped-sexps
+ (unless (and cider-eldoc-max-num-sexps-to-skip
+ (>= num-skipped-sexps
+ cider-eldoc-max-num-sexps-to-skip))
+ ;; Without the above guard,
+ ;; `cider-eldoc-beginning-of-sexp' could traverse the
+ ;; whole buffer when the point is not within a
+ ;; list. This behavior is problematic especially with
+ ;; a buffer containing a large number of
+ ;; non-expressions like a REPL buffer.
+ (1+ num-skipped-sexps)))))))
+ (error))
+ num-skipped-sexps))
+
+(defun cider-eldoc-thing-type (eldoc-info)
+ "Return the type of the thing being displayed by eldoc.
+It can be a function or var now."
+ (pcase (lax-plist-get eldoc-info "type")
+ ("function" 'fn)
+ ("variable" 'var)))
+
+(defun cider-eldoc-info-at-point ()
+ "Return eldoc info at point.
+First go to the beginning of the sexp and check if the eldoc is to be
+considered (i.e sexp is a method call) and not a map or vector literal.
+Then go back to the point and return its eldoc."
+ (save-excursion
+ (unless (cider-in-comment-p)
+ (let* ((current-point (point)))
+ (cider-eldoc-beginning-of-sexp)
+ (unless (member (or (char-before (point)) 0) '(?\" ?\{ ?\[))
+ (goto-char current-point)
+ (when-let (eldoc-info (cider-eldoc-info
+ (cider--eldoc-remove-dot (cider-symbol-at-point))))
+ (list "eldoc-info" eldoc-info
+ "thing" (cider-symbol-at-point)
+ "pos" 0)))))))
+
+(defun cider-eldoc-info-at-sexp-beginning ()
+ "Return eldoc info for first symbol in the sexp."
+ (save-excursion
+ (when-let ((beginning-of-sexp (cider-eldoc-beginning-of-sexp))
+ ;; If we are at the beginning of function name, this will be -1
+ (argument-index (max 0 (1- beginning-of-sexp))))
+ (unless (or (memq (or (char-before (point)) 0)
+ '(?\" ?\{ ?\[))
+ (cider-in-comment-p))
+ (when-let (eldoc-info (cider-eldoc-info
+ (cider--eldoc-remove-dot (cider-symbol-at-point))))
+ (list "eldoc-info" eldoc-info
+ "thing" (cider-symbol-at-point)
+ "pos" argument-index))))))
+
+(defun cider-eldoc-info-in-current-sexp ()
+ "Return eldoc information from the sexp.
+If `cider-eldoc-display-for-symbol-at-poin' is non-nil and
+the symbol at point has a valid eldoc available, return that.
+Otherwise return the eldoc of the first symbol of the sexp."
+ (or (when cider-eldoc-display-for-symbol-at-point
+ (cider-eldoc-info-at-point))
+ (cider-eldoc-info-at-sexp-beginning)))
+
+(defun cider-eldoc--convert-ns-keywords (thing)
+ "Convert THING values that match ns macro keywords to function names."
+ (pcase thing
+ (":import" "clojure.core/import")
+ (":refer-clojure" "clojure.core/refer-clojure")
+ (":use" "clojure.core/use")
+ (":refer" "clojure.core/refer")
+ (_ thing)))
+
+(defun cider-eldoc-info (thing)
+ "Return the info for THING.
+This includes the arglist and ns and symbol name (if available)."
+ (let ((thing (cider-eldoc--convert-ns-keywords thing)))
+ (when (and (cider-nrepl-op-supported-p "eldoc")
+ thing
+ ;; ignore empty strings
+ (not (string= thing ""))
+ ;; ignore strings
+ (not (string-prefix-p "\"" thing))
+ ;; ignore regular expressions
+ (not (string-prefix-p "#" thing))
+ ;; ignore chars
+ (not (string-prefix-p "\\" thing))
+ ;; ignore numbers
+ (not (string-match-p "^[0-9]" thing)))
+ ;; check if we can used the cached eldoc info
+ (cond
+ ;; handle keywords for map access
+ ((string-prefix-p ":" thing) (list "symbol" thing
+ "type" "function"
+ "arglists" '(("map") ("map" "not-found"))))
+ ;; handle Classname. by displaying the eldoc for new
+ ((string-match-p "^[A-Z].+\\.$" thing) (list "symbol" thing
+ "type" "function"
+ "arglists" '(("args*"))))
+ ;; generic case
+ (t (if (equal thing (car cider-eldoc-last-symbol))
+ (cadr cider-eldoc-last-symbol)
+ (when-let ((eldoc-info (cider-sync-request:eldoc thing)))
+ (let* ((arglists (nrepl-dict-get eldoc-info "eldoc"))
+ (docstring (nrepl-dict-get eldoc-info "docstring"))
+ (type (nrepl-dict-get eldoc-info "type"))
+ (ns (nrepl-dict-get eldoc-info "ns"))
+ (class (nrepl-dict-get eldoc-info "class"))
+ (name (nrepl-dict-get eldoc-info "name"))
+ (member (nrepl-dict-get eldoc-info "member"))
+ (ns-or-class (if (and ns (not (string= ns "")))
+ ns
+ class))
+ (name-or-member (if (and name (not (string= name "")))
+ name
+ (format ".%s" member)))
+ (eldoc-plist (list "ns" ns-or-class
+ "symbol" name-or-member
+ "arglists" arglists
+ "docstring" docstring
+ "type" type)))
+ ;; middleware eldoc lookups are expensive, so we
+ ;; cache the last lookup. This eliminates the need
+ ;; for extra middleware requests within the same sexp.
+ (setq cider-eldoc-last-symbol (list thing eldoc-plist))
+ eldoc-plist))))))))
+
+(defun cider--eldoc-remove-dot (sym)
+ "Remove the preceding \".\" from a namespace qualified SYM and return sym.
+Only useful for interop forms. Clojure forms would be returned unchanged."
+ (when sym (replace-regexp-in-string "/\\." "/" sym)))
+
+(defun cider--eldoc-edn-file-p (file-name)
+ "Check whether FILE-NAME is representing an EDN file."
+ (and file-name (equal (file-name-extension file-name) "edn")))
+
+(defun cider-eldoc ()
+ "Backend function for eldoc to show argument list in the echo area."
+ (when (and (cider-connected-p)
+ ;; don't clobber an error message in the minibuffer
+ (not (member last-command '(next-error previous-error)))
+ ;; don't try to provide eldoc in EDN buffers
+ (not (cider--eldoc-edn-file-p buffer-file-name)))
+ (let* ((sexp-eldoc-info (cider-eldoc-info-in-current-sexp))
+ (eldoc-info (lax-plist-get sexp-eldoc-info "eldoc-info"))
+ (pos (lax-plist-get sexp-eldoc-info "pos"))
+ (thing (lax-plist-get sexp-eldoc-info "thing")))
+ (when eldoc-info
+ (if (equal (cider-eldoc-thing-type eldoc-info) 'fn)
+ (cider-eldoc-format-function thing pos eldoc-info)
+ (cider-eldoc-format-variable thing pos eldoc-info))))))
+
+(defun cider-eldoc-setup ()
+ "Setup eldoc in the current buffer.
+eldoc mode has to be enabled for this to have any effect."
+ (setq-local eldoc-documentation-function #'cider-eldoc)
+ (apply #'eldoc-add-command cider-extra-eldoc-commands))
+
+(provide 'cider-eldoc)
+
+;;; cider-eldoc.el ends here
--- /dev/null
+;;; cider-grimoire.el --- Grimoire integration -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2017 Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; A few commands for Grimoire documentation lookup.
+
+;;; Code:
+
+(require 'cider-client)
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-popup)
+
+(require 'nrepl-dict)
+
+(require 'url-vars)
+
+(defconst cider-grimoire-url "http://conj.io/")
+
+(defconst cider-grimoire-buffer "*cider-grimoire*")
+
+(defun cider-grimoire-replace-special (name)
+ "Convert the dashes in NAME to a grimoire friendly format."
+ (thread-last name
+ (replace-regexp-in-string "\\?" "_QMARK_")
+ (replace-regexp-in-string "\\." "_DOT_")
+ (replace-regexp-in-string "\\/" "_SLASH_")
+ (replace-regexp-in-string "\\(\\`_\\)\\|\\(_\\'\\)" "")))
+
+(defun cider-grimoire-url (name ns)
+ "Generate a grimoire search v0 url from NAME, NS."
+ (let ((base-url cider-grimoire-url))
+ (when (and name ns)
+ (concat base-url "search/v0/" ns "/" (cider-grimoire-replace-special name) "/"))))
+
+(defun cider-grimoire-web-lookup (symbol)
+ "Open the grimoire documentation for SYMBOL in a web browser."
+ (if-let ((var-info (cider-var-info symbol)))
+ (let ((name (nrepl-dict-get var-info "name"))
+ (ns (nrepl-dict-get var-info "ns")))
+ (browse-url (cider-grimoire-url name ns)))
+ (error "Symbol %s not resolved" symbol)))
+
+;;;###autoload
+(defun cider-grimoire-web (&optional arg)
+ "Open grimoire documentation in the default web browser.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates."
+ (interactive "P")
+ (funcall (cider-prompt-for-symbol-function arg)
+ "Grimoire doc for"
+ #'cider-grimoire-web-lookup))
+
+(defun cider-create-grimoire-buffer (content)
+ "Create a new grimoire buffer with CONTENT."
+ (with-current-buffer (cider-popup-buffer cider-grimoire-buffer t)
+ (read-only-mode -1)
+ (insert content)
+ (read-only-mode +1)
+ (goto-char (point-min))
+ (current-buffer)))
+
+(defun cider-grimoire-lookup (symbol)
+ "Look up the grimoire documentation for SYMBOL."
+ (if-let ((var-info (cider-var-info symbol)))
+ (let ((name (nrepl-dict-get var-info "name"))
+ (ns (nrepl-dict-get var-info "ns"))
+ (url-request-method "GET")
+ (url-request-extra-headers `(("Content-Type" . "text/plain"))))
+ (url-retrieve (cider-grimoire-url name ns)
+ (lambda (_status)
+ ;; we need to strip the http header
+ (goto-char (point-min))
+ (re-search-forward "^$")
+ (delete-region (point-min) (point))
+ (delete-blank-lines)
+ ;; and create a new buffer with whatever is left
+ (pop-to-buffer (cider-create-grimoire-buffer (buffer-string))))))
+ (error "Symbol %s not resolved" symbol)))
+
+;;;###autoload
+(defun cider-grimoire (&optional arg)
+ "Open grimoire documentation in a popup buffer.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates."
+ (interactive "P")
+ (when (derived-mode-p 'clojurescript-mode)
+ (user-error "`cider-grimoire' doesn't support ClojureScript"))
+ (funcall (cider-prompt-for-symbol-function arg)
+ "Grimoire doc for"
+ #'cider-grimoire-lookup))
+
+(provide 'cider-grimoire)
+
+;;; cider-grimoire.el ends here
--- /dev/null
+;;; cider-inspector.el --- Object inspector -*- lexical-binding: t -*-
+
+;; Copyright © 2013-2017 Vital Reactor, LLC
+;; Copyright © 2014-2017 Bozhidar Batsov and CIDER contributors
+
+;; Author: Ian Eslick <ianNOSPAMvitalreactor.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Clojure object inspector inspired by SLIME.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'seq)
+(require 'cider-interaction)
+
+;; ===================================
+;; Inspector Key Map and Derived Mode
+;; ===================================
+
+(defconst cider-inspector-buffer "*cider-inspect*")
+
+(push cider-inspector-buffer cider-ancillary-buffers)
+
+;;; Customization
+(defgroup cider-inspector nil
+ "Presentation and behaviour of the cider value inspector."
+ :prefix "cider-inspector-"
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-inspector-page-size 32
+ "Default page size in paginated inspector view.
+The page size can be also changed interactively within the inspector."
+ :type '(integer :tag "Page size" 32)
+ :group 'cider-inspector
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-inspector-fill-frame nil
+ "Controls whether the cider inspector window fills its frame."
+ :type 'boolean
+ :group 'cider-inspector
+ :package-version '(cider . "0.15.0"))
+
+(defvar cider-inspector-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map cider-popup-buffer-mode-map)
+ (define-key map (kbd "RET") #'cider-inspector-operate-on-point)
+ (define-key map [mouse-1] #'cider-inspector-operate-on-click)
+ (define-key map "l" #'cider-inspector-pop)
+ (define-key map "g" #'cider-inspector-refresh)
+ ;; Page-up/down
+ (define-key map [next] #'cider-inspector-next-page)
+ (define-key map [prior] #'cider-inspector-prev-page)
+ (define-key map " " #'cider-inspector-next-page)
+ (define-key map (kbd "M-SPC") #'cider-inspector-prev-page)
+ (define-key map (kbd "S-SPC") #'cider-inspector-prev-page)
+ (define-key map "s" #'cider-inspector-set-page-size)
+ (define-key map [tab] #'cider-inspector-next-inspectable-object)
+ (define-key map "\C-i" #'cider-inspector-next-inspectable-object)
+ (define-key map [(shift tab)] #'cider-inspector-previous-inspectable-object)
+ ;; Emacs translates S-TAB to BACKTAB on X.
+ (define-key map [backtab] #'cider-inspector-previous-inspectable-object)
+ map))
+
+(define-derived-mode cider-inspector-mode special-mode "Inspector"
+ "Major mode for inspecting Clojure data structures.
+
+\\{cider-inspector-mode-map}"
+ (set-syntax-table clojure-mode-syntax-table)
+ (setq buffer-read-only t)
+ (setq-local electric-indent-chars nil)
+ (when cider-special-mode-truncate-lines
+ (setq-local truncate-lines t)))
+
+;;;###autoload
+(defun cider-inspect-last-sexp ()
+ "Inspect the result of the the expression preceding point."
+ (interactive)
+ (cider-inspect-expr (cider-last-sexp) (cider-current-ns)))
+
+;;;###autoload
+(defun cider-inspect-defun-at-point ()
+ "Inspect the result of the \"top-level\" expression at point."
+ (interactive)
+ (cider-inspect-expr (cider-defun-at-point) (cider-current-ns)))
+
+;;;###autoload
+(defun cider-inspect-last-result ()
+ "Inspect the most recent eval result."
+ (interactive)
+ (cider-inspect-expr "*1" (cider-current-ns)))
+
+;;;###autoload
+(defun cider-inspect (&optional arg)
+ "Inspect the result of the preceding sexp.
+
+With a prefix argument ARG it inspects the result of the \"top-level\" form.
+With a second prefix argument it prompts for an expression to eval and inspect."
+ (interactive "p")
+ (pcase arg
+ (1 (cider-inspect-last-sexp))
+ (4 (cider-inspect-defun-at-point))
+ (16 (call-interactively #'cider-inspect-expr))))
+
+(defvar cider-inspector-location-stack nil
+ "A stack used to save point locations in inspector buffers.
+These locations are used to emulate save-excursion between
+`cider-inspector-push' and `cider-inspector-pop' operations.")
+
+(defvar cider-inspector-page-location-stack nil
+ "A stack used to save point locations in inspector buffers.
+These locations are used to emulate save-excursion between
+`cider-inspector-next-page' and `cider-inspector-prev-page' operations.")
+
+(defvar cider-inspector-last-command nil
+ "Contains the value of the most recently used `cider-inspector-*' command.
+This is used as an alternative to the built-in `last-command'. Whenever we
+invoke any command through M-x and its variants, the value of `last-command'
+is not set to the command it invokes.")
+
+;; Operations
+;;;###autoload
+(defun cider-inspect-expr (expr ns)
+ "Evaluate EXPR in NS and inspect its value.
+Interactively, EXPR is read from the minibuffer, and NS the
+current buffer's namespace."
+ (interactive (list (cider-read-from-minibuffer "Inspect expression: " (cider-sexp-at-point))
+ (cider-current-ns)))
+ (when-let (value (cider-sync-request:inspect-expr expr ns (or cider-inspector-page-size 32)))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-pop ()
+ (interactive)
+ (setq cider-inspector-last-command 'cider-inspector-pop)
+ (when-let (value (cider-sync-request:inspect-pop))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-push (idx)
+ (push (point) cider-inspector-location-stack)
+ (when-let (value (cider-sync-request:inspect-push idx))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-refresh ()
+ (interactive)
+ (when-let (value (cider-sync-request:inspect-refresh))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-next-page ()
+ "Jump to the next page when inspecting a paginated sequence/map.
+
+Does nothing if already on the last page."
+ (interactive)
+ (push (point) cider-inspector-page-location-stack)
+ (when-let (value (cider-sync-request:inspect-next-page))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-prev-page ()
+ "Jump to the previous page when expecting a paginated sequence/map.
+
+Does nothing if already on the first page."
+ (interactive)
+ (setq cider-inspector-last-command 'cider-inspector-prev-page)
+ (when-let (value (cider-sync-request:inspect-prev-page))
+ (cider-inspector--render-value value)))
+
+(defun cider-inspector-set-page-size (page-size)
+ "Set the page size in pagination mode to the specified PAGE-SIZE.
+
+Current page will be reset to zero."
+ (interactive "nPage size: ")
+ (when-let (value (cider-sync-request:inspect-set-page-size page-size))
+ (cider-inspector--render-value value)))
+
+;; nREPL interactions
+(defun cider-sync-request:inspect-pop ()
+ "Move one level up in the inspector stack."
+ (thread-first (list "op" "inspect-pop")
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-push (idx)
+ "Inspect the inside value specified by IDX."
+ (thread-first (list "op" "inspect-push"
+ "idx" idx)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-refresh ()
+ "Re-render the currently inspected value."
+ (thread-first (list "op" "inspect-refresh")
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-next-page ()
+ "Jump to the next page in paginated collection view."
+ (thread-first (list "op" "inspect-next-page")
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-prev-page ()
+ "Jump to the previous page in paginated collection view."
+ (thread-first (list "op" "inspect-prev-page")
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-set-page-size (page-size)
+ "Set the page size in paginated view to PAGE-SIZE."
+ (thread-first (list "op" "inspect-set-page-size"
+ "page-size" page-size)
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "value")))
+
+(defun cider-sync-request:inspect-expr (expr ns page-size)
+ "Evaluate EXPR in context of NS and inspect its result.
+Set the page size in paginated view to PAGE-SIZE."
+ (thread-first (append (nrepl--eval-request expr ns)
+ (list "inspect" "true"
+ "page-size" page-size))
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "value")))
+
+;; Render Inspector from Structured Values
+(defun cider-inspector--render-value (value)
+ (cider-make-popup-buffer cider-inspector-buffer 'cider-inspector-mode)
+ (cider-inspector-render cider-inspector-buffer value)
+ (cider-popup-buffer-display cider-inspector-buffer t)
+ (when cider-inspector-fill-frame (delete-other-windows))
+ (with-current-buffer cider-inspector-buffer
+ (when (eq cider-inspector-last-command 'cider-inspector-pop)
+ (setq cider-inspector-last-command nil)
+ ;; Prevents error message being displayed when we try to pop
+ ;; from the top-level of a data struture
+ (when cider-inspector-location-stack
+ (goto-char (pop cider-inspector-location-stack))))
+
+ (when (eq cider-inspector-last-command 'cider-inspector-prev-page)
+ (setq cider-inspector-last-command nil)
+ ;; Prevents error message being displayed when we try to
+ ;; go to a prev-page from the first page
+ (when cider-inspector-page-location-stack
+ (goto-char (pop cider-inspector-page-location-stack))))))
+
+(defun cider-inspector-render (buffer str)
+ (with-current-buffer buffer
+ (cider-inspector-mode)
+ (let ((inhibit-read-only t))
+ (condition-case nil
+ (cider-inspector-render* (car (read-from-string str)))
+ (error (insert "\nInspector error for: " str))))
+ (goto-char (point-min))))
+
+(defun cider-inspector-render* (elements)
+ (dolist (el elements)
+ (cider-inspector-render-el* el)))
+
+(defun cider-inspector-render-el* (el)
+ (cond ((symbolp el) (insert (symbol-name el)))
+ ((stringp el) (insert (propertize el 'font-lock-face 'font-lock-keyword-face)))
+ ((and (consp el) (eq (car el) :newline))
+ (insert "\n"))
+ ((and (consp el) (eq (car el) :value))
+ (cider-inspector-render-value (cadr el) (cl-caddr el)))
+ (t (message "Unrecognized inspector object: %s" el))))
+
+(defun cider-inspector-render-value (value idx)
+ (cider-propertize-region
+ (list 'cider-value-idx idx
+ 'mouse-face 'highlight)
+ (cider-inspector-render-el* (cider-font-lock-as-clojure value))))
+
+
+;; ===================================================
+;; Inspector Navigation (lifted from SLIME inspector)
+;; ===================================================
+
+(defun cider-find-inspectable-object (direction limit)
+ "Find the next/previous inspectable object.
+DIRECTION can be either 'next or 'prev.
+LIMIT is the maximum or minimum position in the current buffer.
+
+Return a list of two values: If an object could be found, the
+starting position of the found object and T is returned;
+otherwise LIMIT and NIL is returned."
+ (let ((finder (cl-ecase direction
+ (next 'next-single-property-change)
+ (prev 'previous-single-property-change))))
+ (let ((prop nil) (curpos (point)))
+ (while (and (not prop) (not (= curpos limit)))
+ (let ((newpos (funcall finder curpos 'cider-value-idx nil limit)))
+ (setq prop (get-text-property newpos 'cider-value-idx))
+ (setq curpos newpos)))
+ (list curpos (and prop t)))))
+
+(defun cider-inspector-next-inspectable-object (arg)
+ "Move point to the next inspectable object.
+With optional ARG, move across that many objects.
+If ARG is negative, move backwards."
+ (interactive "p")
+ (let ((maxpos (point-max)) (minpos (point-min))
+ (previously-wrapped-p nil))
+ ;; Forward.
+ (while (> arg 0)
+ (seq-let (pos foundp) (cider-find-inspectable-object 'next maxpos)
+ (if foundp
+ (progn (goto-char pos) (setq arg (1- arg))
+ (setq previously-wrapped-p nil))
+ (if (not previously-wrapped-p) ; cycle detection
+ (progn (goto-char minpos) (setq previously-wrapped-p t))
+ (error "No inspectable objects")))))
+ ;; Backward.
+ (while (< arg 0)
+ (seq-let (pos foundp) (cider-find-inspectable-object 'prev minpos)
+ ;; CIDER-OPEN-INSPECTOR inserts the title of an inspector page
+ ;; as a presentation at the beginning of the buffer; skip
+ ;; that. (Notice how this problem can not arise in ``Forward.'')
+ (if (and foundp (/= pos minpos))
+ (progn (goto-char pos) (setq arg (1+ arg))
+ (setq previously-wrapped-p nil))
+ (if (not previously-wrapped-p) ; cycle detection
+ (progn (goto-char maxpos) (setq previously-wrapped-p t))
+ (error "No inspectable objects")))))))
+
+(defun cider-inspector-previous-inspectable-object (arg)
+ "Move point to the previous inspectable object.
+With optional ARG, move across that many objects.
+If ARG is negative, move forwards."
+ (interactive "p")
+ (cider-inspector-next-inspectable-object (- arg)))
+
+(defun cider-inspector-property-at-point ()
+ (let* ((properties '(cider-value-idx cider-range-button
+ cider-action-number))
+ (find-property
+ (lambda (point)
+ (cl-loop for property in properties
+ for value = (get-text-property point property)
+ when value
+ return (list property value)))))
+ (or (funcall find-property (point))
+ (funcall find-property (1- (point))))))
+
+(defun cider-inspector-operate-on-point ()
+ "Invoke the command for the text at point.
+1. If point is on a value then recursively call the inspector on
+that value.
+2. If point is on an action then call that action.
+3. If point is on a range-button fetch and insert the range."
+ (interactive)
+ (seq-let (property value) (cider-inspector-property-at-point)
+ (cl-case property
+ (cider-value-idx
+ (cider-inspector-push value))
+ ;; TODO: range and action handlers
+ (t (error "No object at point")))))
+
+(defun cider-inspector-operate-on-click (event)
+ "Move to EVENT's position and operate the part."
+ (interactive "@e")
+ (let ((point (posn-point (event-end event))))
+ (cond ((and point
+ (or (get-text-property point 'cider-value-idx)))
+ (goto-char point)
+ (cider-inspector-operate-on-point))
+ (t
+ (error "No clickable part here")))))
+
+;;;###autoload
+(define-obsolete-function-alias 'cider-inspect-read-and-inspect
+ 'cider-inspect-expr "0.13.0")
+
+(provide 'cider-inspector)
+
+;;; cider-inspector.el ends here
--- /dev/null
+;;; cider-interaction.el --- IDE for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Provides an Emacs Lisp client to connect to Clojure nREPL servers.
+
+;;; Code:
+
+(require 'cider-client)
+(require 'cider-repl)
+(require 'cider-popup)
+(require 'cider-common)
+(require 'cider-util)
+(require 'cider-stacktrace)
+(require 'cider-test)
+(require 'cider-doc)
+(require 'cider-eldoc)
+(require 'cider-overlays)
+(require 'subr-x)
+(require 'cider-compat)
+
+(require 'clojure-mode)
+(require 'thingatpt)
+(require 'arc-mode)
+(require 'ansi-color)
+(require 'cl-lib)
+(require 'compile)
+(require 'etags) ; for find-tags-marker-ring
+(require 'tramp)
+
+(defconst cider-read-eval-buffer "*cider-read-eval*")
+(defconst cider-result-buffer "*cider-result*")
+(defconst cider-nrepl-session-buffer "*cider-nrepl-session*")
+(add-to-list 'cider-ancillary-buffers cider-nrepl-session-buffer)
+
+(defcustom cider-show-error-buffer t
+ "Control the popup behavior of cider stacktraces.
+The following values are possible t or 'always, 'except-in-repl,
+'only-in-repl. Any other value, including nil, will cause the stacktrace
+not to be automatically shown.
+
+Irespective of the value of this variable, the `cider-error-buffer' is
+always generated in the background. Use `cider-visit-error-buffer' to
+navigate to this buffer."
+ :type '(choice (const :tag "always" t)
+ (const except-in-repl)
+ (const only-in-repl)
+ (const :tag "never" nil))
+ :group 'cider)
+
+(defcustom cider-auto-jump-to-error t
+ "Control the cursor jump behaviour in compilation error buffer.
+
+When non-nil automatically jump to error location during interactive
+compilation. When set to 'errors-only, don't jump to warnings.
+When set to nil, don't jump at all."
+ :type '(choice (const :tag "always" t)
+ (const errors-only)
+ (const :tag "never" nil))
+ :group 'cider
+ :package-version '(cider . "0.7.0"))
+
+(defcustom cider-auto-select-error-buffer t
+ "Controls whether to auto-select the error popup buffer."
+ :type 'boolean
+ :group 'cider)
+
+(defcustom cider-prompt-save-file-on-load t
+ "Controls whether to prompt to save the file when loading a buffer.
+If nil, files are not saved.
+If t, the user is prompted to save the file if it's been modified.
+If the symbol `always-save', save the file without confirmation."
+ :type '(choice (const t :tag "Prompt to save the file if it's been modified")
+ (const nil :tag "Don't save the file")
+ (const always-save :tag "Save the file without confirmation"))
+ :group 'cider
+ :package-version '(cider . "0.6.0"))
+
+(defcustom cider-completion-use-context t
+ "When true, uses context at point to improve completion suggestions."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.7.0"))
+
+(defcustom cider-annotate-completion-candidates t
+ "When true, annotate completion candidates with some extra information."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.8.0"))
+
+(defcustom cider-annotate-completion-function
+ #'cider-default-annotate-completion-function
+ "Controls how the annotations for completion candidates are formatted.
+
+Must be a function that takes two arguments: the abbreviation of the
+candidate type according to `cider-completion-annotations-alist' and the
+candidate's namespace."
+ :type 'function
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-completion-annotations-alist
+ '(("class" "c")
+ ("field" "fi")
+ ("function" "f")
+ ("import" "i")
+ ("keyword" "k")
+ ("local" "l")
+ ("macro" "m")
+ ("method" "me")
+ ("namespace" "n")
+ ("protocol" "p")
+ ("protocol-function" "pf")
+ ("record" "r")
+ ("special-form" "s")
+ ("static-field" "sf")
+ ("static-method" "sm")
+ ("type" "t")
+ ("var" "v"))
+ "Controls the abbreviations used when annotating completion candidates.
+
+Must be a list of elements with the form (TYPE . ABBREVIATION), where TYPE
+is a possible value of the candidate's type returned from the completion
+backend, and ABBREVIATION is a short form of that type."
+ :type '(alist :key-type string :value-type string)
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-completion-annotations-include-ns 'unqualified
+ "Controls passing of namespaces to `cider-annotate-completion-function'.
+
+When set to 'always, the candidate's namespace will always be passed if it
+is available. When set to 'unqualified, the namespace will only be passed
+if the candidate is not namespace-qualified."
+ :type '(choice (const always)
+ (const unqualified)
+ (const :tag "never" nil))
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defconst cider-refresh-log-buffer "*cider-refresh-log*")
+
+(defcustom cider-refresh-show-log-buffer nil
+ "Controls when to display the refresh log buffer.
+
+If non-nil, the log buffer will be displayed every time `cider-refresh' is
+called.
+
+If nil, the log buffer will still be written to, but will never be
+displayed automatically. Instead, the most relevant information will be
+displayed in the echo area."
+ :type '(choice (const :tag "always" t)
+ (const :tag "never" nil))
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-refresh-before-fn nil
+ "Clojure function for `cider-refresh' to call before reloading.
+
+If nil, nothing will be invoked before reloading. Must be a
+namespace-qualified function of zero arity. Any thrown exception will
+prevent reloading from occurring."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-refresh-after-fn nil
+ "Clojure function for `cider-refresh' to call after reloading.
+
+If nil, nothing will be invoked after reloading. Must be a
+namespace-qualified function of zero arity."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defconst cider-output-buffer "*cider-out*")
+
+(defcustom cider-interactive-eval-output-destination 'repl-buffer
+ "The destination for stdout and stderr produced from interactive evaluation."
+ :type '(choice (const output-buffer)
+ (const repl-buffer))
+ :group 'cider
+ :package-version '(cider . "0.7.0"))
+
+(defface cider-error-highlight-face
+ '((((supports :underline (:style wave)))
+ (:underline (:style wave :color "red") :inherit unspecified))
+ (t (:inherit font-lock-warning-face :underline t)))
+ "Face used to highlight compilation errors in Clojure buffers."
+ :group 'cider)
+
+(defface cider-warning-highlight-face
+ '((((supports :underline (:style wave)))
+ (:underline (:style wave :color "yellow") :inherit unspecified))
+ (t (:inherit font-lock-warning-face :underline (:color "yellow"))))
+ "Face used to highlight compilation warnings in Clojure buffers."
+ :group 'cider)
+
+(defconst cider-clojure-artifact-id "org.clojure/clojure"
+ "Artifact identifier for Clojure.")
+
+(defconst cider-minimum-clojure-version "1.7.0"
+ "Minimum supported version of Clojure.")
+
+(defconst cider-latest-clojure-version "1.8.0"
+ "Latest supported version of Clojure.")
+
+(defconst cider-required-nrepl-version "0.2.12"
+ "The minimum nREPL version that's known to work properly with CIDER.")
+
+;;; Minibuffer
+(defvar cider-minibuffer-history '()
+ "History list of expressions read from the minibuffer.")
+
+(defvar cider-minibuffer-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map (kbd "TAB") #'complete-symbol)
+ (define-key map (kbd "M-TAB") #'complete-symbol)
+ map)
+ "Minibuffer keymap used for reading Clojure expressions.")
+
+(defvar-local cider-connection-created-with 'jack-in
+ "Save how the connection was created.
+Its value can be either 'jack-in or 'connect.")
+
+(defun cider-read-from-minibuffer (prompt &optional value)
+ "Read a string from the minibuffer, prompting with PROMPT.
+If VALUE is non-nil, it is inserted into the minibuffer as initial-input.
+
+PROMPT need not end with \": \". If it doesn't, VALUE is displayed on the
+prompt as a default value (used if the user doesn't type anything) and is
+not used as initial input (input is left empty)."
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (set-syntax-table clojure-mode-syntax-table)
+ (add-hook 'completion-at-point-functions
+ #'cider-complete-at-point nil t)
+ (setq-local eldoc-documentation-function #'cider-eldoc)
+ (run-hooks 'eval-expression-minibuffer-setup-hook))
+ (let* ((has-colon (string-match ": \\'" prompt))
+ (input (read-from-minibuffer (cond
+ (has-colon prompt)
+ (value (format "%s (default %s): " prompt value))
+ (t (format "%s: " prompt)))
+ (when has-colon value) ; initial-input
+ cider-minibuffer-map nil
+ 'cider-minibuffer-history
+ (unless has-colon value)))) ; default-value
+ (if (and (equal input "") value (not has-colon))
+ value
+ input))))
+
+\f
+;;; Utilities
+
+(defun cider--clear-compilation-highlights ()
+ "Remove compilation highlights."
+ (remove-overlays (point-min) (point-max) 'cider-note-p t))
+
+(defun cider-clear-compilation-highlights (&optional arg)
+ "Remove compilation highlights.
+
+When invoked with a prefix ARG the command doesn't prompt for confirmation."
+ (interactive "P")
+ (when (or arg (y-or-n-p "Are you sure you want to clear the compilation highlights? "))
+ (cider--clear-compilation-highlights)))
+
+(defun cider--quit-error-window ()
+ "Buries the `cider-error-buffer' and quits its containing window."
+ (when-let ((error-win (get-buffer-window cider-error-buffer)))
+ (quit-window nil error-win)))
+
+;;;
+(declare-function cider-mode "cider-mode")
+
+(defun cider-jump-to (buffer &optional pos other-window)
+ "Push current point onto marker ring, and jump to BUFFER and POS.
+POS can be either a number, a cons, or a symbol.
+If a number, it is the character position (the point).
+If a cons, it specifies the position as (LINE . COLUMN). COLUMN can be nil.
+If a symbol, `cider-jump-to' searches for something that looks like the
+symbol's definition in the file.
+If OTHER-WINDOW is non-nil don't reuse current window."
+ (with-no-warnings
+ (ring-insert find-tag-marker-ring (point-marker)))
+ (if other-window
+ (pop-to-buffer buffer)
+ ;; like switch-to-buffer, but reuse existing window if BUFFER is visible
+ (pop-to-buffer buffer '((display-buffer-reuse-window display-buffer-same-window))))
+ (with-current-buffer buffer
+ (widen)
+ (goto-char (point-min))
+ (cider-mode +1)
+ (cond
+ ;; Line-column specification.
+ ((consp pos)
+ (forward-line (1- (or (car pos) 1)))
+ (if (cdr pos)
+ (move-to-column (cdr pos))
+ (back-to-indentation)))
+ ;; Point specification.
+ ((numberp pos)
+ (goto-char pos))
+ ;; Symbol or string.
+ (pos
+ ;; Try to find (def full-name ...).
+ (if (or (save-excursion
+ (search-forward-regexp (format "(def.*\\s-\\(%s\\)" (regexp-quote pos))
+ nil 'noerror))
+ (let ((name (replace-regexp-in-string ".*/" "" pos)))
+ ;; Try to find (def name ...).
+ (or (save-excursion
+ (search-forward-regexp (format "(def.*\\s-\\(%s\\)" (regexp-quote name))
+ nil 'noerror))
+ ;; Last resort, just find the first occurrence of `name'.
+ (save-excursion
+ (search-forward name nil 'noerror)))))
+ (goto-char (match-beginning 0))
+ (message "Can't find %s in %s" pos (buffer-file-name))))
+ (t nil))))
+
+(defun cider-find-dwim-other-window (symbol-file)
+ "Jump to SYMBOL-FILE at point, place results in other window."
+ (interactive (cider--find-dwim-interactive "Jump to: "))
+ (cider--find-dwim symbol-file 'cider-find-dwim-other-window t))
+
+(defun cider-find-dwim (symbol-file)
+ "Find and display the SYMBOL-FILE at point.
+
+SYMBOL-FILE could be a var or a resource. If thing at point is empty
+then show dired on project. If var is not found, try to jump to resource
+of the same name. When called interactively, a prompt is given according
+to the variable `cider-prompt-for-symbol'. A single or double prefix argument
+inverts the meaning. A prefix of `-' or a double prefix argument causes the
+results to be displayed in a different window.
+A default value of thing at point is given when prompted."
+ (interactive (cider--find-dwim-interactive "Jump to: "))
+ (cider--find-dwim symbol-file `cider-find-dwim
+ (cider--open-other-window-p current-prefix-arg)))
+
+(defun cider--find-dwim (symbol-file callback &optional other-window)
+ "Find the SYMBOL-FILE at point.
+
+CALLBACK upon failure to invoke prompt if not prompted previously.
+Show results in a different window if OTHER-WINDOW is true."
+ (if-let ((info (cider-var-info symbol-file)))
+ (cider--jump-to-loc-from-info info other-window)
+ (progn
+ (cider-ensure-op-supported "resource")
+ (if-let ((resource (cider-sync-request:resource symbol-file))
+ (buffer (cider-find-file resource)))
+ (cider-jump-to buffer 0 other-window)
+ (if (cider--prompt-for-symbol-p current-prefix-arg)
+ (error "Resource or var %s not resolved" symbol-file)
+ (let ((current-prefix-arg (if current-prefix-arg nil '(4))))
+ (call-interactively callback)))))))
+
+(defun cider--find-dwim-interactive (prompt)
+ "Get interactive arguments for jump-to functions using PROMPT as needed."
+ (if (cider--prompt-for-symbol-p current-prefix-arg)
+ (list
+ (cider-read-from-minibuffer prompt (thing-at-point 'filename)))
+ (list (or (thing-at-point 'filename) "")))) ; No prompt.
+
+(defun cider-find-resource (path)
+ "Find the resource at PATH.
+
+Prompt for input as indicated by the variable `cider-prompt-for-symbol'.
+A single or double prefix argument inverts the meaning of
+`cider-prompt-for-symbol'. A prefix argument of `-` or a double prefix
+argument causes the results to be displayed in other window. The default
+value is thing at point."
+ (interactive
+ (list
+ (if (cider--prompt-for-symbol-p current-prefix-arg)
+ (completing-read "Resource: "
+ (cider-sync-request:resources-list)
+ nil nil
+ (thing-at-point 'filename))
+ (or (thing-at-point 'filename) ""))))
+ (cider-ensure-op-supported "resource")
+ (when (= (length path) 0)
+ (error "Cannot find resource for empty path"))
+ (if-let ((resource (cider-sync-request:resource path))
+ (buffer (cider-find-file resource)))
+ (cider-jump-to buffer nil (cider--open-other-window-p current-prefix-arg))
+ (if (cider--prompt-for-symbol-p current-prefix-arg)
+ (error "Cannot find resource %s" path)
+ (let ((current-prefix-arg (cider--invert-prefix-arg current-prefix-arg)))
+ (call-interactively `cider-find-resource)))))
+
+(defun cider--invert-prefix-arg (arg)
+ "Invert the effect of prefix value ARG on `cider-prompt-for-symbol'.
+
+This function preserves the `other-window' meaning of ARG."
+ (let ((narg (prefix-numeric-value arg)))
+ (pcase narg
+ (16 -1) ; empty empty -> -
+ (-1 16) ; - -> empty empty
+ (4 nil) ; empty -> no-prefix
+ (_ 4)))) ; no-prefix -> empty
+
+(defun cider--prefix-invert-prompt-p (arg)
+ "Test prefix value ARG for its effect on `cider-prompt-for-symbol`."
+ (let ((narg (prefix-numeric-value arg)))
+ (pcase narg
+ (16 t) ; empty empty
+ (4 t) ; empty
+ (_ nil))))
+
+(defun cider--prompt-for-symbol-p (&optional prefix)
+ "Check if cider should prompt for symbol.
+
+Tests againsts PREFIX and the value of `cider-prompt-for-symbol'.
+Invert meaning of `cider-prompt-for-symbol' if PREFIX indicates it should be."
+ (if (cider--prefix-invert-prompt-p prefix)
+ (not cider-prompt-for-symbol) cider-prompt-for-symbol))
+
+(defun cider-sync-request:ns-path (ns)
+ "Get the path to the file containing NS."
+ (thread-first (list "op" "ns-path"
+ "ns" ns)
+ cider-nrepl-send-sync-request
+ (nrepl-dict-get "path")))
+
+(defun cider--find-ns (ns &optional other-window)
+ "Find the file containing NS's definition.
+Optionally open it in a different window if OTHER-WINDOW is truthy."
+ (if-let ((path (cider-sync-request:ns-path ns)))
+ (cider-jump-to (cider-find-file path) nil other-window)
+ (user-error "Can't find %s" ns)))
+
+(defun cider-find-ns (&optional arg ns)
+ "Find the file containing NS.
+
+A prefix ARG of `-` or a double prefix argument causes
+the results to be displayed in a different window."
+ (interactive "P")
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "ns-path")
+ (if ns
+ (cider--find-ns ns)
+ (let* ((namespaces (cider-sync-request:ns-list))
+ (ns (completing-read "Find namespace: " namespaces)))
+ (cider--find-ns ns (cider--open-other-window-p arg)))))
+
+(defvar cider-completion-last-context nil)
+
+(defun cider-completion-symbol-start-pos ()
+ "Find the starting position of the symbol at point, unless inside a string."
+ (let ((sap (symbol-at-point)))
+ (when (and sap (not (nth 3 (syntax-ppss))))
+ (car (bounds-of-thing-at-point 'symbol)))))
+
+(defun cider-completion-get-context-at-point ()
+ "Extract the context at point.
+If point is not inside the list, returns nil; otherwise return \"top-level\"
+form, with symbol at point replaced by __prefix__."
+ (when (save-excursion
+ (condition-case _
+ (progn
+ (up-list)
+ (check-parens)
+ t)
+ (scan-error nil)
+ (user-error nil)))
+ (save-excursion
+ (let* ((pref-end (point))
+ (pref-start (cider-completion-symbol-start-pos))
+ (context (cider-defun-at-point))
+ (_ (beginning-of-defun))
+ (expr-start (point)))
+ (concat (when pref-start (substring context 0 (- pref-start expr-start)))
+ "__prefix__"
+ (substring context (- pref-end expr-start)))))))
+
+(defun cider-completion-get-context ()
+ "Extract context depending on `cider-completion-use-context' and major mode."
+ (let ((context (if (and cider-completion-use-context
+ ;; Important because `beginning-of-defun' and
+ ;; `ending-of-defun' work incorrectly in the REPL
+ ;; buffer, so context extraction fails there.
+ (derived-mode-p 'clojure-mode))
+ (or (cider-completion-get-context-at-point)
+ "nil")
+ "nil")))
+ (if (string= cider-completion-last-context context)
+ ":same"
+ (setq cider-completion-last-context context)
+ context)))
+
+(defun cider-completion--parse-candidate-map (candidate-map)
+ (let ((candidate (nrepl-dict-get candidate-map "candidate"))
+ (type (nrepl-dict-get candidate-map "type"))
+ (ns (nrepl-dict-get candidate-map "ns")))
+ (put-text-property 0 1 'type type candidate)
+ (put-text-property 0 1 'ns ns candidate)
+ candidate))
+
+(defun cider-complete (str)
+ "Complete STR with context at point."
+ (let* ((context (cider-completion-get-context))
+ (candidates (cider-sync-request:complete str context)))
+ (mapcar #'cider-completion--parse-candidate-map candidates)))
+
+(defun cider-completion--get-candidate-type (symbol)
+ (let ((type (get-text-property 0 'type symbol)))
+ (or (cadr (assoc type cider-completion-annotations-alist))
+ type)))
+
+(defun cider-completion--get-candidate-ns (symbol)
+ (when (or (eq 'always cider-completion-annotations-include-ns)
+ (and (eq 'unqualified cider-completion-annotations-include-ns)
+ (not (cider-namespace-qualified-p symbol))))
+ (get-text-property 0 'ns symbol)))
+
+(defun cider-default-annotate-completion-function (type ns)
+ (concat (when ns (format " (%s)" ns))
+ (when type (format " <%s>" type))))
+
+(defun cider-annotate-symbol (symbol)
+ "Return a string suitable for annotating SYMBOL.
+
+If SYMBOL has a text property `type` whose value is recognised, its
+abbreviation according to `cider-completion-annotations-alist' will be
+used. If `type` is present but not recognised, its value will be used
+unaltered.
+
+If SYMBOL has a text property `ns`, then its value will be used according
+to `cider-completion-annotations-include-ns'.
+
+The formatting is performed by `cider-annotate-completion-function'."
+ (when cider-annotate-completion-candidates
+ (let* ((type (cider-completion--get-candidate-type symbol))
+ (ns (cider-completion--get-candidate-ns symbol)))
+ (funcall cider-annotate-completion-function type ns))))
+
+(defun cider-complete-at-point ()
+ "Complete the symbol at point."
+ (when-let ((bounds (bounds-of-thing-at-point 'symbol)))
+ (when (and (cider-connected-p)
+ (not (or (cider-in-string-p) (cider-in-comment-p))))
+ (list (car bounds) (cdr bounds)
+ (completion-table-dynamic #'cider-complete)
+ :annotation-function #'cider-annotate-symbol
+ :company-doc-buffer #'cider-create-doc-buffer
+ :company-location #'cider-company-location
+ :company-docsig #'cider-company-docsig))))
+
+(defun cider-company-location (var)
+ "Open VAR's definition in a buffer.
+
+Returns the cons of the buffer itself and the location of VAR's definition
+in the buffer."
+ (when-let ((info (cider-var-info var))
+ (file (nrepl-dict-get info "file"))
+ (line (nrepl-dict-get info "line"))
+ (buffer (cider-find-file file)))
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (cons buffer (point))))))
+
+(defun cider-company-docsig (thing)
+ "Return signature for THING."
+ (let* ((eldoc-info (cider-eldoc-info thing))
+ (ns (lax-plist-get eldoc-info "ns"))
+ (symbol (lax-plist-get eldoc-info "symbol"))
+ (arglists (lax-plist-get eldoc-info "arglists")))
+ (when eldoc-info
+ (format "%s: %s"
+ (cider-eldoc-format-thing ns symbol thing
+ (cider-eldoc-thing-type eldoc-info))
+ (cider-eldoc-format-arglist arglists 0)))))
+
+;; Fuzzy completion for company-mode
+
+(defun cider-company-unfiltered-candidates (string table predicate point)
+ "Return CIDER completion candidates as is, without filtering them by prefix."
+ (cider-complete string))
+
+(add-to-list 'completion-styles-alist
+ '(cider
+ cider-company-unfiltered-candidates
+ cider-company-unfiltered-candidates
+ "CIDER backend-driven completion style."))
+
+(defun cider-company-enable-fuzzy-completion ()
+ "Enable backend-driven fuzzy completion in the current buffer."
+ (setq-local completion-styles '(cider)))
+
+(defun cider-stdin-handler (&optional buffer)
+ "Make a stdin response handler for BUFFER."
+ (nrepl-make-response-handler (or buffer (current-buffer))
+ (lambda (buffer value)
+ (cider-repl-emit-result buffer value t))
+ (lambda (buffer out)
+ (cider-repl-emit-stdout buffer out))
+ (lambda (buffer err)
+ (cider-repl-emit-stderr buffer err))
+ nil))
+
+(defun cider-insert-eval-handler (&optional buffer)
+ "Make an nREPL evaluation handler for the BUFFER.
+The handler simply inserts the result value in BUFFER."
+ (let ((eval-buffer (current-buffer)))
+ (nrepl-make-response-handler (or buffer eval-buffer)
+ (lambda (_buffer value)
+ (with-current-buffer buffer
+ (insert value)))
+ (lambda (_buffer out)
+ (cider-repl-emit-interactive-stdout out))
+ (lambda (_buffer err)
+ (cider-handle-compilation-errors err eval-buffer))
+ '())))
+
+(defun cider--emit-interactive-eval-output (output repl-emit-function)
+ "Emit output resulting from interactive code evaluation.
+
+The OUTPUT can be sent to either a dedicated output buffer or the current
+REPL buffer. This is controlled by `cider-interactive-eval-output-destination'.
+REPL-EMIT-FUNCTION emits the OUTPUT."
+ (pcase cider-interactive-eval-output-destination
+ (`output-buffer (let ((output-buffer (or (get-buffer cider-output-buffer)
+ (cider-popup-buffer cider-output-buffer t))))
+ (cider-emit-into-popup-buffer output-buffer output)
+ (pop-to-buffer output-buffer)))
+ (`repl-buffer (funcall repl-emit-function output))
+ (_ (error "Unsupported value %s for `cider-interactive-eval-output-destination'"
+ cider-interactive-eval-output-destination))))
+
+(defun cider-emit-interactive-eval-output (output)
+ "Emit OUTPUT resulting from interactive code evaluation.
+
+The output can be send to either a dedicated output buffer or the current
+REPL buffer. This is controlled via
+`cider-interactive-eval-output-destination'."
+ (cider--emit-interactive-eval-output output 'cider-repl-emit-interactive-stdout))
+
+(defun cider-emit-interactive-eval-err-output (output)
+ "Emit err OUTPUT resulting from interactive code evaluation.
+
+The output can be send to either a dedicated output buffer or the current
+REPL buffer. This is controlled via
+`cider-interactive-eval-output-destination'."
+ (cider--emit-interactive-eval-output output 'cider-repl-emit-interactive-stderr))
+
+(defun cider--make-fringe-overlays-for-region (beg end)
+ "Place eval indicators on all sexps between BEG and END."
+ (with-current-buffer (if (markerp end)
+ (marker-buffer end)
+ (current-buffer))
+ (save-excursion
+ (goto-char beg)
+ (condition-case nil
+ (while (progn (clojure-forward-logical-sexp)
+ (and (<= (point) end)
+ (not (eobp))))
+ (cider--make-fringe-overlay (point)))
+ (scan-error nil)))))
+
+(defun cider-interactive-eval-handler (&optional buffer place)
+ "Make an interactive eval handler for BUFFER.
+PLACE is used to display the evaluation result.
+If non-nil, it can be the position where the evaluated sexp ends,
+or it can be a list with (START END) of the evaluated region."
+ (let* ((eval-buffer (current-buffer))
+ (beg (car-safe place))
+ (end (or (car-safe (cdr-safe place)) place))
+ (beg (when beg (copy-marker beg)))
+ (end (when end (copy-marker end))))
+ (nrepl-make-response-handler (or buffer eval-buffer)
+ (lambda (_buffer value)
+ (if beg
+ (cider--make-fringe-overlays-for-region beg end)
+ (cider--make-fringe-overlay end))
+ (cider--display-interactive-eval-result value end))
+ (lambda (_buffer out)
+ (cider-emit-interactive-eval-output out))
+ (lambda (_buffer err)
+ (cider-emit-interactive-eval-err-output err)
+ (cider-handle-compilation-errors err eval-buffer))
+ '())))
+
+(defun cider-load-file-handler (&optional buffer)
+ "Make a load file handler for BUFFER."
+ (let ((eval-buffer (current-buffer)))
+ (nrepl-make-response-handler (or buffer eval-buffer)
+ (lambda (buffer value)
+ (cider--display-interactive-eval-result value)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (cider--make-fringe-overlays-for-region (point-min) (point-max))
+ (run-hooks 'cider-file-loaded-hook))))
+ (lambda (_buffer value)
+ (cider-emit-interactive-eval-output value))
+ (lambda (_buffer err)
+ (cider-emit-interactive-eval-err-output err)
+ (cider-handle-compilation-errors err eval-buffer))
+ '()
+ (lambda ()
+ (funcall nrepl-err-handler)))))
+
+(defun cider-eval-print-handler (&optional buffer)
+ "Make a handler for evaluating and printing result in BUFFER."
+ (nrepl-make-response-handler (or buffer (current-buffer))
+ (lambda (buffer value)
+ (with-current-buffer buffer
+ (insert
+ (if (derived-mode-p 'cider-clojure-interaction-mode)
+ (format "\n%s\n" value)
+ value))))
+ (lambda (_buffer out)
+ (cider-emit-interactive-eval-output out))
+ (lambda (_buffer err)
+ (cider-emit-interactive-eval-err-output err))
+ '()))
+
+(defun cider-eval-print-with-comment-handler (buffer location comment-prefix)
+ "Make a handler for evaluating and printing commented results in BUFFER.
+
+LOCATION is the location at which to insert.
+COMMENT-PREFIX is the comment prefix to use."
+ (nrepl-make-response-handler buffer
+ (lambda (buffer value)
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char location)
+ (insert (concat comment-prefix
+ value "\n")))))
+ (lambda (_buffer out)
+ (cider-emit-interactive-eval-output out))
+ (lambda (_buffer err)
+ (cider-emit-interactive-eval-err-output err))
+ '()))
+
+(defun cider-popup-eval-out-handler (&optional buffer)
+ "Make a handler for evaluating and printing stdout/stderr in popup BUFFER.
+
+This is used by pretty-printing commands and intentionally discards their results."
+ (nrepl-make-response-handler (or buffer (current-buffer))
+ '()
+ ;; stdout handler
+ (lambda (buffer str)
+ (cider-emit-into-popup-buffer buffer (ansi-color-apply str)))
+ ;; stderr handler
+ (lambda (buffer str)
+ (cider-emit-into-popup-buffer buffer (ansi-color-apply str)))
+ '()))
+
+(defun cider-visit-error-buffer ()
+ "Visit the `cider-error-buffer' (usually *cider-error*) if it exists."
+ (interactive)
+ (if-let ((buffer (get-buffer cider-error-buffer)))
+ (cider-popup-buffer-display buffer cider-auto-select-error-buffer)
+ (user-error "No %s buffer" cider-error-buffer)))
+
+(defun cider-find-property (property &optional backward)
+ "Find the next text region which has the specified PROPERTY.
+If BACKWARD is t, then search backward.
+Returns the position at which PROPERTY was found, or nil if not found."
+ (let ((p (if backward
+ (previous-single-char-property-change (point) property)
+ (next-single-char-property-change (point) property))))
+ (when (and (not (= p (point-min))) (not (= p (point-max))))
+ p)))
+
+(defun cider-jump-to-compilation-error (&optional _arg _reset)
+ "Jump to the line causing the current compilation error.
+_ARG and _RESET are ignored, as there is only ever one compilation error.
+They exist for compatibility with `next-error'."
+ (interactive)
+ (cl-labels ((goto-next-note-boundary
+ ()
+ (let ((p (or (cider-find-property 'cider-note-p)
+ (cider-find-property 'cider-note-p t))))
+ (when p
+ (goto-char p)
+ (message "%s" (get-char-property p 'cider-note))))))
+ ;; if we're already on a compilation error, first jump to the end of
+ ;; it, so that we find the next error.
+ (when (get-char-property (point) 'cider-note-p)
+ (goto-next-note-boundary))
+ (goto-next-note-boundary)))
+
+(defun cider--show-error-buffer-p ()
+ "Return non-nil if the error buffer must be shown on error.
+
+Takes into account both the value of `cider-show-error-buffer' and the
+currently selected buffer."
+ (let* ((selected-buffer (window-buffer (selected-window)))
+ (replp (with-current-buffer selected-buffer (derived-mode-p 'cider-repl-mode))))
+ (memq cider-show-error-buffer
+ (if replp
+ '(t always only-in-repl)
+ '(t always except-in-repl)))))
+
+(defun cider-new-error-buffer (&optional mode error-types)
+ "Return an empty error buffer using MODE.
+
+When deciding whether to display the buffer, takes into account not only
+the value of `cider-show-error-buffer' and the currently selected buffer
+but also the ERROR-TYPES of the error, which is checked against the
+`cider-stacktrace-suppressed-errors' set.
+
+When deciding whether to select the buffer, takes into account the value of
+`cider-auto-select-error-buffer'."
+ (if (and (cider--show-error-buffer-p)
+ (not (cider-stacktrace-some-suppressed-errors-p error-types)))
+ (cider-popup-buffer cider-error-buffer cider-auto-select-error-buffer mode)
+ (cider-make-popup-buffer cider-error-buffer mode)))
+
+(defun cider--handle-err-eval-response (response)
+ "Render eval RESPONSE into a new error buffer.
+
+Uses the value of the `out' slot in RESPONSE."
+ (nrepl-dbind-response response (out)
+ (when out
+ (let ((error-buffer (cider-new-error-buffer)))
+ (cider-emit-into-color-buffer error-buffer out)
+ (with-current-buffer error-buffer
+ (compilation-minor-mode +1))))))
+
+(defun cider-default-err-eval-handler ()
+ "Display the last exception without middleware support."
+ (cider--handle-err-eval-response
+ (cider-nrepl-sync-request:eval
+ "(clojure.stacktrace/print-cause-trace *e)")))
+
+(defun cider--render-stacktrace-causes (causes &optional error-types)
+ "If CAUSES is non-nil, render its contents into a new error buffer.
+Optional argument ERROR-TYPES contains a list which should determine the
+op/situation that originated this error."
+ (when causes
+ (let ((error-buffer (cider-new-error-buffer #'cider-stacktrace-mode error-types)))
+ (cider-stacktrace-render error-buffer (reverse causes) error-types))))
+
+(defun cider--handle-stacktrace-response (response causes)
+ "Handle stacktrace op RESPONSE, aggregating the result into CAUSES.
+
+If RESPONSE contains a cause, cons it onto CAUSES and return that. If
+RESPONSE is the final message (i.e. it contains a status), render CAUSES
+into a new error buffer."
+ (nrepl-dbind-response response (class status)
+ (cond (class (cons response causes))
+ (status (cider--render-stacktrace-causes causes)))))
+
+(defun cider-default-err-op-handler ()
+ "Display the last exception, with middleware support."
+ ;; Causes are returned as a series of messages, which we aggregate in `causes'
+ (let (causes)
+ (cider-nrepl-send-request
+ (append
+ (list "op" "stacktrace")
+ (when (cider--pprint-fn)
+ (list "pprint-fn" (cider--pprint-fn)))
+ (when cider-stacktrace-print-length
+ (list "print-length" cider-stacktrace-print-length))
+ (when cider-stacktrace-print-level
+ (list "print-level" cider-stacktrace-print-level)))
+ (lambda (response)
+ ;; While the return value of `cider--handle-stacktrace-response' is not
+ ;; meaningful for the last message, we do not need the value of `causes'
+ ;; after it has been handled, so it's fine to set it unconditionally here
+ (setq causes (cider--handle-stacktrace-response response causes))))))
+
+(defun cider-default-err-handler ()
+ "This function determines how the error buffer is shown.
+It delegates the actual error content to the eval or op handler."
+ (if (cider-nrepl-op-supported-p "stacktrace")
+ (cider-default-err-op-handler)
+ (cider-default-err-eval-handler)))
+
+(defvar cider-compilation-regexp
+ '("\\(?:.*\\(warning, \\)\\|.*?\\(, compiling\\):(\\)\\(.*?\\):\\([[:digit:]]+\\)\\(?::\\([[:digit:]]+\\)\\)?\\(\\(?: - \\(.*\\)\\)\\|)\\)" 3 4 5 (1))
+ "Specifications for matching errors and warnings in Clojure stacktraces.
+See `compilation-error-regexp-alist' for help on their format.")
+
+(add-to-list 'compilation-error-regexp-alist-alist
+ (cons 'cider cider-compilation-regexp))
+(add-to-list 'compilation-error-regexp-alist 'cider)
+
+(defun cider-extract-error-info (regexp message)
+ "Extract error information with REGEXP against MESSAGE."
+ (let ((file (nth 1 regexp))
+ (line (nth 2 regexp))
+ (col (nth 3 regexp))
+ (type (nth 4 regexp))
+ (pat (car regexp)))
+ (when (string-match pat message)
+ ;; special processing for type (1.2) style
+ (setq type (if (consp type)
+ (or (and (car type) (match-end (car type)) 1)
+ (and (cdr type) (match-end (cdr type)) 0)
+ 2)))
+ (list
+ (when file
+ (let ((val (match-string-no-properties file message)))
+ (unless (string= val "NO_SOURCE_PATH") val)))
+ (when line (string-to-number (match-string-no-properties line message)))
+ (when col
+ (let ((val (match-string-no-properties col message)))
+ (when val (string-to-number val))))
+ (aref [cider-warning-highlight-face
+ cider-warning-highlight-face
+ cider-error-highlight-face]
+ (or type 2))
+ message))))
+
+(defun cider--goto-expression-start ()
+ "Go to the beginning a list, vector, map or set outside of a string.
+
+We do so by starting and the current position and proceeding backwards
+until we find a delimiters that's not inside a string."
+ (if (and (looking-back "[])}]" (line-beginning-position))
+ (null (nth 3 (syntax-ppss))))
+ (backward-sexp)
+ (while (or (not (looking-at-p "[({[]"))
+ (nth 3 (syntax-ppss)))
+ (backward-char))))
+
+(defun cider--find-last-error-location (message)
+ "Return the location (begin end buffer) from the Clojure error MESSAGE.
+If location could not be found, return nil."
+ (save-excursion
+ (let ((info (cider-extract-error-info cider-compilation-regexp message)))
+ (when info
+ (let ((file (nth 0 info))
+ (line (nth 1 info))
+ (col (nth 2 info)))
+ (unless (or (not (stringp file))
+ (cider--tooling-file-p file))
+ (when-let ((buffer (cider-find-file file)))
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (move-to-column (or col 0))
+ (let ((begin (progn (if col (cider--goto-expression-start) (back-to-indentation))
+ (point)))
+ (end (progn (if col (forward-list) (move-end-of-line nil))
+ (point))))
+ (list begin end buffer))))))))))))
+
+(defun cider-handle-compilation-errors (message eval-buffer)
+ "Highlight and jump to compilation error extracted from MESSAGE.
+EVAL-BUFFER is the buffer that was current during user's interactive
+evaluation command. Honor `cider-auto-jump-to-error'."
+ (when-let ((loc (cider--find-last-error-location message))
+ (overlay (make-overlay (nth 0 loc) (nth 1 loc) (nth 2 loc)))
+ (info (cider-extract-error-info cider-compilation-regexp message)))
+ (let* ((face (nth 3 info))
+ (note (nth 4 info))
+ (auto-jump (if (eq cider-auto-jump-to-error 'errors-only)
+ (not (eq face 'cider-warning-highlight-face))
+ cider-auto-jump-to-error)))
+ (overlay-put overlay 'cider-note-p t)
+ (overlay-put overlay 'font-lock-face face)
+ (overlay-put overlay 'cider-note note)
+ (overlay-put overlay 'help-echo note)
+ (overlay-put overlay 'modification-hooks
+ (list (lambda (o &rest _args) (delete-overlay o))))
+ (when auto-jump
+ (with-current-buffer eval-buffer
+ (push-mark)
+ ;; At this stage selected window commonly is *cider-error* and we need to
+ ;; re-select the original user window. If eval-buffer is not
+ ;; visible it was probably covered as a result of a small screen or user
+ ;; configuration (https://github.com/clojure-emacs/cider/issues/847). In
+ ;; that case we don't jump at all in order to avoid covering *cider-error*
+ ;; buffer.
+ (when-let ((win (get-buffer-window eval-buffer)))
+ (with-selected-window win
+ (cider-jump-to (nth 2 loc) (car loc)))))))))
+
+(defun cider-need-input (buffer)
+ "Handle an need-input request from BUFFER."
+ (with-current-buffer buffer
+ (nrepl-request:stdin (concat (read-from-minibuffer "Stdin: ") "\n")
+ (cider-stdin-handler buffer)
+ (cider-current-connection))))
+
+(defun cider-emit-into-color-buffer (buffer value)
+ "Emit into color BUFFER the provided VALUE."
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t)
+ (buffer-undo-list t))
+ (goto-char (point-max))
+ (insert (format "%s" value))
+ (ansi-color-apply-on-region (point-min) (point-max)))
+ (goto-char (point-min))))
+
+\f
+;;; Evaluation
+
+(defvar cider-to-nrepl-filename-function
+ (with-no-warnings
+ (if (eq system-type 'cygwin)
+ #'cygwin-convert-file-name-to-windows
+ #'identity))
+ "Function to translate Emacs filenames to nREPL namestrings.")
+
+(defvar-local cider--ns-form-cache (make-hash-table :test 'equal)
+ "ns form cache for the current buffer.
+
+The cache is a hash where the keys are connection names and the values
+are ns forms. This allows every connection to keep track of the ns
+form independently.")
+
+(defun cider--cache-ns-form ()
+ "Cache the form in the current buffer for the current connection."
+ (puthash (cider-current-connection)
+ (cider-ns-form)
+ cider--ns-form-cache))
+
+(defun cider--cached-ns-form ()
+ "Retrieve the cached ns form for the current buffer & connection."
+ (gethash (cider-current-connection) cider--ns-form-cache))
+
+(defun cider--prep-interactive-eval (form)
+ "Prepare the environment for an interactive eval of FORM.
+
+If FORM is an ns-form, ensure that it is evaluated in the `user`
+namespace. Otherwise, ensure the current ns declaration has been
+evaluated (so that the ns containing FORM exists).
+
+Clears any compilation highlights and kills the error window."
+ (cider--clear-compilation-highlights)
+ (cider--quit-error-window)
+ (let ((cur-ns-form (cider-ns-form)))
+ (when (and cur-ns-form
+ (not (string= cur-ns-form (cider--cached-ns-form)))
+ (not (cider-ns-form-p form)))
+ ;; TODO: check for evaluation errors
+ (cider-eval-ns-form 'sync)
+ (cider--cache-ns-form))))
+
+(defvar-local cider-interactive-eval-override nil
+ "Function to call instead of `cider-interactive-eval'.")
+
+(defun cider-interactive-eval (form &optional callback bounds additional-params)
+ "Evaluate FORM and dispatch the response to CALLBACK.
+If the code to be evaluated comes from a buffer, it is preferred to use a
+nil FORM, and specify the code via the BOUNDS argument instead.
+
+This function is the main entry point in CIDER's interactive evaluation
+API. Most other interactive eval functions should rely on this function.
+If CALLBACK is nil use `cider-interactive-eval-handler'.
+BOUNDS, if non-nil, is a list of two numbers marking the start and end
+positions of FORM in its buffer.
+ADDITIONAL-PARAMS is a plist to be appended to the request message.
+
+If `cider-interactive-eval-override' is a function, call it with the same
+arguments and only proceed with evaluation if it returns nil."
+ (let ((form (or form (apply #'buffer-substring bounds)))
+ (start (car-safe bounds))
+ (end (car-safe (cdr-safe bounds))))
+ (when (and start end)
+ (remove-overlays start end 'cider-temporary t))
+ (unless (and cider-interactive-eval-override
+ (functionp cider-interactive-eval-override)
+ (funcall cider-interactive-eval-override form callback bounds))
+ (cider-map-connections #'ignore :any)
+ (cider--prep-interactive-eval form)
+ (cider-nrepl-request:eval
+ form
+ (or callback (cider-interactive-eval-handler nil bounds))
+ ;; always eval ns forms in the user namespace
+ ;; otherwise trying to eval ns form for the first time will produce an error
+ (if (cider-ns-form-p form) "user" (cider-current-ns))
+ (when start (line-number-at-pos start))
+ (when start (cider-column-number-at-pos start))
+ additional-params))))
+
+(defun cider-eval-region (start end)
+ "Evaluate the region between START and END."
+ (interactive "r")
+ (cider-interactive-eval nil nil (list start end)))
+
+(defun cider-eval-last-sexp (&optional prefix)
+ "Evaluate the expression preceding point.
+If invoked with a PREFIX argument, print the result in the current buffer."
+ (interactive "P")
+ (cider-interactive-eval nil
+ (when prefix (cider-eval-print-handler))
+ (cider-last-sexp 'bounds)))
+
+(defun cider-eval-last-sexp-and-replace ()
+ "Evaluate the expression preceding point and replace it with its result."
+ (interactive)
+ (let ((last-sexp (cider-last-sexp)))
+ ;; we have to be sure the evaluation won't result in an error
+ (cider-nrepl-sync-request:eval last-sexp)
+ ;; seems like the sexp is valid, so we can safely kill it
+ (backward-kill-sexp)
+ (cider-interactive-eval last-sexp (cider-eval-print-handler))))
+
+(defun cider-eval-sexp-at-point (&optional prefix)
+ "Evaluate the expression around point.
+If invoked with a PREFIX argument, print the result in the current buffer."
+ (interactive "P")
+ (save-excursion
+ (goto-char (cadr (cider-sexp-at-point 'bounds)))
+ (cider-eval-last-sexp prefix)))
+
+(defun cider-eval-defun-to-comment (loc)
+ "Evaluate the \"top-level\" form and insert result as comment at LOC.
+
+With a prefix arg, LOC, insert before the form, otherwise afterwards."
+ (interactive "P")
+ (let* ((bounds (cider-defun-at-point 'bounds))
+ (insertion-point (nth (if loc 0 1) bounds)))
+ (cider-interactive-eval nil
+ (cider-eval-print-with-comment-handler
+ (current-buffer) insertion-point ";; => ")
+ bounds)))
+
+(declare-function cider-switch-to-repl-buffer "cider-mode")
+
+(defun cider-eval-last-sexp-to-repl (&optional prefix)
+ "Evaluate the expression preceding point and insert its result in the REPL.
+If invoked with a PREFIX argument, switch to the REPL buffer."
+ (interactive "P")
+ (cider-interactive-eval nil
+ (cider-insert-eval-handler (cider-current-connection))
+ (cider-last-sexp 'bounds))
+ (when prefix
+ (cider-switch-to-repl-buffer)))
+
+(defun cider-pprint-eval-last-sexp-to-repl (&optional prefix)
+ "Evaluate the expression preceding point and insert its pretty-printed result in the REPL.
+If invoked with a PREFIX argument, switch to the REPL buffer."
+ (interactive "P")
+ (let* ((conn-buffer (cider-current-connection)))
+ (cider-interactive-eval nil
+ (cider-insert-eval-handler conn-buffer)
+ (cider-last-sexp 'bounds)
+ (cider--nrepl-pprint-request-plist (cider--pretty-print-width))))
+ (when prefix
+ (cider-switch-to-repl-buffer)))
+
+(defun cider-eval-print-last-sexp ()
+ "Evaluate the expression preceding point.
+Print its value into the current buffer."
+ (interactive)
+ (cider-interactive-eval nil
+ (cider-eval-print-handler)
+ (cider-last-sexp 'bounds)))
+
+(defun cider--pprint-eval-form (form)
+ "Pretty print FORM in popup buffer."
+ (let* ((result-buffer (cider-popup-buffer cider-result-buffer nil 'clojure-mode))
+ (handler (cider-popup-eval-out-handler result-buffer)))
+ (cider-interactive-eval (when (stringp form) form)
+ handler
+ (when (consp form) form)
+ (cider--nrepl-pprint-request-plist (cider--pretty-print-width)))))
+
+(defun cider-pprint-eval-last-sexp ()
+ "Evaluate the sexp preceding point and pprint its value in a popup buffer."
+ (interactive)
+ (cider--pprint-eval-form (cider-last-sexp 'bounds)))
+
+(defun cider--prompt-and-insert-inline-dbg ()
+ "Insert a #dbg button at the current sexp."
+ (save-excursion
+ (let ((beg))
+ (skip-chars-forward "\r\n[:blank:]")
+ (unless (looking-at-p "(")
+ (ignore-errors (backward-up-list)))
+ (setq beg (point))
+ (let* ((cond (cider-read-from-minibuffer "Condition for debugging (leave empty for \"always\"): "))
+ (button (propertize (concat "#dbg"
+ (unless (equal cond "")
+ (format " ^{:break/when %s}" cond)))
+ 'font-lock-face 'cider-fragile-button-face)))
+ (when (> (current-column) 30)
+ (insert "\n")
+ (indent-according-to-mode))
+ (insert button)
+ (when (> (current-column) 40)
+ (insert "\n")
+ (indent-according-to-mode)))
+ (make-button beg (point)
+ 'help-echo "Breakpoint. Reevaluate this form to remove it."
+ :type 'cider-fragile))))
+
+(defun cider-eval-defun-at-point (&optional debug-it)
+ "Evaluate the current toplevel form, and print result in the minibuffer.
+With DEBUG-IT prefix argument, also debug the entire form as with the
+command `cider-debug-defun-at-point'."
+ (interactive "P")
+ (let ((inline-debug (eq 16 (car-safe debug-it))))
+ (when debug-it
+ (when (derived-mode-p 'clojurescript-mode)
+ (when (y-or-n-p (concat "The debugger doesn't support ClojureScript yet, and we need help with that."
+ " \nWould you like to read the Feature Request?"))
+ (browse-url "https://github.com/clojure-emacs/cider/issues/1416"))
+ (user-error "The debugger does not support ClojureScript"))
+ (when inline-debug
+ (cider--prompt-and-insert-inline-dbg)))
+ (cider-interactive-eval (when (and debug-it (not inline-debug))
+ (concat "#dbg\n" (cider-defun-at-point)))
+ nil (cider-defun-at-point 'bounds))))
+
+(defun cider-pprint-eval-defun-at-point ()
+ "Evaluate the \"top-level\" form at point and pprint its value in a popup buffer."
+ (interactive)
+ (cider--pprint-eval-form (cider-defun-at-point 'bounds)))
+
+(defun cider-eval-ns-form (&optional sync)
+ "Evaluate the current buffer's namespace form.
+
+When SYNC is true the form is evaluated synchronously,
+otherwise it's evaluated interactively."
+ (interactive)
+ (when (clojure-find-ns)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (if sync
+ ;; The first interactive eval on a file can load a lot of libs. This
+ ;; can easily lead to more than 10 sec.
+ (let ((nrepl-sync-request-timeout 30))
+ (cider-nrepl-sync-request:eval (cider-defun-at-point)))
+ (cider-eval-defun-at-point)))))
+
+(defun cider-read-and-eval (&optional value)
+ "Read a sexp from the minibuffer and output its result to the echo area.
+If VALUE is non-nil, it is inserted into the minibuffer as initial input."
+ (interactive)
+ (let* ((form (cider-read-from-minibuffer "Clojure Eval: " value))
+ (override cider-interactive-eval-override)
+ (ns-form (if (cider-ns-form-p form) "" (format "(ns %s)" (cider-current-ns)))))
+ (with-current-buffer (get-buffer-create cider-read-eval-buffer)
+ (erase-buffer)
+ (clojure-mode)
+ (unless (string= "" ns-form)
+ (insert ns-form "\n\n"))
+ (insert form)
+ (let ((cider-interactive-eval-override override))
+ (cider-interactive-eval form)))))
+
+(defun cider-read-and-eval-defun-at-point ()
+ "Insert the toplevel form at point in the minibuffer and output its result.
+The point is placed next to the function name in the minibuffer to allow
+passing arguments."
+ (interactive)
+ (let* ((fn-name (cadr (split-string (cider-defun-at-point))))
+ (form (concat "(" fn-name ")")))
+ (cider-read-and-eval (cons form (length form)))))
+
+;; Eval keymap
+
+(defvar cider-eval-commands-map
+ (let ((map (define-prefix-command 'cider-eval-commands-map)))
+ ;; single key bindings defined last for display in menu
+ (define-key map (kbd "w") #'cider-eval-last-sexp-and-replace)
+ (define-key map (kbd "r") #'cider-eval-region)
+ (define-key map (kbd "n") #'cider-eval-ns-form)
+ (define-key map (kbd "v") #'cider-eval-sexp-at-point)
+ (define-key map (kbd ".") #'cider-read-and-eval-defun-at-point)
+ ;; duplicates with C- for convenience
+ (define-key map (kbd "C-w") #'cider-eval-last-sexp-and-replace)
+ (define-key map (kbd "C-r") #'cider-eval-region)
+ (define-key map (kbd "C-n") #'cider-eval-ns-form)
+ (define-key map (kbd "C-v") #'cider-eval-sexp-at-point)
+ (define-key map (kbd "C-.") #'cider-read-and-eval-defun-at-point)))
+
+\f
+;; Connection and REPL
+
+(defun cider-insert-in-repl (form eval)
+ "Insert FORM in the REPL buffer and switch to it.
+If EVAL is non-nil the form will also be evaluated."
+ (while (string-match "\\`[ \t\n\r]+\\|[ \t\n\r]+\\'" form)
+ (setq form (replace-match "" t t form)))
+ (with-current-buffer (cider-current-connection)
+ (goto-char (point-max))
+ (let ((beg (point)))
+ (insert form)
+ (indent-region beg (point)))
+ (when eval
+ (cider-repl-return)))
+ (cider-switch-to-repl-buffer))
+
+(defun cider-insert-last-sexp-in-repl (&optional arg)
+ "Insert the expression preceding point in the REPL buffer.
+If invoked with a prefix ARG eval the expression after inserting it."
+ (interactive "P")
+ (cider-insert-in-repl (cider-last-sexp) arg))
+
+(defun cider-insert-defun-in-repl (&optional arg)
+ "Insert the top-level form at point in the REPL buffer.
+If invoked with a prefix ARG eval the expression after inserting it."
+ (interactive "P")
+ (cider-insert-in-repl (cider-defun-at-point) arg))
+
+(defun cider-insert-region-in-repl (start end &optional arg)
+ "Insert the curent region in the REPL buffer.
+START and END represent the region's boundaries.
+If invoked with a prefix ARG eval the expression after inserting it."
+ (interactive "rP")
+ (cider-insert-in-repl
+ (buffer-substring-no-properties start end) arg))
+
+(defun cider-insert-ns-form-in-repl (&optional arg)
+ "Insert the current buffer's ns form in the REPL buffer.
+If invoked with a prefix ARG eval the expression after inserting it."
+ (interactive "P")
+ (cider-insert-in-repl (cider-ns-form) arg))
+
+(defun cider-ping ()
+ "Check that communication with the nREPL server works."
+ (interactive)
+ (thread-first (cider-nrepl-sync-request:eval "\"PONG\"")
+ (nrepl-dict-get "value")
+ (read)
+ (message)))
+
+(defun cider-enable-on-existing-clojure-buffers ()
+ "Enable CIDER's minor mode on existing Clojure buffers.
+See `cider-mode'."
+ (interactive)
+ (add-hook 'clojure-mode-hook #'cider-mode)
+ (dolist (buffer (cider-util--clojure-buffers))
+ (with-current-buffer buffer
+ (cider-mode +1))))
+
+(defun cider-disable-on-existing-clojure-buffers ()
+ "Disable `cider-mode' on existing Clojure buffers.
+See `cider-mode'."
+ (interactive)
+ (dolist (buffer (cider-util--clojure-buffers))
+ (with-current-buffer buffer
+ (cider-mode -1))))
+
+(defun cider-possibly-disable-on-existing-clojure-buffers ()
+ "If not connected, disable `cider-mode' on existing Clojure buffers."
+ (unless (cider-connected-p)
+ (cider-disable-on-existing-clojure-buffers)))
+
+\f
+;;; Completion
+
+(defun cider-sync-request:toggle-trace-var (symbol)
+ "Toggle var tracing for SYMBOL."
+ (thread-first (list "op" "toggle-trace-var"
+ "ns" (cider-current-ns)
+ "sym" symbol)
+ (cider-nrepl-send-sync-request)))
+
+(defun cider--toggle-trace-var (sym)
+ "Toggle var tracing for SYM."
+ (let* ((trace-response (cider-sync-request:toggle-trace-var sym))
+ (var-name (nrepl-dict-get trace-response "var-name"))
+ (var-status (nrepl-dict-get trace-response "var-status")))
+ (pcase var-status
+ ("not-found" (error "Var %s not found" (cider-propertize sym 'fn)))
+ ("not-traceable" (error "Var %s can't be traced because it's not bound to a function" (cider-propertize var-name 'fn)))
+ (_ (message "Var %s %s" (cider-propertize var-name 'fn) var-status)))))
+
+(defun cider-toggle-trace-var (arg)
+ "Toggle var tracing.
+
+Prompts for the symbol to use, or uses the symbol at point, depending on
+the value of `cider-prompt-for-symbol'. With prefix arg ARG, does the
+opposite of what that option dictates."
+ (interactive "P")
+ (cider-ensure-op-supported "toggle-trace-var")
+ (funcall (cider-prompt-for-symbol-function arg)
+ "Toggle trace for var"
+ #'cider--toggle-trace-var))
+
+(defun cider-sync-request:toggle-trace-ns (ns)
+ "Toggle namespace tracing for NS."
+ (thread-first (list "op" "toggle-trace-ns"
+ "ns" ns)
+ (cider-nrepl-send-sync-request)))
+
+(defun cider-toggle-trace-ns (query)
+ "Toggle ns tracing.
+Defaults to the current ns. With prefix arg QUERY, prompts for a ns."
+ (interactive "P")
+ (cider-map-connections
+ (lambda (conn)
+ (with-current-buffer conn
+ (cider-ensure-op-supported "toggle-trace-ns")
+ (let ((ns (if query
+ (completing-read "Toggle trace for ns: "
+ (cider-sync-request:ns-list))
+ (cider-current-ns))))
+ (let* ((trace-response (cider-sync-request:toggle-trace-ns ns))
+ (ns-status (nrepl-dict-get trace-response "ns-status")))
+ (pcase ns-status
+ ("not-found" (error "Namespace %s not found" (cider-propertize ns 'ns)))
+ (_ (message "Namespace %s %s" (cider-propertize ns 'ns) ns-status)))))))
+ :clj))
+
+(defun cider-undef ()
+ "Undefine a symbol from the current ns."
+ (interactive)
+ (cider-ensure-op-supported "undef")
+ (cider-read-symbol-name
+ "Undefine symbol: "
+ (lambda (sym)
+ (cider-nrepl-send-request
+ (list "op" "undef"
+ "ns" (cider-current-ns)
+ "symbol" sym)
+ (cider-interactive-eval-handler (current-buffer))))))
+
+(defun cider-refresh--handle-response (response log-buffer)
+ (nrepl-dbind-response response (out err reloading status error error-ns after before)
+ (cl-flet* ((log (message &optional face)
+ (cider-emit-into-popup-buffer log-buffer message face))
+
+ (log-echo (message &optional face)
+ (log message face)
+ (unless cider-refresh-show-log-buffer
+ (let ((message-truncate-lines t))
+ (message "cider-refresh: %s" message)))))
+ (cond
+ (out
+ (log out))
+
+ (err
+ (log err 'font-lock-warning-face))
+
+ ((member "invoking-before" status)
+ (log-echo (format "Calling %s\n" before) 'font-lock-string-face))
+
+ ((member "invoked-before" status)
+ (log-echo (format "Successfully called %s\n" before) 'font-lock-string-face))
+
+ ((member "invoked-not-resolved" status)
+ (log-echo "Could not resolve refresh function\n" 'font-lock-string-face))
+
+ (reloading
+ (log-echo (format "Reloading %s\n" reloading) 'font-lock-string-face))
+
+ ((member "reloading" (nrepl-dict-keys response))
+ (log-echo "Nothing to reload\n" 'font-lock-string-face))
+
+ ((member "ok" status)
+ (log-echo "Reloading successful\n" 'font-lock-string-face))
+
+ (error-ns
+ (log-echo (format "Error reloading %s\n" error-ns) 'font-lock-warning-face))
+
+ ((member "invoking-after" status)
+ (log-echo (format "Calling %s\n" after) 'font-lock-string-face))
+
+ ((member "invoked-after" status)
+ (log-echo (format "Successfully called %s\n" after) 'font-lock-string-face))))
+
+ (with-selected-window (or (get-buffer-window cider-refresh-log-buffer)
+ (selected-window))
+ (with-current-buffer cider-refresh-log-buffer
+ (goto-char (point-max))))
+
+ (when (member "error" status)
+ (cider--render-stacktrace-causes error))))
+
+(defun cider-refresh (&optional mode)
+ "Reload modified and unloaded namespaces on the classpath.
+
+With a single prefix argument, or if MODE is `refresh-all', reload all
+namespaces on the classpath unconditionally.
+
+With a double prefix argument, or if MODE is `clear', clear the state of
+the namespace tracker before reloading. This is useful for recovering from
+some classes of error (for example, those caused by circular dependencies)
+that a normal reload would not otherwise recover from. The trade-off of
+clearing is that stale code from any deleted files may not be completely
+unloaded.
+
+With a negative prefix argument, or if MODE is `inhibit-fns', prevent any
+refresh functions (defined in `cider-refresh-before-fn' and
+`cider-refresh-after-fn') from being invoked."
+ (interactive "p")
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "refresh")
+ (let ((clear? (member mode '(clear 16)))
+ (refresh-all? (member mode '(refresh-all 4)))
+ (inhibit-refresh-fns (member mode '(inhibit-fns -1))))
+ (cider-map-connections
+ (lambda (conn)
+ ;; Inside the lambda, so the buffer is not created if we error out.
+ (let ((log-buffer (or (get-buffer cider-refresh-log-buffer)
+ (cider-make-popup-buffer cider-refresh-log-buffer))))
+ (when cider-refresh-show-log-buffer
+ (cider-popup-buffer-display log-buffer))
+ (when inhibit-refresh-fns
+ (cider-emit-into-popup-buffer log-buffer "inhibiting refresh functions\n"))
+ (when clear?
+ (cider-nrepl-send-sync-request (list "op" "refresh-clear") conn))
+ (cider-nrepl-send-request
+ (append (list "op" (if refresh-all? "refresh-all" "refresh")
+ "print-length" cider-stacktrace-print-length
+ "print-level" cider-stacktrace-print-level)
+ (when (cider--pprint-fn) (list "pprint-fn" (cider--pprint-fn)))
+ (when (and (not inhibit-refresh-fns) cider-refresh-before-fn)
+ (list "before" cider-refresh-before-fn))
+ (when (and (not inhibit-refresh-fns) cider-refresh-after-fn)
+ (list "after" cider-refresh-after-fn)))
+ (lambda (response)
+ (cider-refresh--handle-response response log-buffer))
+ conn)))
+ :clj 'any-mode)))
+
+(defun cider-file-string (file)
+ "Read the contents of a FILE and return as a string."
+ (with-current-buffer (find-file-noselect file)
+ (substring-no-properties (buffer-string))))
+
+(defun cider-load-buffer (&optional buffer)
+ "Load (eval) BUFFER's file in nREPL.
+If no buffer is provided the command acts on the current buffer.
+
+If the buffer is for a cljc or cljx file, and both a Clojure and
+ClojureScript REPL exists for the project, it is evaluated in both REPLs."
+ (interactive)
+ (check-parens)
+ (cider-ensure-connected)
+ (setq buffer (or buffer (current-buffer)))
+ (with-current-buffer buffer
+ (unless buffer-file-name
+ (user-error "Buffer `%s' is not associated with a file" (current-buffer)))
+ (when (and cider-prompt-save-file-on-load
+ (buffer-modified-p)
+ (or (eq cider-prompt-save-file-on-load 'always-save)
+ (y-or-n-p (format "Save file %s? " buffer-file-name))))
+ (save-buffer))
+ (remove-overlays nil nil 'cider-temporary t)
+ (cider--clear-compilation-highlights)
+ (cider--quit-error-window)
+ (cider--cache-ns-form)
+ (let ((filename (buffer-file-name)))
+ (cider-map-connections
+ (lambda (connection)
+ (cider-request:load-file (cider-file-string filename)
+ (funcall cider-to-nrepl-filename-function
+ (cider--server-filename filename))
+ (file-name-nondirectory filename)
+ connection))
+ :both)
+ (message "Loading %s..." filename))))
+
+(defun cider-load-file (filename)
+ "Load (eval) the Clojure file FILENAME in nREPL.
+
+If the file is a cljc or cljx file, and both a Clojure and ClojureScript
+REPL exists for the project, it is evaluated in both REPLs.
+
+The heavy lifting is done by `cider-load-buffer'."
+ (interactive (list
+ (read-file-name "Load file: " nil nil nil
+ (when (buffer-file-name)
+ (file-name-nondirectory
+ (buffer-file-name))))))
+ (if-let ((buffer (find-buffer-visiting filename)))
+ (cider-load-buffer buffer)
+ (find-file filename)
+ (cider-load-buffer (current-buffer))))
+
+(defalias 'cider-eval-file 'cider-load-file
+ "A convenience alias as some people are confused by the load-* names.")
+
+(defalias 'cider-eval-buffer 'cider-load-buffer
+ "A convenience alias as some people are confused by the load-* names.")
+
+(defun cider--format-buffer (formatter)
+ "Format the contents of the current buffer.
+
+Uses FORMATTER, a function of one argument, to convert the string contents
+of the buffer into a formatted string."
+ (let* ((original (substring-no-properties (buffer-string)))
+ (formatted (funcall formatter original)))
+ (unless (equal original formatted)
+ (erase-buffer)
+ (insert formatted))))
+
+(defun cider-format-buffer ()
+ "Format the Clojure code in the current buffer."
+ (interactive)
+ (cider-ensure-connected)
+ (cider--format-buffer #'cider-sync-request:format-code))
+
+(defun cider-format-edn-buffer ()
+ "Format the EDN data in the current buffer."
+ (interactive)
+ (cider-ensure-connected)
+ (cider--format-buffer (lambda (edn)
+ (cider-sync-request:format-edn edn (cider--pretty-print-width)))))
+
+(defun cider--format-reindent (formatted start)
+ "Reindent FORMATTED to align with buffer position START."
+ (let* ((start-column (save-excursion (goto-char start) (current-column)))
+ (indent-line (concat "\n" (make-string start-column ? ))))
+ (replace-regexp-in-string "\n" indent-line formatted)))
+
+(defun cider--format-region (start end formatter)
+ "Format the contents of the given region.
+
+START and END represent the region's boundaries.
+FORMATTER is a function of one argument which is used to convert
+the string contents of the region into a formatted string."
+ (let* ((original (buffer-substring-no-properties start end))
+ (formatted (funcall formatter original))
+ (indented (cider--format-reindent formatted start)))
+ (unless (equal original indented)
+ (delete-region start end)
+ (insert indented))))
+
+(defun cider-format-region (start end)
+ "Format the Clojure code in the current region.
+START and END represent the region's boundaries."
+ (interactive "r")
+ (cider-ensure-connected)
+ (cider--format-region start end #'cider-sync-request:format-code))
+
+(defun cider-format-edn-region (start end)
+ "Format the EDN data in the current region.
+START and END represent the region's boundaries."
+ (interactive "r")
+ (cider-ensure-connected)
+ (let* ((start-column (save-excursion (goto-char start) (current-column)))
+ (right-margin (- (cider--pretty-print-width) start-column)))
+ (cider--format-region start end
+ (lambda (edn)
+ (cider-sync-request:format-edn edn right-margin)))))
+
+(defun cider-format-defun ()
+ "Format the code in the current defun."
+ (interactive)
+ (cider-ensure-connected)
+ (save-excursion
+ (mark-defun)
+ (cider-format-region (region-beginning) (region-end))))
+
+;;; interrupt evaluation
+(defun cider-interrupt-handler (buffer)
+ "Create an interrupt response handler for BUFFER."
+ (nrepl-make-response-handler buffer nil nil nil nil))
+
+(defun cider-describe-nrepl-session ()
+ "Describe an nREPL session."
+ (interactive)
+ (cider-ensure-connected)
+ (let ((selected-session (completing-read "Describe nREPL session: " (nrepl-sessions (cider-current-connection)))))
+ (when (and selected-session (not (equal selected-session "")))
+ (let* ((session-info (nrepl-sync-request:describe (cider-current-connection)))
+ (ops (nrepl-dict-keys (nrepl-dict-get session-info "ops")))
+ (session-id (nrepl-dict-get session-info "session"))
+ (session-type (cond
+ ((equal session-id (cider-current-session)) "Active eval")
+ ((equal session-id (cider-current-tooling-session)) "Active tooling")
+ (t "Unknown"))))
+ (with-current-buffer (cider-popup-buffer cider-nrepl-session-buffer)
+ (read-only-mode -1)
+ (insert (format "Session: %s\n" session-id)
+ (format "Type: %s session\n" session-type)
+ (format "Supported ops:\n"))
+ (mapc (lambda (op) (insert (format " * %s\n" op))) ops)))
+ (display-buffer cider-nrepl-session-buffer))))
+
+(defun cider-close-nrepl-session ()
+ "Close an nREPL session for the current connection."
+ (interactive)
+ (cider-ensure-connected)
+ (nrepl-sync-request:close (cider-current-connection))
+ (message "Closed nREPL session"))
+
+;;; quiting
+(defun cider--close-buffer (buffer)
+ "Close the BUFFER and kill its associated process (if any)."
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (when-let ((proc (get-buffer-process buffer)))
+ (when (process-live-p proc)
+ (when (or (not nrepl-server-buffer)
+ ;; Sync request will hang if the server is dead.
+ (process-live-p (get-buffer-process nrepl-server-buffer)))
+ (when (or nrepl-session nrepl-tooling-session)
+ (nrepl-sync-request:close buffer)))
+ (when proc (delete-process proc)))))
+ (kill-buffer buffer)))
+
+(defun cider-close-ancillary-buffers ()
+ "Close buffers that are shared across connections."
+ (interactive)
+ (dolist (buf-name cider-ancillary-buffers)
+ (when (get-buffer buf-name)
+ (kill-buffer buf-name))))
+
+(defun cider--quit-connection (conn)
+ "Quit the connection CONN."
+ (when conn
+ (cider--close-connection-buffer conn)
+ ;; clean the cached ns forms for this connection in all Clojure buffers
+ (dolist (clojure-buffer (cider-util--clojure-buffers))
+ (with-current-buffer clojure-buffer
+ (remhash conn cider--ns-form-cache)))))
+
+(defun cider-quit (&optional quit-all)
+ "Quit the currently active CIDER connection.
+
+With a prefix argument QUIT-ALL the command will kill all connections
+and all ancillary CIDER buffers."
+ (interactive "P")
+ (cider-ensure-connected)
+ (if (and quit-all (y-or-n-p "Are you sure you want to quit all CIDER connections? "))
+ (progn
+ (dolist (connection cider-connections)
+ (cider--quit-connection connection))
+ (message "All active nREPL connections were closed"))
+ (let ((connection (cider-current-connection)))
+ (when (y-or-n-p (format "Are you sure you want to quit the current CIDER connection %s? "
+ (cider-propertize (buffer-name connection) 'bold)))
+ (cider--quit-connection connection))))
+ ;; if there are no more connections we can kill all ancillary buffers
+ (unless (cider-connected-p)
+ (cider-close-ancillary-buffers)))
+
+(defun cider--restart-connection (conn)
+ "Restart the connection CONN."
+ (let ((project-dir (with-current-buffer conn nrepl-project-dir))
+ (buf-name (buffer-name conn))
+ ;; save these variables before we kill the connection
+ (conn-creation-method (with-current-buffer conn cider-connection-created-with))
+ (conn-endpoint (with-current-buffer conn nrepl-endpoint)))
+ (cider--quit-connection conn)
+ ;; Workaround for a nasty race condition https://github.com/clojure-emacs/cider/issues/439
+ ;; TODO: Find a better way to ensure `cider-quit' has finished
+ (message "Waiting for CIDER connection %s to quit..."
+ (cider-propertize buf-name 'bold))
+ (sleep-for 2)
+ (pcase conn-creation-method
+ (`connect (apply #'cider-connect conn-endpoint))
+ (`jack-in (if project-dir
+ (let ((default-directory project-dir))
+ (cider-jack-in))
+ (error "Can't restart CIDER connection for unknown project")))
+ (_ (error "Unexpected value %S for `cider-connection-created-with'"
+ conn-creation-method)))))
+
+(defun cider-restart (&optional restart-all)
+ "Restart the currently active CIDER connection.
+If RESTART-ALL is t, then restarts all connections."
+ (interactive "P")
+ (cider-ensure-connected)
+ (if restart-all
+ (dolist (conn cider-connections)
+ (cider--restart-connection conn))
+ (cider--restart-connection (cider-current-connection))))
+
+(defvar cider--namespace-history nil
+ "History of user input for namespace prompts.")
+
+(defun cider--var-namespace (var)
+ "Return the namespace of VAR.
+VAR is a fully qualified Clojure variable name as a string."
+ (replace-regexp-in-string "\\(?:#'\\)?\\(.*\\)/.*" "\\1" var))
+
+(defun cider-load-all-project-ns ()
+ "Load all namespaces in the current project."
+ (interactive)
+ (cider-ensure-connected)
+ (cider-ensure-op-supported "ns-load-all")
+ (when (y-or-n-p "Are you sure you want to load all namespaces in the project? ")
+ (message "Loading all project namespaces...")
+ (let ((loaded-ns-count (length (cider-sync-request:ns-load-all))))
+ (message "Loaded %d namespaces" loaded-ns-count))))
+
+(defun cider-run (&optional function)
+ "Run -main or FUNCTION, prompting for its namespace if necessary.
+With a prefix argument, prompt for function to run instead of -main."
+ (interactive (list (when current-prefix-arg (read-string "Function name: "))))
+ (cider-ensure-connected)
+ (let ((name (or function "-main")))
+ (when-let ((response (cider-nrepl-send-sync-request
+ (list "op" "ns-list-vars-by-name" "name" name))))
+ (if-let ((vars (split-string (substring (nrepl-dict-get response "var-list") 1 -1))))
+ (cider-interactive-eval
+ (if (= (length vars) 1)
+ (concat "(" (car vars) ")")
+ (let* ((completions (mapcar #'cider--var-namespace vars))
+ (def (or (car cider--namespace-history)
+ (car completions))))
+ (format "(#'%s/%s)"
+ (completing-read (format "Namespace (%s): " def)
+ completions nil t nil
+ 'cider--namespace-history def)
+ name))))
+ (user-error "No %s var defined in any namespace" (cider-propertize name 'fn))))))
+
+(provide 'cider-interaction)
+
+;;; cider-interaction.el ends here
--- /dev/null
+;;; cider-macroexpansion.el --- Macro expansion support -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Macro expansion support.
+
+;;; Code:
+
+(require 'cider-mode)
+(require 'subr-x)
+(require 'cider-compat)
+
+(defconst cider-macroexpansion-buffer "*cider-macroexpansion*")
+
+(push cider-macroexpansion-buffer cider-ancillary-buffers)
+
+(defcustom cider-macroexpansion-display-namespaces 'tidy
+ "Determines if namespaces are displayed in the macroexpansion buffer.
+Possible values are:
+
+ 'qualified ;=> Vars are fully-qualified in the expansion
+ 'none ;=> Vars are displayed without namespace qualification
+ 'tidy ;=> Vars that are :refer-ed or defined in the current namespace are
+ displayed with their simple name, non-refered vars from other
+ namespaces are refered using the alias for that namespace (if
+ defined), other vars are displayed fully qualified."
+ :type '(choice (const :tag "Suppress namespaces" none)
+ (const :tag "Show fully-qualified namespaces" qualified)
+ (const :tag "Show namespace aliases" tidy))
+ :group 'cider
+ :package-version '(cider . "0.7.0"))
+
+(defcustom cider-macroexpansion-print-metadata nil
+ "Determines if metadata is included in macroexpansion results."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defun cider-sync-request:macroexpand (expander expr &optional display-namespaces)
+ "Macroexpand, using EXPANDER, the given EXPR.
+The default for DISPLAY-NAMESPACES is taken from
+`cider-macroexpansion-display-namespaces'."
+ (cider-ensure-op-supported "macroexpand")
+ (thread-first (list "op" "macroexpand"
+ "expander" expander
+ "code" expr
+ "ns" (cider-current-ns)
+ "display-namespaces"
+ (or display-namespaces
+ (symbol-name cider-macroexpansion-display-namespaces)))
+ (append (when cider-macroexpansion-print-metadata
+ (list "print-meta" "true")))
+ (cider-nrepl-send-sync-request)
+ (nrepl-dict-get "expansion")))
+
+(defun cider-macroexpand-undo (&optional arg)
+ "Undo the last macroexpansion, using `undo-only'.
+ARG is passed along to `undo-only'."
+ (interactive)
+ (let ((inhibit-read-only t))
+ (undo-only arg)))
+
+(defvar cider-last-macroexpand-expression nil
+ "Specify the last macroexpansion preformed.
+This variable specifies both what was expanded and the expander.")
+
+(defun cider-macroexpand-expr (expander expr)
+ "Macroexpand, use EXPANDER, the given EXPR."
+ (when-let ((expansion (cider-sync-request:macroexpand expander expr)))
+ (setq cider-last-macroexpand-expression expr)
+ (cider-initialize-macroexpansion-buffer expansion (cider-current-ns))))
+
+(defun cider-macroexpand-expr-inplace (expander)
+ "Substitute the form preceding point with its macroexpansion using EXPANDER."
+ (interactive)
+ (let* ((expansion (cider-sync-request:macroexpand expander (cider-last-sexp)))
+ (bounds (cons (save-excursion (clojure-backward-logical-sexp 1) (point)) (point))))
+ (cider-redraw-macroexpansion-buffer
+ expansion (current-buffer) (car bounds) (cdr bounds))))
+
+(defun cider-macroexpand-again ()
+ "Repeat the last macroexpansion."
+ (interactive)
+ (cider-initialize-macroexpansion-buffer cider-last-macroexpand-expression (cider-current-ns)))
+
+;;;###autoload
+(defun cider-macroexpand-1 (&optional prefix)
+ "Invoke \\=`macroexpand-1\\=` on the expression preceding point.
+If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of
+\\=`macroexpand-1\\=`."
+ (interactive "P")
+ (let ((expander (if prefix "macroexpand" "macroexpand-1")))
+ (cider-macroexpand-expr expander (cider-last-sexp))))
+
+(defun cider-macroexpand-1-inplace (&optional prefix)
+ "Perform inplace \\=`macroexpand-1\\=` on the expression preceding point.
+If invoked with a PREFIX argument, use \\=`macroexpand\\=` instead of
+\\=`macroexpand-1\\=`."
+ (interactive "P")
+ (let ((expander (if prefix "macroexpand" "macroexpand-1")))
+ (cider-macroexpand-expr-inplace expander)))
+
+;;;###autoload
+(defun cider-macroexpand-all ()
+ "Invoke \\=`clojure.walk/macroexpand-all\\=` on the expression preceding point."
+ (interactive)
+ (cider-macroexpand-expr "macroexpand-all" (cider-last-sexp)))
+
+(defun cider-macroexpand-all-inplace ()
+ "Perform inplace \\=`clojure.walk/macroexpand-all\\=` on the expression preceding point."
+ (interactive)
+ (cider-macroexpand-expr-inplace "macroexpand-all"))
+
+(defun cider-initialize-macroexpansion-buffer (expansion ns)
+ "Create a new Macroexpansion buffer with EXPANSION and namespace NS."
+ (pop-to-buffer (cider-create-macroexpansion-buffer))
+ (setq cider-buffer-ns ns)
+ (setq buffer-undo-list nil)
+ (let ((inhibit-read-only t)
+ (buffer-undo-list t))
+ (erase-buffer)
+ (insert (format "%s" expansion))
+ (goto-char (point-max))
+ (cider--font-lock-ensure)))
+
+(defun cider-redraw-macroexpansion-buffer (expansion buffer start end)
+ "Redraw the macroexpansion with new EXPANSION.
+Text in BUFFER from START to END is replaced with new expansion,
+and point is placed after the expanded form."
+ (with-current-buffer buffer
+ (let ((buffer-read-only nil))
+ (goto-char start)
+ (delete-region start end)
+ (insert (format "%s" expansion))
+ (goto-char start)
+ (indent-sexp)
+ (forward-sexp))))
+
+(declare-function cider-mode "cider-mode")
+
+(defun cider-create-macroexpansion-buffer ()
+ "Create a new macroexpansion buffer."
+ (with-current-buffer (cider-popup-buffer cider-macroexpansion-buffer t)
+ (clojure-mode)
+ (cider-mode -1)
+ (cider-macroexpansion-mode 1)
+ (current-buffer)))
+
+(defvar cider-macroexpansion-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "g") #'cider-macroexpand-again)
+ (define-key map (kbd "q") #'cider-popup-buffer-quit-function)
+ (define-key map (kbd "d") #'cider-doc)
+ (define-key map (kbd "j") #'cider-javadoc)
+ (define-key map (kbd ".") #'cider-find-var)
+ (define-key map (kbd "m") #'cider-macroexpand-1-inplace)
+ (define-key map (kbd "a") #'cider-macroexpand-all-inplace)
+ (define-key map (kbd "u") #'cider-macroexpand-undo)
+ (define-key map [remap undo] #'cider-macroexpand-undo)
+ (easy-menu-define cider-macroexpansion-mode-menu map
+ "Menu for CIDER's doc mode"
+ '("Macroexpansion"
+ ["Restart expansion" cider-macroexpand-again]
+ ["Macroexpand-1" cider-macroexpand-1-inplace]
+ ["Macroexpand-all" cider-macroexpand-all-inplace]
+ ["Macroexpand-undo" cider-macroexpand-undo]
+ ["Go to source" cider-find-var]
+ ["Go to doc" cider-doc]
+ ["Go to Javadoc" cider-docview-javadoc]
+ ["Quit" cider-popup-buffer-quit-function]))
+ map))
+
+(define-minor-mode cider-macroexpansion-mode
+ "Minor mode for CIDER macroexpansion.
+
+\\{cider-macroexpansion-mode-map}"
+ nil
+ " Macroexpand"
+ cider-macroexpansion-mode-map)
+
+(provide 'cider-macroexpansion)
+
+;;; cider-macroexpansion.el ends here
--- /dev/null
+;;; cider-mode.el --- Minor mode for REPL interactions -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Minor mode for REPL interactions.
+
+;;; Code:
+
+(require 'clojure-mode)
+(require 'cider-interaction)
+(require 'cider-test)
+(require 'cider-eldoc)
+(require 'cider-resolve)
+(require 'cider-doc)
+(require 'subr-x)
+(require 'cider-compat)
+
+(defcustom cider-mode-line-show-connection t
+ "If the mode-line lighter should detail the connection."
+ :group 'cider
+ :type 'boolean
+ :package-version '(cider "0.10.0"))
+
+(defun cider--modeline-info ()
+ "Return info for the `cider-mode' modeline.
+
+Info contains project name and host:port endpoint."
+ (if-let ((current-connection (ignore-errors (cider-current-connection))))
+ (with-current-buffer current-connection
+ (concat
+ cider-repl-type
+ (when cider-mode-line-show-connection
+ (format ":%s@%s:%s"
+ (or (cider--project-name nrepl-project-dir) "<no project>")
+ (pcase (car nrepl-endpoint)
+ ("localhost" "")
+ (x x))
+ (cadr nrepl-endpoint)))))
+ "not connected"))
+
+;;;###autoload
+(defcustom cider-mode-line
+ '(:eval (format " cider[%s]" (cider--modeline-info)))
+ "Mode line lighter for `cider-mode'.
+
+The value of this variable is a mode line template as in
+`mode-line-format'. See Info Node `(elisp)Mode Line Format' for
+details about mode line templates.
+
+Customize this variable to change how `cider-mode' displays its
+status in the mode line. The default value displays the current connection.
+Set this variable to nil to disable the mode line
+entirely."
+ :group 'cider
+ :type 'sexp
+ :risky t
+ :package-version '(cider "0.7.0"))
+
+\f
+;;; Switching between REPL & source buffers
+(defvar-local cider-last-clojure-buffer nil
+ "A buffer-local variable holding the last Clojure source buffer.
+`cider-switch-to-last-clojure-buffer' uses this variable to jump
+back to last Clojure source buffer.")
+
+(defun cider-remember-clojure-buffer (buffer)
+ "Try to remember the BUFFER from which the user jumps.
+The BUFFER needs to be a Clojure buffer and current major mode needs
+to be `cider-repl-mode'. The user can use `cider-switch-to-last-clojure-buffer'
+to jump back to the last Clojure source buffer."
+ (when (and buffer
+ (with-current-buffer buffer
+ (derived-mode-p 'clojure-mode))
+ (derived-mode-p 'cider-repl-mode))
+ (setq cider-last-clojure-buffer buffer)))
+
+(defun cider--switch-to-repl-buffer (repl-buffer &optional set-namespace)
+ "Select the REPL-BUFFER, when possible in an existing window.
+
+Hint: You can use `display-buffer-reuse-frames' and
+`special-display-buffer-names' to customize the frame in which
+the buffer should appear.
+
+When SET-NAMESPACE is t, sets the namespace in the REPL buffer to
+that of the namespace in the Clojure source buffer."
+ (cider-ensure-connected)
+ (let ((buffer (current-buffer)))
+ ;; first we switch to the REPL buffer
+ (if cider-repl-display-in-current-window
+ (pop-to-buffer-same-window repl-buffer)
+ (pop-to-buffer repl-buffer))
+ ;; then if necessary we update its namespace
+ (when set-namespace
+ (cider-repl-set-ns (with-current-buffer buffer (cider-current-ns))))
+ (cider-remember-clojure-buffer buffer)
+ (goto-char (point-max))))
+
+(defun cider-switch-to-repl-buffer (&optional set-namespace)
+ "Select the REPL buffer, when possible in an existing window.
+The buffer chosen is based on the file open in the current buffer.
+
+If the REPL buffer cannot be unambiguously determined, the REPL
+buffer is chosen based on the current connection buffer and a
+message raised informing the user.
+
+Hint: You can use `display-buffer-reuse-frames' and
+`special-display-buffer-names' to customize the frame in which
+the buffer should appear.
+
+With a prefix arg SET-NAMESPACE sets the namespace in the REPL buffer to that
+of the namespace in the Clojure source buffer."
+ (interactive "P")
+ (cider--switch-to-repl-buffer (cider-current-repl-buffer) set-namespace))
+
+(declare-function cider-load-buffer "cider-interaction")
+
+(defun cider-load-buffer-and-switch-to-repl-buffer (&optional set-namespace)
+ "Load the current buffer into the matching REPL buffer and switch to it.
+When SET-NAMESPACE is true, we'll also set the REPL's ns to match that of the
+Clojure buffer."
+ (interactive "P")
+ (cider-load-buffer)
+ (cider-switch-to-repl-buffer set-namespace))
+
+(defun cider-switch-to-last-clojure-buffer ()
+ "Switch to the last Clojure buffer.
+The default keybinding for this command is
+the same as `cider-switch-to-repl-buffer',
+so that it is very convenient to jump between a
+Clojure buffer and the REPL buffer."
+ (interactive)
+ (if (and (derived-mode-p 'cider-repl-mode)
+ (buffer-live-p cider-last-clojure-buffer))
+ (if cider-repl-display-in-current-window
+ (pop-to-buffer-same-window cider-last-clojure-buffer)
+ (pop-to-buffer cider-last-clojure-buffer))
+ (message "Don't know the original Clojure buffer")))
+
+(defun cider-find-and-clear-repl-output (&optional clear-repl)
+ "Find the current REPL buffer and clear it.
+With a prefix argument CLEAR-REPL the command clears the entire REPL buffer.
+Returns to the buffer in which the command was invoked."
+ (interactive "P")
+ (let ((origin-buffer (current-buffer)))
+ (switch-to-buffer (cider-current-repl-buffer))
+ (if clear-repl
+ (cider-repl-clear-buffer)
+ (cider-repl-clear-output))
+ (switch-to-buffer origin-buffer)))
+
+\f
+;;; The menu-bar
+(defconst cider-mode-menu
+ `("CIDER"
+ ["Start a REPL" cider-jack-in
+ :help "Starts an nREPL server (with lein, boot, or maven) and connects a REPL to it."]
+ ["Connect to a REPL" cider-connect
+ :help "Connects to a REPL that's already running."]
+ ["Quit" cider-quit :active cider-connections]
+ ["Restart" cider-restart :active cider-connections]
+ ("Clojurescript"
+ ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clojurescript
+ :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL.
+Configure `cider-cljs-*-repl' to change the ClojureScript REPL to use for your build tool."]
+ ["Create a ClojureScript REPL from a Clojure REPL" cider-create-sibling-cljs-repl]
+ ["Form for launching a ClojureScript REPL via Leiningen" (customize-variable 'cider-cljs-lein-repl)]
+ ["Form for launching a ClojureScript REPL via Boot" (customize-variable 'cider-cljs-boot-repl)]
+ ["Form for launching a ClojureScript REPL via Gradle" (customize-variable 'cider-cljs-gradle-repl)])
+ "--"
+ ["Connection info" cider-display-connection-info
+ :active cider-connections]
+ ["Rotate default connection" cider-rotate-default-connection
+ :active (cdr cider-connections)]
+ ["Select any CIDER buffer" cider-selector]
+ "--"
+ ["Configure CIDER" (customize-group 'cider)]
+ "--"
+ ["A sip of CIDER" cider-drink-a-sip]
+ ["View manual online" cider-view-manual]
+ ["View refcard online" cider-view-refcard]
+ ["Report a bug" cider-report-bug]
+ ["Version info" cider-version]
+ "--"
+ ["Close ancillary buffers" cider-close-ancillary-buffers
+ :active (seq-remove #'null cider-ancillary-buffers)]
+ ("nREPL" :active cider-connections
+ ["Describe session" cider-describe-nrepl-session]
+ ["Close session" cider-close-nrepl-session]
+ ["Toggle message logging" nrepl-toggle-message-logging]))
+ "Menu for CIDER mode")
+
+(defconst cider-mode-eval-menu
+ '("CIDER Eval" :visible cider-connections
+ ["Eval top-level sexp" cider-eval-defun-at-point]
+ ["Eval current sexp" cider-eval-sexp-at-point]
+ ["Eval last sexp" cider-eval-last-sexp]
+ ["Eval selected region" cider-eval-region]
+ ["Eval ns form" cider-eval-ns-form]
+ "--"
+ ["Interrupt evaluation" cider-interrupt]
+ "--"
+ ["Eval last sexp and insert" cider-eval-print-last-sexp
+ :keys "\\[universal-argument] \\[cider-eval-last-sexp]"]
+ ["Eval last sexp in popup buffer" cider-pprint-eval-last-sexp]
+ ["Eval last sexp and replace" cider-eval-last-sexp-and-replace]
+ ["Eval last sexp to REPL" cider-eval-last-sexp-to-repl]
+ ["Eval last sexp and pretty-print to REPL" cider-pprint-eval-last-sexp-to-repl]
+ ["Insert last sexp in REPL" cider-insert-last-sexp-in-repl]
+ ["Eval top-level sexp to comment" cider-eval-defun-to-comment]
+ "--"
+ ["Load this buffer" cider-load-buffer]
+ ["Load another file" cider-load-file]
+ ["Load all project files" cider-load-all-project-ns]
+ ["Refresh loaded code" cider-refresh]
+ ["Run project (-main function)" cider-run])
+ "Menu for CIDER mode eval commands.")
+
+(defconst cider-mode-interactions-menu
+ `("CIDER Interactions" :visible cider-connections
+ ["Complete symbol" complete-symbol]
+ "--"
+ ("REPL"
+ ["Set REPL to this ns" cider-repl-set-ns]
+ ["Switch to REPL" cider-switch-to-repl-buffer]
+ ["REPL Pretty Print" cider-repl-toggle-pretty-printing
+ :style toggle :selected cider-repl-use-pretty-printing]
+ ["Clear latest output" cider-find-and-clear-repl-output]
+ ["Clear all output" (cider-find-and-clear-repl-output t)
+ :keys "\\[universal-argument] \\[cider-find-and-clear-repl-output]"]
+ "--"
+ ["Configure the REPL" (customize-group 'cider-repl)])
+ ,cider-doc-menu
+ ("Find (jump to)"
+ ["Find definition" cider-find-var]
+ ["Find resource" cider-find-resource]
+ ["Go back" cider-pop-back])
+ ("Macroexpand"
+ ["Macroexpand-1" cider-macroexpand-1]
+ ["Macroexpand-all" cider-macroexpand-all])
+ ,cider-test-menu
+ ("Debug"
+ ["Inspect" cider-inspect]
+ ["Toggle var tracing" cider-toggle-trace-var]
+ ["Toggle ns tracing" cider-toggle-trace-ns]
+ "--"
+ ["Debug top-level form" cider-debug-defun-at-point
+ :keys "\\[universal-argument] \\[cider-eval-defun-at-point]"]
+ ["List instrumented defs" cider-browse-instrumented-defs]
+ "--"
+ ["Configure the Debugger" (customize-group 'cider-debug)])
+ ("Browse"
+ ["Browse namespace" cider-browse-ns]
+ ["Browse all namespaces" cider-browse-ns-all]
+ ["Browse REPL input history" cider-repl-history]
+ ["Browse classpath" cider-classpath]
+ ["Browse classpath entry" cider-open-classpath-entry]))
+ "Menu for CIDER interactions.")
+
+(defconst cider-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c C-d") 'cider-doc-map)
+ (define-key map (kbd "M-.") #'cider-find-var)
+ (define-key map (kbd "C-c C-.") #'cider-find-ns)
+ (define-key map (kbd "M-,") #'cider-pop-back)
+ (define-key map (kbd "C-c M-.") #'cider-find-resource)
+ (define-key map (kbd "M-TAB") #'complete-symbol)
+ (define-key map (kbd "C-M-x") #'cider-eval-defun-at-point)
+ (define-key map (kbd "C-c C-c") #'cider-eval-defun-at-point)
+ (define-key map (kbd "C-x C-e") #'cider-eval-last-sexp)
+ (define-key map (kbd "C-c C-e") #'cider-eval-last-sexp)
+ (define-key map (kbd "C-c C-v") 'cider-eval-commands-map)
+ (define-key map (kbd "C-c M-;") #'cider-eval-defun-to-comment)
+ (define-key map (kbd "C-c M-e") #'cider-eval-last-sexp-to-repl)
+ (define-key map (kbd "C-c M-p") #'cider-insert-last-sexp-in-repl)
+ (define-key map (kbd "C-c C-p") #'cider-pprint-eval-last-sexp)
+ (define-key map (kbd "C-c C-f") #'cider-pprint-eval-defun-at-point)
+ (define-key map (kbd "C-c M-:") #'cider-read-and-eval)
+ (define-key map (kbd "C-c C-u") #'cider-undef)
+ (define-key map (kbd "C-c C-m") #'cider-macroexpand-1)
+ (define-key map (kbd "C-c M-m") #'cider-macroexpand-all)
+ (define-key map (kbd "C-c M-n") #'cider-repl-set-ns)
+ (define-key map (kbd "C-c M-i") #'cider-inspect)
+ (define-key map (kbd "C-c M-t v") #'cider-toggle-trace-var)
+ (define-key map (kbd "C-c M-t n") #'cider-toggle-trace-ns)
+ (define-key map (kbd "C-c C-z") #'cider-switch-to-repl-buffer)
+ (define-key map (kbd "C-c M-z") #'cider-load-buffer-and-switch-to-repl-buffer)
+ (define-key map (kbd "C-c C-o") #'cider-find-and-clear-repl-output)
+ (define-key map (kbd "C-c C-k") #'cider-load-buffer)
+ (define-key map (kbd "C-c C-l") #'cider-load-file)
+ (define-key map (kbd "C-c C-b") #'cider-interrupt)
+ (define-key map (kbd "C-c ,") 'cider-test-commands-map)
+ (define-key map (kbd "C-c C-t") 'cider-test-commands-map)
+ (define-key map (kbd "C-c M-s") #'cider-selector)
+ (define-key map (kbd "C-c M-r") #'cider-rotate-default-connection)
+ (define-key map (kbd "C-c M-d") #'cider-display-connection-info)
+ (define-key map (kbd "C-c C-x") #'cider-refresh)
+ (define-key map (kbd "C-c C-q") #'cider-quit)
+ (dolist (variable '(cider-mode-interactions-menu
+ cider-mode-eval-menu
+ cider-mode-menu))
+ (easy-menu-do-define (intern (format "%s-open" variable))
+ map
+ (get variable 'variable-documentation)
+ (cider--menu-add-help-strings (symbol-value variable))))
+ map))
+
+;; This menu works as an easy entry-point into CIDER. Even if cider.el isn't
+;; loaded yet, this will be shown in Clojure buffers next to the "Clojure"
+;; menu.
+;;;###autoload
+(eval-after-load 'clojure-mode
+ '(easy-menu-define cider-clojure-mode-menu-open clojure-mode-map
+ "Menu for Clojure mode.
+ This is displayed in `clojure-mode' buffers, if `cider-mode' is not active."
+ `("CIDER" :visible (not cider-mode)
+ ["Start a REPL" cider-jack-in
+ :help "Starts an nREPL server (with lein, boot, or maven) and connects a REPL to it."]
+ ["Connect to a REPL" cider-connect
+ :help "Connects to a REPL that's already running."]
+ ["Start a Clojure REPL, and a ClojureScript REPL" cider-jack-in-clojurescript
+ :help "Starts an nREPL server, connects a Clojure REPL to it, and then a ClojureScript REPL.
+ Configure `cider-cljs-lein-repl', `cider-cljs-boot-repl' and `cider-cljs-gradle-repl' to change the ClojureScript REPL to use."]
+ "--"
+ ["View manual online" cider-view-manual])))
+
+;;; Dynamic indentation
+(defcustom cider-dynamic-indentation t
+ "Whether CIDER should aid Clojure(Script) indentation.
+If non-nil, CIDER uses runtime information (such as the \":style/indent\"
+metadata) to improve standard `clojure-mode' indentation.
+If nil, CIDER won't interfere with `clojure-mode's indentation.
+
+Toggling this variable only takes effect after a file is closed and
+re-visited."
+ :type 'boolean
+ :package-version '(cider . "0.11.0")
+ :group 'cider)
+
+(defun cider--get-symbol-indent (symbol-name)
+ "Return the indent metadata for SYMBOL-NAME in the current namespace."
+ (let* ((ns (cider-current-ns)))
+ (if-let ((meta (cider-resolve-var ns symbol-name))
+ (indent (or (nrepl-dict-get meta "style/indent")
+ (nrepl-dict-get meta "indent"))))
+ (let ((format (format ":indent metadata on ‘%s’ is unreadable! \nERROR: %%s"
+ symbol-name)))
+ (with-demoted-errors format
+ (cider--deep-vector-to-list (read indent))))
+ ;; There's no indent metadata, but there might be a clojure-mode
+ ;; indent-spec with fully-qualified namespace.
+ (when (string-match cider-resolve--prefix-regexp symbol-name)
+ (when-let ((sym (intern-soft (replace-match (save-match-data
+ (cider-resolve-alias ns (match-string 1 symbol-name)))
+ t t symbol-name 1))))
+ (get sym 'clojure-indent-function))))))
+
+\f
+;;; Dynamic font locking
+(defcustom cider-font-lock-dynamically '(macro core deprecated)
+ "Specifies how much dynamic font-locking CIDER should use.
+Dynamic font-locking this refers to applying syntax highlighting to vars
+defined in the currently active nREPL connection. This is done in addition
+to `clojure-mode's usual (static) font-lock, so even if you set this
+variable to nil you'll still see basic syntax highlighting.
+
+The value is a list of symbols, each one indicates a different type of var
+that should be font-locked:
+ `macro' (default): Any defined macro gets the `font-lock-builtin-face'.
+ `function': Any defined function gets the `font-lock-function-face'.
+ `var': Any non-local var gets the `font-lock-variable-face'.
+ `deprecated' (default): Any deprecated var gets the `cider-deprecated-face'
+ face.
+ `core' (default): Any symbol from clojure.core (face depends on type).
+
+The value can also be t, which means to font-lock as much as possible."
+ :type '(choice (set :tag "Fine-tune font-locking"
+ (const :tag "Any defined macro" macro)
+ (const :tag "Any defined function" function)
+ (const :tag "Any defined var" var)
+ (const :tag "Any defined deprecated" deprecated)
+ (const :tag "Any symbol from clojure.core" core))
+ (const :tag "Font-lock as much as possible" t))
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-font-lock-reader-conditionals t
+ "Apply font-locking to unused reader conditional expressions depending on the buffer CIDER connection type."
+ :type 'boolean
+ :group 'cider
+ :package-version '(cider . "0.15.0"))
+
+(defface cider-deprecated-face
+ '((((background light)) :background "light goldenrod")
+ (((background dark)) :background "#432"))
+ "Face used on deprecated vars."
+ :group 'cider)
+
+(defface cider-instrumented-face
+ '((((type graphic)) :box (:color "#c00" :line-width -1))
+ (t :underline t :background "#800"))
+ "Face used to mark code being debugged."
+ :group 'cider-debug
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defface cider-traced-face
+ '((((type graphic)) :box (:color "cyan" :line-width -1))
+ (t :underline t :background "#066"))
+ "Face used to mark code being traced."
+ :group 'cider
+ :package-version '(cider . "0.11.0"))
+
+(defface cider-reader-conditional-face
+ '((t (:inherit font-lock-comment-face)))
+ "Face used to mark unused reader conditional expressions."
+ :group 'cider
+ :package-version '(cider . "0.15.0"))
+
+(defconst cider-reader-conditionals-regexp "\\(?:#\\?@?[[:space:]\n]*(\\)"
+ "Regexp for matching reader conditionals with a non-capturing group.
+
+Starts from the reader macro characters to the opening parentheses.")
+
+(defvar cider--reader-conditionals-match-data (list nil nil)
+ "Reusable list for `match-data` in reader conditionals font lock matchers.")
+
+(defun cider--search-reader-conditionals (limit)
+ "Matcher for finding reader conditionals.
+
+Search is done with the given LIMIT."
+ (when (and cider-font-lock-reader-conditionals
+ (cider-connected-p))
+ (when (search-forward-regexp cider-reader-conditionals-regexp limit t)
+ (let ((start (match-beginning 0))
+ (state (syntax-ppss)))
+ (if (or (nth 3 state) (nth 4 state)) ; inside string or comment?
+ (cider--search-reader-conditionals limit)
+ (when (<= (point) limit)
+ (ignore-errors
+ (let ((md (match-data nil cider--reader-conditionals-match-data)))
+ (setf (nth 0 md) start)
+ (setf (nth 1 md) (point))
+ (set-match-data md)
+ t))))))))
+
+(defun cider--anchored-search-suppressed-forms-internal (limit)
+ "Helper function for `cider--anchored-search-suppressed-forms`.
+
+LIMIT is the same as the LIMIT in `cider--anchored-search-suppressed-forms`"
+ (let ((expr (read (current-buffer)))
+ (start (save-excursion (backward-sexp) (point))))
+ (when (<= (point) limit)
+ (forward-sexp)
+ (if (not (string-equal (symbol-name expr) (concat ":" (cider-connection-type-for-buffer))))
+ (ignore-errors
+ (cl-assert (<= (point) limit))
+ (let ((md (match-data nil cider--reader-conditionals-match-data)))
+ (setf (nth 0 md) start)
+ (setf (nth 1 md) (point))
+ (set-match-data md)
+ t))
+ (cider--anchored-search-suppressed-forms-internal limit)))))
+
+(defun cider--anchored-search-suppressed-forms (limit)
+ "Matcher for finding unused reader conditional expressions.
+
+An unused reader conditional expression is an expression for a platform
+that does not match the CIDER connection for the buffer. Search is done
+with the given LIMIT."
+ (let ((result 'retry))
+ (while (and (eq result 'retry) (<= (point) limit))
+ (condition-case condition
+ (setq result (cider--anchored-search-suppressed-forms-internal limit))
+ (invalid-read-syntax
+ (setq result 'retry))
+ (wrong-type-argument
+ (setq result 'retry))
+ (scan-error
+ (setq result 'retry))
+ (end-of-file
+ (setq result nil))
+ (error
+ (setq result nil)
+ (display-warning
+ '(cider warning)
+ (format
+ (concat "Caught error during fontification while searching for forms\n"
+ "that are suppressed by reader-conditionals. The error was: %S.")
+ condition)))))
+ (if (eq result 'retry) (setq result nil))
+ result))
+
+(defconst cider--reader-conditionals-font-lock-keywords
+ '((cider--search-reader-conditionals
+ (cider--anchored-search-suppressed-forms
+ (save-excursion
+ (let* ((state (syntax-ppss))
+ (list-pt (nth 1 state)))
+ (when list-pt
+ (goto-char list-pt)
+ (forward-list)
+ (backward-char)
+ (point))))
+ nil
+ (0 'cider-reader-conditional-face t))))
+ "Font Lock keywords for unused reader conditionals in CIDER mode.")
+
+(defun cider--unless-local-match (value)
+ "Return VALUE, unless `match-string' is a local var."
+ (unless (or (get-text-property (point) 'cider-block-dynamic-font-lock)
+ (member (match-string 0)
+ (get-text-property (point) 'cider-locals)))
+ value))
+
+(defun cider--compile-font-lock-keywords (symbols-plist core-plist)
+ "Return a list of font-lock rules for the symbols in SYMBOLS-PLIST and CORE-PLIST."
+ (let ((cider-font-lock-dynamically (if (eq cider-font-lock-dynamically t)
+ '(function var macro core deprecated)
+ cider-font-lock-dynamically))
+ deprecated enlightened
+ macros functions vars instrumented traced)
+ (cl-labels ((handle-plist
+ (plist)
+ (let ((do-function (memq 'function cider-font-lock-dynamically))
+ (do-var (memq 'var cider-font-lock-dynamically))
+ (do-macro (memq 'macro cider-font-lock-dynamically))
+ (do-deprecated (memq 'deprecated cider-font-lock-dynamically)))
+ (while plist
+ (let ((sym (pop plist))
+ (meta (pop plist)))
+ (pcase (nrepl-dict-get meta "cider.nrepl.middleware.util.instrument/breakfunction")
+ (`nil nil)
+ (`"#'cider.nrepl.middleware.debug/breakpoint-if-interesting"
+ (push sym instrumented))
+ (`"#'cider.nrepl.middleware.enlighten/light-form"
+ (push sym enlightened)))
+ ;; The ::traced keywords can be inlined by MrAnderson, so
+ ;; we catch that case too.
+ ;; FIXME: This matches values too, not just keys.
+ (when (seq-find (lambda (k) (and (stringp k)
+ (string-match (rx "clojure.tools.trace/traced" eos) k)))
+ meta)
+ (push sym traced))
+ (when (and do-deprecated (nrepl-dict-get meta "deprecated"))
+ (push sym deprecated))
+ (cond ((and do-macro (nrepl-dict-get meta "macro"))
+ (push sym macros))
+ ((and do-function (nrepl-dict-get meta "arglists"))
+ (push sym functions))
+ (do-var (push sym vars))))))))
+ (when (memq 'core cider-font-lock-dynamically)
+ (let ((cider-font-lock-dynamically '(function var macro core deprecated)))
+ (handle-plist core-plist)))
+ (handle-plist symbols-plist))
+ `(
+ ,@(when macros
+ `((,(concat (rx (or "(" "#'")) ; Can't take the value of macros.
+ "\\(" (regexp-opt macros 'symbols) "\\)")
+ 1 (cider--unless-local-match font-lock-keyword-face))))
+ ,@(when functions
+ `((,(regexp-opt functions 'symbols) 0
+ (cider--unless-local-match font-lock-function-name-face))))
+ ,@(when vars
+ `((,(regexp-opt vars 'symbols) 0
+ (cider--unless-local-match font-lock-variable-name-face))))
+ ,@(when deprecated
+ `((,(regexp-opt deprecated 'symbols) 0
+ (cider--unless-local-match 'cider-deprecated-face) append)))
+ ,@(when enlightened
+ `((,(regexp-opt enlightened 'symbols) 0
+ (cider--unless-local-match 'cider-enlightened-face) append)))
+ ,@(when instrumented
+ `((,(regexp-opt instrumented 'symbols) 0
+ (cider--unless-local-match 'cider-instrumented-face) append)))
+ ,@(when traced
+ `((,(regexp-opt traced 'symbols) 0
+ (cider--unless-local-match 'cider-traced-face) append))))))
+
+(defconst cider--static-font-lock-keywords
+ (eval-when-compile
+ `((,(regexp-opt '("#break" "#dbg" "#light") 'symbols) 0 font-lock-warning-face)))
+ "Default expressions to highlight in CIDER mode.")
+
+(defvar-local cider--dynamic-font-lock-keywords nil)
+
+(defun cider-refresh-dynamic-font-lock (&optional ns)
+ "Ensure that the current buffer has up-to-date font-lock rules.
+NS defaults to `cider-current-ns', and it can also be a dict describing the
+namespace itself."
+ (interactive)
+ (when (and cider-font-lock-dynamically
+ font-lock-mode)
+ (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords)
+ (when-let ((ns (or ns (cider-current-ns)))
+ (symbols (cider-resolve-ns-symbols ns)))
+ (setq-local cider--dynamic-font-lock-keywords
+ (cider--compile-font-lock-keywords
+ symbols (cider-resolve-ns-symbols (cider-resolve-core-ns))))
+ (font-lock-add-keywords nil cider--dynamic-font-lock-keywords 'end))
+ (cider--font-lock-flush)))
+
+\f
+;;; Detecting local variables
+(defun cider--read-locals-from-next-sexp ()
+ "Return a list of all locals inside the next logical sexp."
+ (save-excursion
+ (ignore-errors
+ (clojure-forward-logical-sexp 1)
+ (let ((out nil)
+ (end (point)))
+ (forward-sexp -1)
+ ;; FIXME: This returns locals found inside the :or clause of a
+ ;; destructuring map.
+ (while (search-forward-regexp "\\_<[^:&]\\(\\sw\\|\\s_\\)*\\_>" end 'noerror)
+ (push (match-string-no-properties 0) out))
+ out))))
+
+(defun cider--read-locals-from-bindings-vector ()
+ "Return a list of all locals inside the next bindings vector."
+ (save-excursion
+ (ignore-errors
+ (cider-start-of-next-sexp)
+ (when (eq (char-after) ?\[)
+ (forward-char 1)
+ (let ((out nil))
+ (setq out (append (cider--read-locals-from-next-sexp) out))
+ (while (ignore-errors (clojure-forward-logical-sexp 3)
+ (unless (eobp)
+ (forward-sexp -1)
+ t))
+ (setq out (append (cider--read-locals-from-next-sexp) out)))
+ out)))))
+
+(defun cider--read-locals-from-arglist ()
+ "Return a list of all locals in current form's arglist(s)."
+ (let ((out nil))
+ (save-excursion
+ (ignore-errors
+ (cider-start-of-next-sexp)
+ ;; Named fn
+ (when (looking-at-p "\\s_\\|\\sw")
+ (cider-start-of-next-sexp 1))
+ ;; Docstring
+ (when (eq (char-after) ?\")
+ (cider-start-of-next-sexp 1))
+ ;; Attribute map
+ (when (eq (char-after) ?{)
+ (cider-start-of-next-sexp 1))
+ ;; The arglist
+ (pcase (char-after)
+ (?\[ (setq out (cider--read-locals-from-next-sexp)))
+ ;; FIXME: This returns false positives. It takes all arglists of a
+ ;; function and returns all args it finds. The logic should be changed
+ ;; so that each arglist applies to its own scope.
+ (?\( (ignore-errors
+ (while (eq (char-after) ?\()
+ (save-excursion
+ (forward-char 1)
+ (setq out (append (cider--read-locals-from-next-sexp) out)))
+ (cider-start-of-next-sexp 1)))))))
+ out))
+
+(defun cider--parse-and-apply-locals (end &optional outer-locals)
+ "Figure out local variables between point and END.
+A list of these variables is set as the `cider-locals' text property over
+the code where they are in scope.
+Optional argument OUTER-LOCALS is used to specify local variables defined
+before point."
+ (while (search-forward-regexp "(\\(ns\\_>\\|def\\|fn\\|for\\b\\|loop\\b\\|with-\\|do[a-z]+\\|\\([a-z]+-\\)?let\\b\\)"
+ end 'noerror)
+ (goto-char (match-beginning 0))
+ (let ((sym (match-string 1))
+ (sexp-end (save-excursion
+ (or (ignore-errors (forward-sexp 1)
+ (point))
+ end))))
+ ;; #1324: Don't do dynamic font-lock in `ns' forms, they are special
+ ;; macros where nothing is evaluated, so we'd get a lot of false
+ ;; positives.
+ (if (equal sym "ns")
+ (add-text-properties (point) sexp-end '(cider-block-dynamic-font-lock t))
+ (forward-char 1)
+ (forward-sexp 1)
+ (let ((locals (append outer-locals
+ (pcase sym
+ ((or "fn" "def" "") (cider--read-locals-from-arglist))
+ (_ (cider--read-locals-from-bindings-vector))))))
+ (add-text-properties (point) sexp-end (list 'cider-locals locals))
+ (clojure-forward-logical-sexp 1)
+ (cider--parse-and-apply-locals sexp-end locals)))
+ (goto-char sexp-end))))
+
+(defun cider--update-locals-for-region (beg end)
+ "Update the `cider-locals' text property for region from BEG to END."
+ (save-excursion
+ (goto-char beg)
+ ;; If the inside of a `ns' form changed, reparse it from the start.
+ (when (and (not (bobp))
+ (get-text-property (1- (point)) 'cider-block-dynamic-font-lock))
+ (ignore-errors (beginning-of-defun)))
+ (save-excursion
+ ;; Move up until we reach a sexp that encloses the entire region (or
+ ;; a top-level sexp), and set that as the new BEG.
+ (goto-char end)
+ (while (and (or (> (point) beg)
+ (not (eq (char-after) ?\()))
+ (condition-case nil
+ (progn (backward-up-list) t)
+ (scan-error nil))))
+ (setq beg (min beg (point)))
+ ;; If there are locals above the current sexp, reapply them to the
+ ;; current sexp.
+ (let ((locals-above (when (> beg (point-min))
+ (get-text-property (1- beg) 'cider-locals))))
+ (condition-case nil
+ (clojure-forward-logical-sexp 1)
+ (error (goto-char end)))
+ (add-text-properties beg (point) `(cider-locals ,locals-above))
+ ;; Extend the region being font-locked to include whole sexps.
+ (setq end (max end (point)))
+ (goto-char beg)
+ (ignore-errors
+ (cider--parse-and-apply-locals end locals-above))))))
+
+(defun cider--docview-as-string (sym info)
+ "Return a string of what would be displayed by `cider-docview-render'."
+ (with-temp-buffer
+ (cider-docview-render (current-buffer) sym info)
+ (goto-char (point-max))
+ (forward-line -1)
+ (replace-regexp-in-string
+ "[`']" "\\\\=\\&"
+ (buffer-substring-no-properties (point-min) (1- (point))))))
+
+(defcustom cider-use-tooltips t
+ "If non-nil, CIDER displays mouse-over tooltips."
+ :group 'cider
+ :type 'boolean
+ :package-version '(cider "0.12.0"))
+
+(defvar cider--debug-mode-response)
+(defvar cider--debug-mode)
+
+(defun cider--help-echo (_ obj pos)
+ "Return the help-echo string for OBJ at POS.
+See \(info \"(elisp) Special Properties\")"
+ (while-no-input
+ (when (and (bufferp obj) (cider-connected-p)
+ cider-use-tooltips (not help-at-pt-display-when-idle))
+ (with-current-buffer obj
+ (ignore-errors
+ (save-excursion
+ (goto-char pos)
+ (when-let ((sym (cider-symbol-at-point)))
+ (if (member sym (get-text-property (point) 'cider-locals))
+ (concat (format "`%s' is a local" sym)
+ (when cider--debug-mode
+ (let* ((locals (nrepl-dict-get cider--debug-mode-response "locals"))
+ (local-val (cadr (assoc sym locals))))
+ (format " with value:\n%s" local-val))))
+ (let* ((info (cider-sync-request:info sym))
+ (candidates (nrepl-dict-get info "candidates")))
+ (if candidates
+ (concat "There were ambiguities resolving this symbol:\n\n"
+ (mapconcat (lambda (x) (cider--docview-as-string sym x))
+ candidates
+ (concat "\n\n" (make-string 60 ?-) "\n\n")))
+ (cider--docview-as-string sym info)))))))))))
+
+(defun cider--wrap-fontify-locals (func)
+ "Return a function that will call FUNC after parsing local variables.
+The local variables are stored in a list under the `cider-locals' text
+property."
+ (lambda (beg end &rest rest)
+ (with-silent-modifications
+ (remove-text-properties beg end '(cider-locals nil cider-block-dynamic-font-lock nil))
+ (add-text-properties beg end '(help-echo cider--help-echo))
+ (when cider-font-lock-dynamically
+ (cider--update-locals-for-region beg end)))
+ (apply func beg end rest)))
+
+\f
+;;; Minor-mode definition
+(defvar x-gtk-use-system-tooltips)
+
+;;;###autoload
+(define-minor-mode cider-mode
+ "Minor mode for REPL interaction from a Clojure buffer.
+
+\\{cider-mode-map}"
+ nil
+ cider-mode-line
+ cider-mode-map
+ (if cider-mode
+ (progn
+ (cider-eldoc-setup)
+ (make-local-variable 'completion-at-point-functions)
+ (add-to-list 'completion-at-point-functions
+ #'cider-complete-at-point)
+ (font-lock-add-keywords nil cider--static-font-lock-keywords)
+ (cider-refresh-dynamic-font-lock)
+ (font-lock-add-keywords nil cider--reader-conditionals-font-lock-keywords)
+ ;; `font-lock-mode' might get enabled after `cider-mode'.
+ (add-hook 'font-lock-mode-hook #'cider-refresh-dynamic-font-lock nil 'local)
+ (setq-local font-lock-fontify-region-function
+ (cider--wrap-fontify-locals font-lock-fontify-region-function))
+ ;; GTK tooltips look bad, and we have no control over the face.
+ (setq-local x-gtk-use-system-tooltips nil)
+ ;; `tooltip' has variable-width by default, which looks terrible.
+ (set-face-attribute 'tooltip nil :inherit 'unspecified)
+ (when cider-dynamic-indentation
+ (setq-local clojure-get-indent-function #'cider--get-symbol-indent))
+ (setq-local clojure-expected-ns-function #'cider-expected-ns)
+ (setq next-error-function #'cider-jump-to-compilation-error))
+ (mapc #'kill-local-variable '(completion-at-point-functions
+ next-error-function
+ x-gtk-use-system-tooltips
+ font-lock-fontify-region-function
+ clojure-get-indent-function))
+ (remove-hook 'font-lock-mode-hook #'cider-refresh-dynamic-font-lock 'local)
+ (font-lock-add-keywords nil cider--reader-conditionals-font-lock-keywords)
+ (font-lock-remove-keywords nil cider--dynamic-font-lock-keywords)
+ (font-lock-remove-keywords nil cider--static-font-lock-keywords)
+ (cider--font-lock-flush)))
+
+(defun cider-set-buffer-ns (ns)
+ "Set this buffer's namespace to NS and refresh font-locking."
+ (setq-local cider-buffer-ns ns)
+ (when (or cider-mode (derived-mode-p 'cider-repl-mode))
+ (cider-refresh-dynamic-font-lock ns)))
+
+(provide 'cider-mode)
+
+;;; cider-mode.el ends here
--- /dev/null
+;;; cider-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Use `cider--make-overlay' to place a generic overlay at point. Or use
+;; `cider--make-result-overlay' to place an interactive eval result overlay at
+;; the end of a specified line.
+
+;;; Code:
+
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cl-lib)
+
+\f
+;;; Customization
+(defface cider-result-overlay-face
+ '((((class color) (background light))
+ :background "grey90" :box (:line-width -1 :color "yellow"))
+ (((class color) (background dark))
+ :background "grey10" :box (:line-width -1 :color "black")))
+ "Face used to display evaluation results at the end of line.
+If `cider-overlays-use-font-lock' is non-nil, this face is
+applied with lower priority than the syntax highlighting."
+ :group 'cider
+ :package-version '(cider "0.9.1"))
+
+(defcustom cider-result-use-clojure-font-lock t
+ "If non-nil, interactive eval results are font-locked as Clojure code."
+ :group 'cider
+ :type 'boolean
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-overlays-use-font-lock t
+ "If non-nil, results overlays are font-locked as Clojure code.
+If nil, apply `cider-result-overlay-face' to the entire overlay instead of
+font-locking it."
+ :group 'cider
+ :type 'boolean
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-use-overlays 'both
+ "Whether to display evaluation results with overlays.
+If t, use overlays. If nil, display on the echo area. If both, display on
+both places.
+
+Only applies to evaluation commands. To configure the debugger overlays,
+see `cider-debug-use-overlays'."
+ :type '(choice (const :tag "End of line" t)
+ (const :tag "Bottom of screen" nil)
+ (const :tag "Both" both))
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-eval-result-prefix "=> "
+ "The prefix displayed in the minibuffer before a result value."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.5.0"))
+
+(defcustom cider-eval-result-duration 'command
+ "Duration, in seconds, of CIDER's eval-result overlays.
+If nil, overlays last indefinitely.
+If the symbol `command', they're erased after the next command.
+Also see `cider-use-overlays'."
+ :type '(choice (integer :tag "Duration in seconds")
+ (const :tag "Until next command" command)
+ (const :tag "Last indefinitely" nil))
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+\f
+;;; Overlay logic
+(defun cider--delete-overlay (ov &rest _)
+ "Safely delete overlay OV.
+Never throws errors, and can be used in an overlay's modification-hooks."
+ (ignore-errors (delete-overlay ov)))
+
+(defun cider--make-overlay (l r type &rest props)
+ "Place an overlay between L and R and return it.
+TYPE is a symbol put on the overlay's category property. It is used to
+easily remove all overlays from a region with:
+ (remove-overlays start end 'category TYPE)
+PROPS is a plist of properties and values to add to the overlay."
+ (let ((o (make-overlay l (or r l) (current-buffer))))
+ (overlay-put o 'category type)
+ (overlay-put o 'cider-temporary t)
+ (while props (overlay-put o (pop props) (pop props)))
+ (push #'cider--delete-overlay (overlay-get o 'modification-hooks))
+ o))
+
+(defun cider--remove-result-overlay ()
+ "Remove result overlay from current buffer.
+This function also removes itself from `post-command-hook'."
+ (remove-hook 'post-command-hook #'cider--remove-result-overlay 'local)
+ (remove-overlays nil nil 'category 'result))
+
+(defun cider--remove-result-overlay-after-command ()
+ "Add `cider--remove-result-overlay' locally to `post-command-hook'.
+This function also removes itself from `post-command-hook'."
+ (remove-hook 'post-command-hook #'cider--remove-result-overlay-after-command 'local)
+ (add-hook 'post-command-hook #'cider--remove-result-overlay nil 'local))
+
+(defface cider-fringe-good-face
+ '((((class color) (background light)) :foreground "lightgreen")
+ (((class color) (background dark)) :foreground "darkgreen"))
+ "Face used on the fringe indicator for successful evaluation."
+ :group 'cider)
+
+(defconst cider--fringe-overlay-good
+ (propertize " " 'display '(left-fringe empty-line cider-fringe-good-face))
+ "The before-string property that adds a green indicator on the fringe.")
+
+(defcustom cider-use-fringe-indicators t
+ "Whether to display evaluation indicators on the left fringe."
+ :safe #'booleanp
+ :group 'cider
+ :type 'boolean)
+
+(defun cider--make-fringe-overlay (&optional end)
+ "Place an eval indicator at the fringe before a sexp.
+END is the position where the sexp ends, and defaults to point."
+ (when cider-use-fringe-indicators
+ (with-current-buffer (if (markerp end)
+ (marker-buffer end)
+ (current-buffer))
+ (save-excursion
+ (if end
+ (goto-char end)
+ (setq end (point)))
+ (clojure-forward-logical-sexp -1)
+ ;; Create the green-circle overlay.
+ (cider--make-overlay (point) end 'cider-fringe-indicator
+ 'before-string cider--fringe-overlay-good)))))
+
+(cl-defun cider--make-result-overlay (value &rest props &key where duration (type 'result)
+ (format (concat " " cider-eval-result-prefix "%s "))
+ (prepend-face 'cider-result-overlay-face)
+ &allow-other-keys)
+ "Place an overlay displaying VALUE at the end of line.
+VALUE is used as the overlay's after-string property, meaning it is
+displayed at the end of the overlay. The overlay itself is placed from
+beginning to end of current line.
+Return nil if the overlay was not placed or if it might not be visible, and
+return the overlay otherwise.
+
+Return the overlay if it was placed successfully, and nil if it failed.
+
+This function takes some optional keyword arguments:
+
+ If WHERE is a number or a marker, apply the overlay over
+ the entire line at that place (defaulting to `point'). If
+ it is a cons cell, the car and cdr determine the start and
+ end of the overlay.
+ DURATION takes the same possible values as the
+ `cider-eval-result-duration' variable.
+ TYPE is passed to `cider--make-overlay' (defaults to `result').
+ FORMAT is a string passed to `format'. It should have
+ exactly one %s construct (for VALUE).
+
+All arguments beyond these (PROPS) are properties to be used on the
+overlay."
+ (declare (indent 1))
+ (while (keywordp (car props))
+ (setq props (cdr (cdr props))))
+ ;; If the marker points to a dead buffer, don't do anything.
+ (let ((buffer (cond
+ ((markerp where) (marker-buffer where))
+ ((markerp (car-safe where)) (marker-buffer (car where)))
+ (t (current-buffer)))))
+ (with-current-buffer buffer
+ (save-excursion
+ (when (number-or-marker-p where)
+ (goto-char where))
+ ;; Make sure the overlay is actually at the end of the sexp.
+ (skip-chars-backward "\r\n[:blank:]")
+ (let* ((beg (if (consp where)
+ (car where)
+ (save-excursion
+ (clojure-backward-logical-sexp 1)
+ (point))))
+ (end (if (consp where)
+ (cdr where)
+ (line-end-position)))
+ (display-string (format format value))
+ (o nil))
+ (remove-overlays beg end 'category type)
+ (funcall (if cider-overlays-use-font-lock
+ #'font-lock-prepend-text-property
+ #'put-text-property)
+ 0 (length display-string)
+ 'face prepend-face
+ display-string)
+ ;; If the display spans multiple lines or is very long, display it at
+ ;; the beginning of the next line.
+ (when (or (string-match "\n." display-string)
+ (> (string-width display-string)
+ (- (window-width) (current-column))))
+ (setq display-string (concat " \n" display-string)))
+ ;; Put the cursor property only once we're done manipulating the
+ ;; string, since we want it to be at the first char.
+ (put-text-property 0 1 'cursor 0 display-string)
+ (when (> (string-width display-string) (* 3 (window-width)))
+ (setq display-string
+ (concat (substring display-string 0 (* 3 (window-width)))
+ (substitute-command-keys
+ "...\nResult truncated. Type `\\[cider-inspect-last-result]' to inspect it."))))
+ ;; Create the result overlay.
+ (setq o (apply #'cider--make-overlay
+ beg end type
+ 'after-string display-string
+ props))
+ (pcase duration
+ ((pred numberp) (run-at-time duration nil #'cider--delete-overlay o))
+ (`command
+ ;; If inside a command-loop, tell `cider--remove-result-overlay'
+ ;; to only remove after the *next* command.
+ (if this-command
+ (add-hook 'post-command-hook
+ #'cider--remove-result-overlay-after-command
+ nil 'local)
+ (cider--remove-result-overlay-after-command))))
+ (when-let ((win (get-buffer-window buffer)))
+ ;; Left edge is visible.
+ (when (and (<= (window-start win) (point))
+ ;; In 24.3 `<=' is still a binary perdicate.
+ (<= (point) (window-end win))
+ ;; Right edge is visible. This is a little conservative
+ ;; if the overlay contains line breaks.
+ (or (< (+ (current-column) (string-width value))
+ (window-width win))
+ (not truncate-lines)))
+ o)))))))
+
+\f
+;;; Displaying eval result
+(defun cider--display-interactive-eval-result (value &optional point)
+ "Display the result VALUE of an interactive eval operation.
+VALUE is syntax-highlighted and displayed in the echo area.
+If POINT and `cider-use-overlays' are non-nil, it is also displayed in an
+overlay at the end of the line containing POINT.
+Note that, while POINT can be a number, it's preferable to be a marker, as
+that will better handle some corner cases where the original buffer is not
+focused."
+ (let* ((font-value (if cider-result-use-clojure-font-lock
+ (cider-font-lock-as-clojure value)
+ value))
+ (used-overlay (when (and point cider-use-overlays)
+ (cider--make-result-overlay font-value
+ :where point
+ :duration cider-eval-result-duration))))
+ (message
+ "%s"
+ (propertize (format "%s%s" cider-eval-result-prefix font-value)
+ ;; The following hides the message from the echo-area, but
+ ;; displays it in the Messages buffer. We only hide the message
+ ;; if the user wants to AND if the overlay succeeded.
+ 'invisible (and used-overlay
+ (not (eq cider-use-overlays 'both)))))))
+
+\f
+;;; Fragile buttons
+(defface cider-fragile-button-face
+ '((((type graphic))
+ :box (:line-width 3 :style released-button)
+ :inherit font-lock-warning-face)
+ (t :inverse-video t))
+ "Face for buttons that vanish when clicked."
+ :package-version '(cider . "0.12.0")
+ :group 'cider)
+
+(define-button-type 'cider-fragile
+ 'action 'cider--overlay-destroy
+ 'follow-link t
+ 'face nil
+ 'modification-hooks '(cider--overlay-destroy)
+ 'help-echo "RET: delete this.")
+
+(defun cider--overlay-destroy (ov &rest r)
+ "Delete overlay OV and its underlying text.
+If any other arguments are given (collected in R), only actually do anything
+if the first one is non-nil. This is so it works in `modification-hooks'."
+ (unless (and r (not (car r)))
+ (let ((inhibit-modification-hooks t)
+ (beg (copy-marker (overlay-start ov)))
+ (end (copy-marker (overlay-end ov))))
+ (delete-overlay ov)
+ (delete-region beg end)
+ (goto-char beg)
+ (when (= (char-after) (char-before) ?\n)
+ (delete-char 1)))))
+
+(provide 'cider-overlays)
+;;; cider-overlays.el ends here
--- /dev/null
+(define-package "cider" "20170129.1941" "Clojure Interactive Development Environment that Rocks"
+ '((emacs "24.4")
+ (clojure-mode "5.6.0")
+ (pkg-info "0.4")
+ (queue "0.1.1")
+ (spinner "1.7")
+ (seq "2.16"))
+ :url "http://www.github.com/clojure-emacs/cider" :keywords
+ '("languages" "clojure" "cider"))
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
--- /dev/null
+;;; cider-popup.el --- Creating and quitting popup buffers -*- lexical-binding: t; -*-
+
+;; Copyright © 2015-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Common functionality for dealing with popup buffers.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'cider-compat)
+
+(define-minor-mode cider-popup-buffer-mode
+ "Mode for CIDER popup buffers"
+ nil
+ (" cider-tmp")
+ '(("q" . cider-popup-buffer-quit-function)))
+
+(defvar-local cider-popup-buffer-quit-function #'cider-popup-buffer-quit
+ "The function that is used to quit a temporary popup buffer.")
+
+(defun cider-popup-buffer-quit-function (&optional kill-buffer-p)
+ "Wrapper to invoke the function `cider-popup-buffer-quit-function'.
+KILL-BUFFER-P is passed along."
+ (interactive)
+ (funcall cider-popup-buffer-quit-function kill-buffer-p))
+
+(defun cider-popup-buffer (name &optional select mode ancillary)
+ "Create new popup buffer called NAME.
+If SELECT is non-nil, select the newly created window.
+If major MODE is non-nil, enable it for the popup buffer.
+If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers'
+and automatically removed when killed."
+ (thread-first (cider-make-popup-buffer name mode ancillary)
+ (cider-popup-buffer-display select)))
+
+(defun cider-popup-buffer-display (buffer &optional select)
+ "Display BUFFER.
+If SELECT is non-nil, select the BUFFER."
+ (let ((window (get-buffer-window buffer 'visible)))
+ (when window
+ (with-current-buffer buffer
+ (set-window-point window (point))))
+ ;; If the buffer we are popping up is already displayed in the selected
+ ;; window, the below `inhibit-same-window' logic will cause it to be
+ ;; displayed twice - so we early out in this case. Note that we must check
+ ;; `selected-window', as async request handlers are executed in the context
+ ;; of the current connection buffer (i.e. `current-buffer' is dynamically
+ ;; bound to that).
+ (unless (eq window (selected-window))
+ ;; Non nil `inhibit-same-window' ensures that current window is not covered
+ ;; Non nil `inhibit-switch-frame' ensures that the other frame is not selected
+ ;; if that's where the buffer is being shown.
+ (funcall (if select #'pop-to-buffer #'display-buffer)
+ buffer `(nil . ((inhibit-same-window . ,pop-up-windows)
+ (reusable-frames . visible))))))
+ buffer)
+
+(defun cider-popup-buffer-quit (&optional kill)
+ "Quit the current (temp) window.
+Bury its buffer using `quit-restore-window'.
+If prefix argument KILL is non-nil, kill the buffer instead of burying it."
+ (interactive)
+ (quit-restore-window (selected-window) (if kill 'kill 'append)))
+
+(defvar-local cider-popup-output-marker nil)
+
+(defvar cider-ancillary-buffers nil)
+
+(defun cider-make-popup-buffer (name &optional mode ancillary)
+ "Create a temporary buffer called NAME using major MODE (if specified).
+If ANCILLARY is non-nil, the buffer is added to `cider-ancillary-buffers'
+and automatically removed when killed."
+ (with-current-buffer (get-buffer-create name)
+ (kill-all-local-variables)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (when mode
+ (funcall mode))
+ (cider-popup-buffer-mode 1)
+ (setq cider-popup-output-marker (point-marker))
+ (setq buffer-read-only t)
+ (when ancillary
+ (add-to-list 'cider-ancillary-buffers name)
+ (add-hook 'kill-buffer-hook
+ (lambda () (setq cider-ancillary-buffers (remove name cider-ancillary-buffers)))
+ nil 'local))
+ (current-buffer)))
+
+(defun cider-emit-into-popup-buffer (buffer value &optional face)
+ "Emit into BUFFER the provided VALUE optionally using FACE."
+ ;; Long string output renders Emacs unresponsive and users might intentionally
+ ;; kill the frozen popup buffer. Therefore, we don't re-create the buffer and
+ ;; silently ignore the output.
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t)
+ (buffer-undo-list t)
+ (moving (= (point) cider-popup-output-marker)))
+ (save-excursion
+ (goto-char cider-popup-output-marker)
+ (let ((value-str (format "%s" value)))
+ (when face
+ (if (fboundp 'add-face-text-property)
+ (add-face-text-property 0 (length value-str) face nil value-str)
+ (add-text-properties 0 (length value-str) (list 'face face) value-str)))
+ (insert value-str))
+ (indent-sexp)
+ (set-marker cider-popup-output-marker (point)))
+ (when moving (goto-char cider-popup-output-marker))))))
+
+(provide 'cider-popup)
+
+;;; cider-popup.el ends here
--- /dev/null
+;;; cider-repl-history.el --- REPL input history browser
+
+;; Copyright (c) 2017 John Valente and browse-kill-ring authors
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;; Based heavily on browse-kill-ring
+;; https://github.com/browse-kill-ring/browse-kill-ring
+
+;;; Commentary:
+
+;; REPL input history browser for CIDER.
+
+;; Allows you to browse the full input history for your REPL buffer, and
+;; insert previous commands at the prompt.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'cider-compat)
+(require 'cider-popup)
+(require 'clojure-mode)
+(require 'derived)
+(require 'pulse)
+
+(defconst cider-repl-history-buffer "*cider-repl-history*")
+(add-to-list 'cider-ancillary-buffers cider-repl-history-buffer)
+
+(defgroup cider-repl-history nil
+ "A package for browsing and inserting the items in the CIDER command history."
+ :prefix "cider-repl-history-"
+ :group 'cider)
+
+(defvar cider-repl-history-display-styles
+ '((separated . cider-repl-history-insert-as-separated)
+ (one-line . cider-repl-history-insert-as-one-line)))
+
+(defcustom cider-repl-history-display-style 'separated
+ "How to display the CIDER command history items.
+
+If `one-line', then replace newlines with \"\\n\" for display.
+
+If `separated', then display `cider-repl-history-separator' between
+entries."
+ :type '(choice (const :tag "One line" one-line)
+ (const :tag "Separated" separated))
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-quit-action 'quit-window
+ "What action to take when `cider-repl-history-quit' is called.
+
+If `bury-buffer', then simply bury the *cider-repl-history* buffer, but keep
+the window.
+
+If `bury-and-delete-window', then bury the buffer, and (if there is
+more than one window) delete the window.
+
+If `delete-and-restore', then restore the window configuration to what it was
+before `cider-repl-history' was called, and kill the *cider-repl-history* buffer.
+
+If `quit-window', then restore the window configuration to what
+it was before `cider-repl-history' was called, and bury *cider-repl-history*.
+This is the default.
+
+If `kill-and-delete-window', then kill the *cider-repl-history* buffer, and
+delete the window on close.
+
+Otherwise, it should be a function to call."
+ ;; Note, if you use one of the non-"delete" options, after you "quit",
+ ;; the *cider-repl-history* buffer is still available. If you are using
+ ;; `cider-repl-history-show-preview', and you switch to *cider-repl-history* (i.e.,
+ ;; with C-x b), it will not give the preview unless and until you "update"
+ ;; the *cider-repl-history* buffer.
+ ;;
+ ;; This really should not be an issue, because there's no reason to "switch"
+ ;; back to the buffer. If you want to get it back, you can just do C-c M-p
+ ;; from the REPL buffer.
+
+ ;; If you get in this situation and find it annoying, you can either disable
+ ;; the preview, or set `cider-repl-history-quit-action' to 'delete-and-restore.
+ ;; Then you will simply not have the *cider-repl-history* buffer after you quit,
+ ;; and it won't be an issue.
+
+ :type '(choice (const :tag "Bury buffer"
+ :value bury-buffer)
+ (const :tag "Bury buffer and delete window"
+ :value bury-and-delete-window)
+ (const :tag "Delete window"
+ :value delete-and-restore)
+ (const :tag "Save and restore"
+ :value quit-window)
+ (const :tag "Kill buffer and delete window"
+ :value kill-and-delete-window)
+ function)
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-resize-window nil
+ "Whether to resize the `cider-repl-history' window to fit its contents.
+Value is either t, meaning yes, or a cons pair of integers,
+ (MAXIMUM . MINIMUM) for the size of the window. MAXIMUM defaults to
+the window size chosen by `pop-to-buffer'; MINIMUM defaults to
+`window-min-height'."
+ :type '(choice (const :tag "No" nil)
+ (const :tag "Yes" t)
+ (cons (integer :tag "Maximum") (integer :tag "Minimum")))
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-separator ";;;;;;;;;;"
+ "The string separating entries in the `separated' style.
+See `cider-repl-history-display-style'."
+ ;; The (default) separator is a Clojure comment, to preserve fontification
+ ;; in the buffer.
+ :type 'string
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-recenter nil
+ "If non-nil, then always keep the current entry at the top of the window."
+ :type 'boolean
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-highlight-current-entry nil
+ "If non-nil, highlight the currently selected command history entry."
+ :type 'boolean
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-highlight-inserted-item nil
+ "If non-nil, then temporarily highlight the inserted command history entry.
+The value selected controls how the inserted item is highlighted,
+possible values are `solid' (highlight the inserted text for a
+fixed period of time), or `pulse' (fade out the highlighting gradually).
+Setting this variable to the value t will select the default
+highlighting style, which currently `pulse'.
+
+The variable `cider-repl-history-inserted-item-face' contains the
+face used for highlighting."
+ :type '(choice (const nil) (const t) (const solid) (const pulse))
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-separator-face 'bold
+ "The face in which to highlight the `cider-repl-history-separator'."
+ :type 'face
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-current-entry-face 'highlight
+ "The face in which to highlight the command history current entry."
+ :type 'face
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-inserted-item-face 'highlight
+ "The face in which to highlight the inserted item."
+ :type 'face
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-maximum-display-length nil
+ "Whether or not to limit the length of displayed items.
+
+If this variable is an integer, the display of the command history will be
+limited to that many characters.
+Setting this variable to nil means no limit."
+ :type '(choice (const :tag "None" nil)
+ integer)
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-display-duplicates t
+ "If non-nil, then display duplicate items in the command history."
+ :type 'boolean
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-display-duplicate-highest t
+ "When `cider-repl-history-display-duplicates' is nil, then display highest (most recent) duplicate items in the command history."
+ :type 'boolean
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-text-properties nil
+ "If non-nil, maintain text properties of the command history items."
+ :type 'boolean
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-hook nil
+ "A list of functions to call after `cider-repl-history'."
+ :type 'hook
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-history-show-preview nil
+ "If non-nil, show a preview of the inserted text in the REPL buffer.
+
+The REPL buffer would show a preview of what the buffer would look like
+if the item under point were inserted."
+
+ :type 'boolean
+ :group 'cider-repl-history
+ :package-version '(cider . "0.15.0"))
+
+(defvar cider-repl-history-repl-window nil
+ "The window in which chosen command history data will be inserted.
+It is probably not a good idea to set this variable directly; simply
+call `cider-repl-history' again.")
+
+(defvar cider-repl-history-repl-buffer nil
+ "The buffer in which chosen command history data will be inserted.
+It is probably not a good idea to set this variable directly; simply
+call `cider-repl-history' again.")
+
+(defvar cider-repl-history-preview-overlay nil
+ "The overlay used to preview what would happen if the user inserted the given text.")
+
+(defvar cider-repl-history-previous-overlay nil
+ "Previous overlay within *cider-repl-history* buffer.")
+
+
+(defun cider-repl-history-get-history ()
+ "Function to retrieve history from the REPL buffer."
+ (if cider-repl-history-repl-buffer
+ (buffer-local-value
+ 'cider-repl-input-history
+ cider-repl-history-repl-buffer)
+ (error "Variable `cider-repl-history-repl-buffer' not bound to a buffer")))
+
+(defun cider-repl-history-resize-window ()
+ "If variable `cider-repl-history-resize-window' is non-nil, resize the *cider-repl-history* window."
+ (when cider-repl-history-resize-window
+ (apply #'fit-window-to-buffer (selected-window)
+ (if (consp cider-repl-history-resize-window)
+ (list (car cider-repl-history-resize-window)
+ (or (cdr cider-repl-history-resize-window)
+ window-min-height))
+ (list nil window-min-height)))))
+
+(defun cider-repl-history-read-regexp (msg use-default-p)
+ "Get a regular expression from the user, prompting with MSG; previous entry is default if USE-DEFAULT-P."
+ (let* ((default (car regexp-history))
+ (input
+ (read-from-minibuffer
+ (if (and default use-default-p)
+ (format "%s for regexp (default `%s'): "
+ msg
+ default)
+ (format "%s (regexp): " msg))
+ nil
+ nil
+ nil
+ 'regexp-history
+ (if use-default-p nil default))))
+ (if (equal input "")
+ (if use-default-p default nil)
+ input)))
+
+(defun cider-repl-history-clear-preview ()
+ "Clear the preview, if one is present."
+ (interactive)
+ (when cider-repl-history-preview-overlay
+ (cl-assert (overlayp cider-repl-history-preview-overlay))
+ (delete-overlay cider-repl-history-preview-overlay)))
+
+(defun cider-repl-history-cleanup-on-exit ()
+ "Function called when the user is finished with `cider-repl-history'.
+This function performs any cleanup that is required when the user
+has finished interacting with the *cider-repl-history* buffer. For now
+the only cleanup performed is to remove the preview overlay, if
+it's turned on."
+ (cider-repl-history-clear-preview))
+
+(defun cider-repl-history-quit ()
+ "Take the action specified by `cider-repl-history-quit-action'."
+ (interactive)
+ (cider-repl-history-cleanup-on-exit)
+ (pcase cider-repl-history-quit-action
+ (`delete-and-restore
+ (quit-restore-window (selected-window) 'kill))
+ (`quit-window
+ (quit-window))
+ (`kill-and-delete-window
+ (kill-buffer (current-buffer))
+ (unless (= (count-windows) 1)
+ (delete-window)))
+ (`bury-and-delete-window
+ (bury-buffer)
+ (unless (= (count-windows) 1)
+ (delete-window)))
+ (_
+ (funcall cider-repl-history-quit-action))))
+
+(defun cider-repl-history-preview-overlay-setup (orig-buf)
+ "Setup the preview overlay in ORIG-BUF."
+ (when cider-repl-history-show-preview
+ (with-current-buffer orig-buf
+ (let* ((will-replace (region-active-p))
+ (start (if will-replace
+ (min (point) (mark))
+ (point)))
+ (end (if will-replace
+ (max (point) (mark))
+ (point))))
+ (cider-repl-history-clear-preview)
+ (setq cider-repl-history-preview-overlay
+ (make-overlay start end orig-buf))
+ (overlay-put cider-repl-history-preview-overlay
+ 'invisible t)))))
+
+(defun cider-repl-history-highlight-inserted (start end)
+ "Insert the text between START and END."
+ (pcase cider-repl-history-highlight-inserted-item
+ ((or `pulse `t)
+ (let ((pulse-delay .05) (pulse-iterations 10))
+ (with-no-warnings
+ (pulse-momentary-highlight-region
+ start end cider-repl-history-inserted-item-face))))
+ (`solid
+ (let ((o (make-overlay start end)))
+ (overlay-put o 'face cider-repl-history-inserted-item-face)
+ (sit-for 0.5)
+ (delete-overlay o)))))
+
+(defun cider-repl-history-insert-and-highlight (str)
+ "Helper function to insert STR at point, highlighting it if appropriate."
+ (let ((before-insert (point)))
+ (let (deactivate-mark)
+ (insert-for-yank str))
+ (cider-repl-history-highlight-inserted
+ before-insert
+ (point))))
+
+(defun cider-repl-history-target-overlay-at (position &optional no-error)
+ "Return overlay at POSITION that has property `cider-repl-history-target'.
+If no such overlay, raise an error unless NO-ERROR is true, in which
+case retun nil."
+ (let ((ovs (overlays-at (point))))
+ (catch 'cider-repl-history-target-overlay-at
+ (dolist (ov ovs)
+ (when (overlay-get ov 'cider-repl-history-target)
+ (throw 'cider-repl-history-target-overlay-at ov)))
+ (unless no-error
+ (error "No CIDER history item here")))))
+
+(defun cider-repl-history-current-string (pt &optional no-error)
+ "Find the string to insert into the REPL by looking for the overlay at PT; might error unless NO-ERROR set."
+ (let ((o (cider-repl-history-target-overlay-at pt t)))
+ (if o
+ (overlay-get o 'cider-repl-history-target)
+ (unless no-error
+ (error "No CIDER history item in this buffer")))))
+
+(defun cider-repl-history-do-insert (buf pt)
+ "Helper function to insert text from BUF at PT into the REPL buffer and kill *cider-repl-history*."
+ ;; Note: as mentioned at the top, this file is based on browse-kill-ring,
+ ;; which has numerous insertion options. The functionality of
+ ;; browse-kill-ring allows users to insert at point, and move point to the end
+ ;; of the inserted text; or insert at the beginning or end of the buffer,
+ ;; while leaving point alone. And each of these had the option of leaving the
+ ;; history buffer in place, or getting rid of it. That was appropriate for a
+ ;; generic paste tool, but for inserting a previous command into an
+ ;; interpreter, I felt the only useful option would be inserting it at the end
+ ;; and quitting the history buffer, so that is all that's provided.
+ (let ((str (cider-repl-history-current-string pt)))
+ (cider-repl-history-quit)
+ (with-selected-window cider-repl-history-repl-window
+ (with-current-buffer cider-repl-history-repl-buffer
+ (let ((max (point-max)))
+ (if (= max (point))
+ (cider-repl-history-insert-and-highlight str)
+ (save-excursion
+ (goto-char max)
+ (cider-repl-history-insert-and-highlight str))))))))
+
+(defun cider-repl-history-insert-and-quit ()
+ "Insert the item into the REPL buffer, and close the *cider-repl-history* buffer.
+
+The text is always inserted at the very bottom of the REPL buffer. If your
+cursor is already at the bottom, it is advanced to the end of the inserted
+text. If your cursor is somewhere else, the cursor is not moved, but the
+text is still inserted at the end."
+ (interactive)
+ (cider-repl-history-do-insert (current-buffer) (point)))
+
+(defun cider-repl-history-mouse-insert (e)
+ "Insert the item at E into the REPL buffer, and close the *cider-repl-history*.
+
+The text is always inserted at the very bottom of the REPL buffer. If your
+cursor is already at the bottom, it is advanced to the end of the inserted
+text. If your cursor is somewhere else, the cursor is not moved, but the
+text is still inserted at the end."
+ (interactive "e")
+ (let* ((data (save-excursion
+ (mouse-set-point e)
+ (cons (current-buffer) (point))))
+ (buf (car data))
+ (pt (cdr data)))
+ (cider-repl-history-do-insert buf pt)))
+
+(defun cider-repl-history-clear-highlighed-entry ()
+ "Clear the highlighted entry, when one exists."
+ (when cider-repl-history-previous-overlay
+ (cl-assert (overlayp cider-repl-history-previous-overlay)
+ t "not an overlay")
+ (overlay-put cider-repl-history-previous-overlay 'face nil)))
+
+(defun cider-repl-history-update-highlighed-entry ()
+ "Update highlighted entry, when feature is turned on."
+ (when cider-repl-history-highlight-current-entry
+ (if-let ((current-overlay (cider-repl-history-target-overlay-at (point) t)))
+ (unless (equal cider-repl-history-previous-overlay current-overlay)
+ ;; We've changed overlay. Clear current highlighting,
+ ;; and highlight the new overlay.
+ (cl-assert (overlay-get current-overlay 'cider-repl-history-target) t)
+ (cider-repl-history-clear-highlighed-entry)
+ (setq cider-repl-history-previous-overlay current-overlay)
+ (overlay-put current-overlay 'face
+ cider-repl-history-current-entry-face))
+ ;; No overlay at point. Just clear all current highlighting.
+ (cider-repl-history-clear-highlighed-entry))))
+
+(defun cider-repl-history-forward (&optional arg)
+ "Move forward by ARG command history entries."
+ (interactive "p")
+ (beginning-of-line)
+ (while (not (zerop arg))
+ (let ((o (cider-repl-history-target-overlay-at (point) t)))
+ (cond
+ ((>= arg 0)
+ (setq arg (1- arg))
+ ;; We're on a cider-repl-history overlay, skip to the end of it.
+ (when o
+ (goto-char (overlay-end o))
+ (setq o nil))
+ (while (not (or o (eobp)))
+ (goto-char (next-overlay-change (point)))
+ (setq o (cider-repl-history-target-overlay-at (point) t))))
+ (t
+ (setq arg (1+ arg))
+ (when o
+ (goto-char (overlay-start o))
+ (setq o nil))
+ (while (not (or o (bobp)))
+ (goto-char (previous-overlay-change (point)))
+ (setq o (cider-repl-history-target-overlay-at (point) t)))))))
+ (when cider-repl-history-recenter
+ (recenter 1)))
+
+(defun cider-repl-history-previous (&optional arg)
+ "Move backward by ARG command history entries."
+ (interactive "p")
+ (cider-repl-history-forward (- arg)))
+
+(defun cider-repl-history-search-forward (regexp &optional backwards)
+ "Move to the next command history entry matching REGEXP from point.
+If optional arg BACKWARDS is non-nil, move to the previous matching
+entry."
+ (interactive
+ (list (cider-repl-history-read-regexp "Search forward" t)
+ current-prefix-arg))
+ (let ((orig (point)))
+ (cider-repl-history-forward (if backwards -1 1))
+ (let ((over (cider-repl-history-target-overlay-at (point) t)))
+ (while (and over
+ (not (if backwards (bobp) (eobp)))
+ (not (string-match regexp
+ (overlay-get over
+ 'cider-repl-history-target))))
+ (cider-repl-history-forward (if backwards -1 1))
+ (setq over (cider-repl-history-target-overlay-at (point) t)))
+ (unless (and over
+ (string-match regexp
+ (overlay-get over
+ 'cider-repl-history-target)))
+ (goto-char orig)
+ (message "No more command history entries matching %s" regexp)))))
+
+(defun cider-repl-history-search-backward (regexp)
+ "Move to the previous command history entry matching REGEXP from point."
+ (interactive
+ (list (cider-repl-history-read-regexp "Search backward" t)))
+ (cider-repl-history-search-forward regexp t))
+
+(defun cider-repl-history-elide (str)
+ "If STR is too long, abbreviate it with an ellipsis; otherwise, return it unchanged."
+ (if (and cider-repl-history-maximum-display-length
+ (> (length str)
+ cider-repl-history-maximum-display-length))
+ (concat (substring str 0 (- cider-repl-history-maximum-display-length 3))
+ (propertize "..." 'cider-repl-history-extra t))
+ str))
+
+(defmacro cider-repl-history-add-overlays-for (item &rest body)
+ "Add overlays for ITEM, and execute BODY."
+ (let ((beg (cl-gensym "cider-repl-history-add-overlays-"))
+ (end (cl-gensym "cider-repl-history-add-overlays-")))
+ `(let ((,beg (point))
+ (,end
+ (progn
+ ,@body
+ (point))))
+ (let ((o (make-overlay ,beg ,end)))
+ (overlay-put o 'cider-repl-history-target ,item)
+ (overlay-put o 'mouse-face 'highlight)))))
+
+(defun cider-repl-history-insert-as-separated (items)
+ "Insert ITEMS into the current buffer, with separators between items."
+ (while items
+ (let* ((origitem (car items))
+ (item (cider-repl-history-elide origitem))
+ (len (length item)))
+ (cider-repl-history-add-overlays-for origitem (insert item))
+ ;; When the command history has items with read-only text property at
+ ;; **the end of** string, cider-repl-history-setup fails with error
+ ;; `Text is read-only'. So inhibit-read-only here.
+ ;; See http://bugs.debian.org/225082
+ (let ((inhibit-read-only t))
+ (insert "\n")
+ (when (cdr items)
+ (insert (propertize cider-repl-history-separator
+ 'cider-repl-history-extra t
+ 'cider-repl-history-separator t))
+ (insert "\n"))))
+ (setq items (cdr items))))
+
+(defun cider-repl-history-insert-as-one-line (items)
+ "Insert ITEMS into the current buffer, formatting each item as a single line.
+
+An explicit newline character will replace newlines so that the text retains its
+spacing when it's actually inserted into the REPL buffer."
+ (dolist (item items)
+ (cider-repl-history-add-overlays-for
+ item
+ (let* ((item (cider-repl-history-elide item))
+ (len (length item))
+ (start 0)
+ (newl (propertize "\\n" 'cider-repl-history-extra t)))
+ (while (and (< start len)
+ (string-match "\n" item start))
+ (insert (substring item start (match-beginning 0))
+ newl)
+ (setq start (match-end 0)))
+ (insert (substring item start len))))
+ (insert "\n")))
+
+(defun cider-repl-history-preview-update-text (preview-text)
+ "Update `cider-repl-history-preview-overlay' to show `PREVIEW-TEXT`."
+ ;; If preview-text is nil, replacement should be nil too.
+ (cl-assert (overlayp cider-repl-history-preview-overlay))
+ (let ((replacement (when preview-text
+ (propertize preview-text 'face 'highlight))))
+ (overlay-put cider-repl-history-preview-overlay
+ 'before-string replacement)))
+
+(defun cider-repl-history-preview-update-by-position (&optional pt)
+ "Update `cider-repl-history-preview-overlay' to match item at PT.
+
+This function is called whenever the selection in the *cider-repl-history*
+buffer is adjusted, the `cider-repl-history-preview-overlay'
+is udpated to preview the text of the selection at PT (or the
+current point if not specified)."
+ (let ((new-text (cider-repl-history-current-string
+ (or pt (point)) t)))
+ (cider-repl-history-preview-update-text new-text)))
+
+(defun cider-repl-history-undo-other-window ()
+ "Undo the most recent change in the other window's buffer.
+You most likely want to use this command for undoing an insertion of
+text from the *cider-repl-history* buffer."
+ (interactive)
+ (with-current-buffer cider-repl-history-repl-buffer
+ (undo)))
+
+(defun cider-repl-history-setup (repl-win repl-buf history-buf &optional regexp)
+ "Setup: REPL-WIN and REPL-BUF are where to insert commands, HISTORY-BUF is the history, and optional arg REGEXP is a filter."
+ (cider-repl-history-preview-overlay-setup repl-buf)
+ (with-current-buffer history-buf
+ (unwind-protect
+ (progn
+ (cider-repl-history-mode)
+ (setq buffer-read-only nil)
+ (when (eq 'one-line cider-repl-history-display-style)
+ (setq truncate-lines t))
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (setq cider-repl-history-repl-buffer repl-buf)
+ (setq cider-repl-history-repl-window repl-win)
+ (let* ((cider-repl-history-maximum-display-length
+ (if (and cider-repl-history-maximum-display-length
+ (<= cider-repl-history-maximum-display-length 3))
+ 4
+ cider-repl-history-maximum-display-length))
+ (cider-command-history (cider-repl-history-get-history))
+ (items (mapcar
+ (if cider-repl-history-text-properties
+ #'copy-sequence
+ #'substring-no-properties)
+ cider-command-history)))
+ (when (not cider-repl-history-display-duplicates)
+ ;; display highest or lowest duplicate.
+ ;; if `cider-repl-history-display-duplicate-highest' is t,
+ ;; display highest (most recent) duplicate.
+ (cl-delete-duplicates
+ items
+ :test #'equal
+ :from-end cider-repl-history-display-duplicate-highest))
+ (when (stringp regexp)
+ (setq items (delq nil
+ (mapcar
+ #'(lambda (item)
+ (when (string-match regexp item)
+ item))
+ items))))
+ (funcall (or (cdr (assq cider-repl-history-display-style
+ cider-repl-history-display-styles))
+ (error "Invalid `cider-repl-history-display-style': %s"
+ cider-repl-history-display-style))
+ items)
+ (when cider-repl-history-show-preview
+ (cider-repl-history-preview-update-by-position (point-min))
+ ;; Local post-command-hook, only happens in *cider-repl-history*
+ (add-hook 'post-command-hook
+ 'cider-repl-history-preview-update-by-position
+ nil t)
+ (add-hook 'kill-buffer-hook
+ 'cider-repl-history-cleanup-on-exit
+ nil t))
+ (when cider-repl-history-highlight-current-entry
+ (add-hook 'post-command-hook
+ 'cider-repl-history-update-highlighed-entry
+ nil t))
+ (message
+ (let ((entry (if (= 1 (length cider-command-history))
+ "entry"
+ "entries")))
+ (concat
+ (if (and (not regexp)
+ cider-repl-history-display-duplicates)
+ (format "%s %s in the command history."
+ (length cider-command-history) entry)
+ (format "%s (of %s) %s in the command history shown."
+ (length items) (length cider-command-history) entry))
+ (substitute-command-keys
+ (concat " Type \\[cider-repl-history-quit] to quit. "
+ "\\[describe-mode] for help.")))))
+ (set-buffer-modified-p nil)
+ (goto-char (point-min))
+ (cider-repl-history-forward 0)
+ (setq mode-name (if regexp
+ (concat "History [" regexp "]")
+ "History"))
+ (run-hooks 'cider-repl-history-hook)))
+ (setq buffer-read-only t))))
+
+(defun cider-repl-history-update ()
+ "Update the history buffer to reflect the latest state of the command history."
+ (interactive)
+ (cl-assert (eq major-mode 'cider-repl-history-mode))
+ (cider-repl-history-setup cider-repl-history-repl-window
+ cider-repl-history-repl-buffer
+ (current-buffer))
+ (cider-repl-history-resize-window))
+
+(defun cider-repl-history-occur (regexp)
+ "Display all command history entries matching REGEXP."
+ (interactive
+ (list (cider-repl-history-read-regexp
+ "Display command history entries matching" nil)))
+ (cl-assert (eq major-mode 'cider-repl-history-mode))
+ (cider-repl-history-setup cider-repl-history-repl-window
+ cider-repl-history-repl-buffer
+ (current-buffer)
+ regexp)
+ (cider-repl-history-resize-window))
+
+(put 'cider-repl-history-mode 'mode-class 'special)
+(define-derived-mode cider-repl-history-mode clojure-mode "History"
+ "Major mode for browsing the entries in the command input history.
+
+\\{cider-repl-history-mode-map}"
+ (define-key cider-repl-history-mode-map (kbd "n") 'cider-repl-history-forward)
+ (define-key cider-repl-history-mode-map (kbd "p") 'cider-repl-history-previous)
+ (define-key cider-repl-history-mode-map (kbd "SPC") 'cider-repl-history-insert-and-quit)
+ (define-key cider-repl-history-mode-map (kbd "RET") 'cider-repl-history-insert-and-quit)
+ (define-key cider-repl-history-mode-map [(mouse-2)] 'cider-repl-history-mouse-insert)
+ (define-key cider-repl-history-mode-map (kbd "l") 'cider-repl-history-occur)
+ (define-key cider-repl-history-mode-map (kbd "s") 'cider-repl-history-search-forward)
+ (define-key cider-repl-history-mode-map (kbd "r") 'cider-repl-history-search-backward)
+ (define-key cider-repl-history-mode-map (kbd "g") 'cider-repl-history-update)
+ (define-key cider-repl-history-mode-map (kbd "q") 'cider-repl-history-quit)
+ (define-key cider-repl-history-mode-map (kbd "U") 'cider-repl-history-undo-other-window)
+ (define-key cider-repl-history-mode-map (kbd "?") 'describe-mode)
+ (define-key cider-repl-history-mode-map (kbd "h") 'describe-mode))
+
+;;;###autoload
+(defun cider-repl-history ()
+ "Display items in the CIDER command history in another buffer."
+ (interactive)
+ (when (eq major-mode 'cider-repl-history-mode)
+ (user-error "Already viewing the CIDER command history"))
+
+ (let* ((repl-win (selected-window))
+ (repl-buf (window-buffer repl-win))
+ (buf (get-buffer-create cider-repl-history-buffer)))
+ (cider-repl-history-setup repl-win repl-buf buf)
+ (pop-to-buffer buf)
+ (cider-repl-history-resize-window)))
+
+(provide 'cider-repl-history)
+
+;;; cider-repl-history.el ends here
--- /dev/null
+;;; cider-repl.el --- REPL interactions -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; REPL interactions.
+
+;;; Code:
+
+(require 'cider-client)
+(require 'cider-doc)
+(require 'cider-test)
+(require 'cider-eldoc) ; for cider-eldoc-setup
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-util)
+(require 'cider-resolve)
+
+(require 'clojure-mode)
+(require 'easymenu)
+(require 'cl-lib)
+
+(eval-when-compile
+ (defvar paredit-version)
+ (defvar paredit-space-for-delimiter-predicates))
+
+\f
+(defgroup cider-repl nil
+ "Interaction with the REPL."
+ :prefix "cider-repl-"
+ :group 'cider)
+
+(defface cider-repl-prompt-face
+ '((t (:inherit font-lock-keyword-face)))
+ "Face for the prompt in the REPL buffer."
+ :group 'cider-repl)
+
+(defface cider-repl-stdout-face
+ '((t (:inherit font-lock-string-face)))
+ "Face for STDOUT output in the REPL buffer."
+ :group 'cider-repl)
+
+(defface cider-repl-stderr-face
+ '((t (:inherit font-lock-warning-face)))
+ "Face for STDERR output in the REPL buffer."
+ :group 'cider-repl
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-repl-input-face
+ '((t (:bold t)))
+ "Face for previous input in the REPL buffer."
+ :group 'cider-repl)
+
+(defface cider-repl-result-face
+ '((t ()))
+ "Face for the result of an evaluation in the REPL buffer."
+ :group 'cider-repl)
+
+(defcustom cider-repl-pop-to-buffer-on-connect t
+ "Controls whether to pop to the REPL buffer on connect.
+
+When set to nil the buffer will only be created, and not displayed. When
+set to `display-only' the buffer will be displayed, but it will not become
+focused. Otherwise the buffer is displayed and focused."
+ :type '(choice (const :tag "Create the buffer, but don't display it" nil)
+ (const :tag "Create and display the buffer, but don't focus it"
+ display-only)
+ (const :tag "Create, display, and focus the buffer" t))
+ :group 'cider-repl)
+
+(defcustom cider-repl-display-in-current-window nil
+ "Controls whether the REPL buffer is displayed in the current window."
+ :type 'boolean
+ :group 'cider-repl)
+
+(defcustom cider-repl-scroll-on-output t
+ "Controls whether the REPL buffer auto-scrolls on new output.
+
+When set to t (the default), if the REPL buffer contains more lines than the
+size of the window, the buffer is automatically re-centered upon completion
+of evaluating an expression, so that the bottom line of output is on the
+bottom line of the window.
+
+If this is set to nil, no re-centering takes place."
+ :type 'boolean
+ :group 'cider-repl
+ :package-version '(cider . "0.11.0"))
+
+(defcustom cider-repl-use-pretty-printing nil
+ "Control whether the results in REPL are pretty-printed or not.
+The `cider-toggle-pretty-printing' command can be used to interactively
+change the setting's value."
+ :type 'boolean
+ :group 'cider-repl)
+
+(defcustom cider-repl-pretty-print-width nil
+ "Control the width of pretty printing on the REPL.
+This sets the wrap point for pretty printing on the repl. If nil, it
+defaults to the variable `fill-column'."
+ :type '(restricted-sexp :match-alternatives
+ (integerp 'nil))
+ :group 'cider-repl
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-repl-use-clojure-font-lock t
+ "Non-nil means to use Clojure mode font-locking for input and result.
+Nil means that `cider-repl-input-face' and `cider-repl-result-face'
+will be used."
+ :type 'boolean
+ :group 'cider-repl
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-repl-result-prefix ""
+ "The prefix displayed in the REPL before a result value."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.5.0"))
+
+(defcustom cider-repl-tab-command 'cider-repl-indent-and-complete-symbol
+ "Select the command to be invoked by the TAB key.
+The default option is `cider-repl-indent-and-complete-symbol'. If
+you'd like to use the default Emacs behavior use
+`indent-for-tab-command'."
+ :type 'symbol
+ :group 'cider-repl)
+
+(defcustom cider-repl-display-help-banner t
+ "When non-nil a bit of help text will be displayed on REPL start."
+ :type 'boolean
+ :group 'cider-repl
+ :package-version '(cider . "0.11.0"))
+
+\f
+;;;; REPL buffer local variables
+(defvar-local cider-repl-input-start-mark nil)
+
+(defvar-local cider-repl-prompt-start-mark nil)
+
+(defvar-local cider-repl-old-input-counter 0
+ "Counter used to generate unique `cider-old-input' properties.
+This property value must be unique to avoid having adjacent inputs be
+joined together.")
+
+(defvar-local cider-repl-input-history '()
+ "History list of strings read from the REPL buffer.")
+
+(defvar-local cider-repl-input-history-items-added 0
+ "Variable counting the items added in the current session.")
+
+(defvar-local cider-repl-output-start nil
+ "Marker for the start of output.
+Currently its only purpose is to facilitate `cider-repl-clear-buffer'.")
+
+(defvar-local cider-repl-output-end nil
+ "Marker for the end of output.
+Currently its only purpose is to facilitate `cider-repl-clear-buffer'.")
+
+(defun cider-repl-tab ()
+ "Invoked on TAB keystrokes in `cider-repl-mode' buffers."
+ (interactive)
+ (funcall cider-repl-tab-command))
+
+(defun cider-repl-reset-markers ()
+ "Reset all REPL markers."
+ (dolist (markname '(cider-repl-output-start
+ cider-repl-output-end
+ cider-repl-prompt-start-mark
+ cider-repl-input-start-mark))
+ (set markname (make-marker))
+ (set-marker (symbol-value markname) (point))))
+
+\f
+;;; REPL init
+
+(defvar-local cider-repl-ns-cache nil
+ "A dict holding information about all currently loaded namespaces.
+This cache is stored in the connection buffer. Other buffer's access it
+via `cider-current-connection'.")
+
+(defvar cider-mode)
+(declare-function cider-refresh-dynamic-font-lock "cider-mode")
+
+(defun cider-repl--state-handler (response)
+ "Handle the server state contained in RESPONSE.
+Currently, this is only used to keep `cider-repl-type' updated."
+ (with-demoted-errors "Error in `cider-repl--state-handler': %s"
+ (when (member "state" (nrepl-dict-get response "status"))
+ (nrepl-dbind-response response (repl-type changed-namespaces)
+ (when repl-type
+ (setq cider-repl-type repl-type))
+ (unless (nrepl-dict-empty-p changed-namespaces)
+ (setq cider-repl-ns-cache (nrepl-dict-merge cider-repl-ns-cache changed-namespaces))
+ (dolist (b (buffer-list))
+ (with-current-buffer b
+ ;; Metadata changed, so signatures may have changed too.
+ (setq cider-eldoc-last-symbol nil)
+ (when (or cider-mode (derived-mode-p 'cider-repl-mode))
+ (when-let ((ns-dict (or (nrepl-dict-get changed-namespaces (cider-current-ns))
+ (let ((ns-dict (cider-resolve--get-in (cider-current-ns))))
+ (when (seq-find (lambda (ns) (nrepl-dict-get changed-namespaces ns))
+ (nrepl-dict-get ns-dict "aliases"))
+ ns-dict)))))
+ (cider-refresh-dynamic-font-lock ns-dict))))))))))
+
+(declare-function cider-default-err-handler "cider-interaction")
+
+(defun cider-repl-create (endpoint)
+ "Create a REPL buffer and install `cider-repl-mode'.
+ENDPOINT is a plist as returned by `nrepl-connect'."
+ ;; Connection might not have been set as yet. Please don't send requests here.
+ (let* ((reuse-buff (not (eq 'new nrepl-use-this-as-repl-buffer)))
+ (buff-name (nrepl-make-buffer-name nrepl-repl-buffer-name-template nil
+ (plist-get endpoint :host)
+ (plist-get endpoint :port)
+ reuse-buff)))
+ ;; when reusing, rename the buffer accordingly
+ (when (and reuse-buff
+ (not (equal buff-name nrepl-use-this-as-repl-buffer)))
+ ;; uniquify as it might be Nth connection to the same endpoint
+ (setq buff-name (generate-new-buffer-name buff-name))
+ (with-current-buffer nrepl-use-this-as-repl-buffer
+ (rename-buffer buff-name)))
+ (with-current-buffer (get-buffer-create buff-name)
+ (unless (derived-mode-p 'cider-repl-mode)
+ (cider-repl-mode))
+ (setq nrepl-err-handler #'cider-default-err-handler)
+ (cider-repl-reset-markers)
+ (add-hook 'nrepl-response-handler-functions #'cider-repl--state-handler nil 'local)
+ (add-hook 'nrepl-connected-hook 'cider--connected-handler nil 'local)
+ (add-hook 'nrepl-disconnected-hook 'cider--disconnected-handler nil 'local)
+ (current-buffer))))
+
+(defun cider-repl-require-repl-utils ()
+ "Require standard REPL util functions into the current REPL."
+ (interactive)
+ (cider-nrepl-request:eval
+ "(when (clojure.core/resolve 'clojure.main/repl-requires)
+ (clojure.core/map clojure.core/require clojure.main/repl-requires))"
+ (lambda (_response) nil)))
+
+(declare-function cider-set-buffer-ns "cider-mode")
+(defun cider-repl-set-initial-ns (buffer)
+ "Set the REPL BUFFER's initial namespace (by altering `cider-buffer-ns').
+This is \"user\" by default but can be overridden in apps like lein (:init-ns)."
+ ;; we don't want to get a timeout during init
+ (let ((nrepl-sync-request-timeout nil))
+ (with-current-buffer buffer
+ (let ((initial-ns (or (read
+ (nrepl-dict-get
+ (cider-nrepl-sync-request:eval "(str *ns*)")
+ "value"))
+ "user")))
+ (cider-set-buffer-ns initial-ns)))))
+
+(defvar cider-current-clojure-buffer nil
+ "This variable holds current buffer temporarily when connecting to a REPL.
+It is set to current buffer when `cider' or `cider-jack-in' is called.
+After the REPL buffer is created, the value of this variable is used
+to call `cider-remember-clojure-buffer'.")
+
+(declare-function cider-remember-clojure-buffer "cider-mode")
+
+(defun cider-repl-init (buffer &optional no-banner)
+ "Initialize the REPL in BUFFER.
+BUFFER must be a REPL buffer with `cider-repl-mode' and a running
+client process connection. Unless NO-BANNER is non-nil, insert a banner."
+ (cider-repl-set-initial-ns buffer)
+ (cider-repl-require-repl-utils)
+ (unless no-banner
+ (cider-repl--insert-banner-and-prompt buffer))
+ (when cider-repl-display-in-current-window
+ (add-to-list 'same-window-buffer-names (buffer-name buffer)))
+ (pcase cider-repl-pop-to-buffer-on-connect
+ (`display-only (display-buffer buffer))
+ ((pred identity) (pop-to-buffer buffer)))
+ (cider-remember-clojure-buffer cider-current-clojure-buffer)
+ buffer)
+
+(defun cider-repl--banner ()
+ "Generate the welcome REPL buffer banner."
+ (let ((host (cider--connection-host (current-buffer)))
+ (port (cider--connection-port (current-buffer))))
+ (format ";; Connected to nREPL server - nrepl://%s:%s
+;; CIDER %s, nREPL %s
+;; Clojure %s, Java %s
+;; Docs: (doc function-name)
+;; (find-doc part-of-name)
+;; Source: (source function-name)
+;; Javadoc: (javadoc java-object-or-class)
+;; Exit: <C-c C-q>
+;; Results: Stored in vars *1, *2, *3, an exception in *e;"
+ host
+ port
+ (cider--version)
+ (cider--nrepl-version)
+ (cider--clojure-version)
+ (cider--java-version))))
+
+(defun cider-repl--help-banner ()
+ "Generate the help banner."
+ (substitute-command-keys
+ "\n;; ======================================================================
+;; If you're new to CIDER it is highly recommended to go through its
+;; manual first. Type <M-x cider-view-manual> to view it.
+;; In case you're seeing any warnings you should consult the manual's
+;; \"Troubleshooting\" section.
+;;
+;; Here are few tips to get you started:
+;;
+;; * Press <\\[describe-mode]> to see a list of the keybindings available (this
+;; will work in every Emacs buffer)
+;; * Press <\\[cider-repl-handle-shortcut]> to quickly invoke some REPL command
+;; * Press <\\[cider-switch-to-last-clojure-buffer]> to switch between the REPL and a Clojure file
+;; * Press <\\[cider-find-var]> to jump to the source of something (e.g. a var, a
+;; Java method)
+;; * Press <\\[cider-doc]> to view the documentation for something (e.g.
+;; a var, a Java method)
+;; * Enable `eldoc-mode' to display function & method signatures in the minibuffer.
+;; * Print CIDER's refcard and keep it close to your keyboard.
+;;
+;; CIDER is super customizable - try <M-x customize-group cider> to
+;; get a feel for this. If you're thirsty for knowledge you should try
+;; <M-x cider-drink-a-sip>.
+;;
+;; If you think you've encountered a bug (or have some suggestions for
+;; improvements) use <M-x cider-report-bug> to report it.
+;;
+;; Above all else - don't panic! In case of an emergency - procure
+;; some (hard) cider and enjoy it responsibly!
+;;
+;; You can remove this message with the `cider-repl-clear-help-banner' command.
+;; You can disable it from appearing on start by setting
+;; `cider-repl-display-help-banner' to nil.
+;; ======================================================================
+"))
+
+(defun cider-repl--insert-banner-and-prompt (buffer)
+ "Insert REPL banner and REPL prompt in BUFFER."
+ (with-current-buffer buffer
+ (when (zerop (buffer-size))
+ (insert (propertize (cider-repl--banner) 'font-lock-face 'font-lock-comment-face))
+ (when cider-repl-display-help-banner
+ (insert (propertize (cider-repl--help-banner) 'font-lock-face 'font-lock-comment-face))))
+ (goto-char (point-max))
+ (cider-repl--mark-output-start)
+ (cider-repl--mark-input-start)
+ (cider-repl--insert-prompt cider-buffer-ns)))
+
+\f
+;;; REPL interaction
+
+(defun cider-repl--in-input-area-p ()
+ "Return t if in input area."
+ (<= cider-repl-input-start-mark (point)))
+
+(defun cider-repl--current-input (&optional until-point-p)
+ "Return the current input as string.
+The input is the region from after the last prompt to the end of
+buffer. If UNTIL-POINT-P is non-nil, the input is until the current
+point."
+ (buffer-substring-no-properties cider-repl-input-start-mark
+ (if until-point-p
+ (point)
+ (point-max))))
+
+(defun cider-repl-previous-prompt ()
+ "Move backward to the previous prompt."
+ (interactive)
+ (cider-repl--find-prompt t))
+
+(defun cider-repl-next-prompt ()
+ "Move forward to the next prompt."
+ (interactive)
+ (cider-repl--find-prompt))
+
+(defun cider-repl--find-prompt (&optional backward)
+ "Find the next prompt.
+If BACKWARD is non-nil look backward."
+ (let ((origin (point))
+ (cider-repl-prompt-property 'field))
+ (while (progn
+ (cider-search-property-change cider-repl-prompt-property backward)
+ (not (or (cider-end-of-proprange-p cider-repl-prompt-property) (bobp) (eobp)))))
+ (unless (cider-end-of-proprange-p cider-repl-prompt-property)
+ (goto-char origin))))
+
+(defun cider-search-property-change (prop &optional backward)
+ "Search forward for a property change to PROP.
+If BACKWARD is non-nil search backward."
+ (cond (backward
+ (goto-char (previous-single-char-property-change (point) prop)))
+ (t
+ (goto-char (next-single-char-property-change (point) prop)))))
+
+(defun cider-end-of-proprange-p (property)
+ "Return t if at the the end of a property range for PROPERTY."
+ (and (get-char-property (max (point-min) (1- (point))) property)
+ (not (get-char-property (point) property))))
+
+(defun cider-repl--mark-input-start ()
+ "Mark the input start."
+ (set-marker cider-repl-input-start-mark (point) (current-buffer)))
+
+(defun cider-repl--mark-output-start ()
+ "Mark the output start."
+ (set-marker cider-repl-output-start (point))
+ (set-marker cider-repl-output-end (point)))
+
+(defun cider-repl-mode-beginning-of-defun (&optional arg)
+ "Move to the beginning of defun.
+If given a negative value of ARG, move to the end of defun."
+ (if (and arg (< arg 0))
+ (cider-repl-mode-end-of-defun (- arg))
+ (dotimes (_ (or arg 1))
+ (cider-repl-previous-prompt))))
+
+(defun cider-repl-mode-end-of-defun (&optional arg)
+ "Move to the end of defun.
+If given a negative value of ARG, move to the beginning of defun."
+ (if (and arg (< arg 0))
+ (cider-repl-mode-beginning-of-defun (- arg))
+ (dotimes (_ (or arg 1))
+ (cider-repl-next-prompt))))
+
+(defun cider-repl-beginning-of-defun ()
+ "Move to beginning of defun."
+ (interactive)
+ ;; We call `beginning-of-defun' if we're at the start of a prompt
+ ;; already, to trigger `cider-repl-mode-beginning-of-defun' by means
+ ;; of the locally bound `beginning-of-defun-function', in order to
+ ;; jump to the start of the previous prompt.
+ (if (and (not (cider-repl--at-prompt-start-p))
+ (cider-repl--in-input-area-p))
+ (goto-char cider-repl-input-start-mark)
+ (beginning-of-defun)))
+
+(defun cider-repl-end-of-defun ()
+ "Move to end of defun."
+ (interactive)
+ ;; C.f. `cider-repl-beginning-of-defun'
+ (if (and (not (= (point) (point-max)))
+ (cider-repl--in-input-area-p))
+ (goto-char (point-max))
+ (end-of-defun)))
+
+(defun cider-repl-bol-mark ()
+ "Set the mark and go to the beginning of line or the prompt."
+ (interactive)
+ (unless mark-active
+ (set-mark (point)))
+ (move-beginning-of-line 1))
+
+(defun cider-repl--at-prompt-start-p ()
+ "Return t if point is at the start of prompt.
+This will not work on non-current prompts."
+ (= (point) cider-repl-input-start-mark))
+
+(defun cider-repl--show-maximum-output ()
+ "Put the end of the buffer at the bottom of the window."
+ (when (and cider-repl-scroll-on-output (eobp))
+ (let ((win (get-buffer-window (current-buffer) t)))
+ (when win
+ (with-selected-window win
+ (set-window-point win (point-max))
+ (recenter -1))))))
+
+(defmacro cider-save-marker (marker &rest body)
+ "Save MARKER and execute BODY."
+ (declare (debug t))
+ (let ((pos (make-symbol "pos")))
+ `(let ((,pos (marker-position ,marker)))
+ (prog1 (progn . ,body)
+ (set-marker ,marker ,pos)))))
+
+(put 'cider-save-marker 'lisp-indent-function 1)
+
+(defun cider-repl-prompt-default (namespace)
+ "Return a prompt string that mentions NAMESPACE."
+ (format "%s> " namespace))
+
+(defun cider-repl-prompt-abbreviated (namespace)
+ "Return a prompt string that abbreviates NAMESPACE."
+ (format "%s> " (cider-abbreviate-ns namespace)))
+
+(defun cider-repl-prompt-lastname (namespace)
+ "Return a prompt string with the last name in NAMESPACE."
+ (format "%s> " (cider-last-ns-segment namespace)))
+
+(defcustom cider-repl-prompt-function #'cider-repl-prompt-default
+ "A function that returns a prompt string.
+Takes one argument, a namespace name.
+For convenience, three functions are already provided for this purpose:
+`cider-repl-prompt-lastname', `cider-repl-prompt-abbreviated', and
+`cider-repl-prompt-default'"
+ :type '(choice (const :tag "Full namespace" cider-repl-prompt-default)
+ (const :tag "Abbreviated namespace" cider-repl-prompt-abbreviated)
+ (const :tag "Last name in namespace" cider-repl-prompt-lastname)
+ (function :tag "Custom function"))
+ :group 'cider-repl
+ :package-version '(cider . "0.9.0"))
+
+(defun cider-repl--insert-prompt (namespace)
+ "Insert the prompt (before markers!), taking into account NAMESPACE.
+Set point after the prompt.
+Return the position of the prompt beginning."
+ (goto-char cider-repl-input-start-mark)
+ (cider-save-marker cider-repl-output-start
+ (cider-save-marker cider-repl-output-end
+ (unless (bolp) (insert-before-markers "\n"))
+ (let ((prompt-start (point))
+ (prompt (funcall cider-repl-prompt-function namespace)))
+ (cider-propertize-region
+ '(font-lock-face cider-repl-prompt-face read-only t intangible t
+ field cider-repl-prompt
+ rear-nonsticky (field read-only font-lock-face intangible))
+ (insert-before-markers prompt))
+ (set-marker cider-repl-prompt-start-mark prompt-start)
+ prompt-start))))
+
+(defun cider-repl--flush-ansi-color-context ()
+ "Flush ansi color context after printing.
+When there is a possible unfinished ansi control sequence,
+ `ansi-color-context` maintains this list."
+ (when (and ansi-color-context (stringp (cadr ansi-color-context)))
+ (insert-before-markers (cadr ansi-color-context))
+ (setq ansi-color-context nil)))
+
+(defun cider-repl--emit-output-at-pos (buffer string output-face position &optional bol)
+ "Using BUFFER, insert STRING (applying to it OUTPUT-FACE) at POSITION.
+If BOL is non-nil insert at the beginning of line."
+ (with-current-buffer buffer
+ (save-excursion
+ (cider-save-marker cider-repl-output-start
+ (cider-save-marker cider-repl-output-end
+ (goto-char position)
+ ;; TODO: Review the need for bol
+ (when (and bol (not (bolp))) (insert-before-markers "\n"))
+ (insert-before-markers
+ (ansi-color-apply (propertize string
+ 'font-lock-face output-face
+ 'rear-nonsticky '(font-lock-face))))
+ (cider-repl--flush-ansi-color-context)
+ (when (and (= (point) cider-repl-prompt-start-mark)
+ (not (bolp)))
+ (insert-before-markers "\n")
+ (set-marker cider-repl-output-end (1- (point)))))))
+ (cider-repl--show-maximum-output)))
+
+(defun cider-repl--emit-interactive-output (string face)
+ "Emit STRING as interactive output using FACE."
+ (with-current-buffer (cider-current-repl-buffer)
+ (let ((pos (cider-repl--end-of-line-before-input-start))
+ (string (replace-regexp-in-string "\n\\'" "" string)))
+ (cider-repl--emit-output-at-pos (current-buffer) string face pos t))))
+
+(defun cider-repl-emit-interactive-stdout (string)
+ "Emit STRING as interactive output."
+ (cider-repl--emit-interactive-output string 'cider-repl-stdout-face))
+
+(defun cider-repl-emit-interactive-stderr (string)
+ "Emit STRING as interactive err output."
+ (cider-repl--emit-interactive-output string 'cider-repl-stderr-face))
+
+(defun cider-repl-manual-warning (section-id format &rest args)
+ "Emit a warning to the REPL and link to the online manual.
+SECTION-ID is the section to link to. The link is added on the last line.
+FORMAT is a format string to compile with ARGS and display on the REPL."
+ (let ((message (apply #'format format args)))
+ (cider-repl-emit-interactive-stderr
+ (concat "WARNING: " message "\n "
+ (cider--manual-button "More information" section-id)
+ "."))))
+
+(defun cider-repl--emit-output (buffer string face &optional bol)
+ "Using BUFFER, emit STRING font-locked with FACE.
+If BOL is non-nil, emit at the beginning of the line."
+ (with-current-buffer buffer
+ (cider-repl--emit-output-at-pos buffer string face cider-repl-input-start-mark bol)))
+
+(defun cider-repl-emit-stdout (buffer string)
+ "Using BUFFER, emit STRING as standard output."
+ (cider-repl--emit-output buffer string 'cider-repl-stdout-face))
+
+(defun cider-repl-emit-stderr (buffer string)
+ "Using BUFFER, emit STRING as error output."
+ (cider-repl--emit-output buffer string 'cider-repl-stderr-face))
+
+(defun cider-repl-emit-prompt (buffer)
+ "Emit the REPL prompt into BUFFER."
+ (with-current-buffer buffer
+ (save-excursion
+ (cider-save-marker cider-repl-output-start
+ (cider-save-marker cider-repl-output-end
+ (cider-repl--insert-prompt cider-buffer-ns))))
+ (cider-repl--show-maximum-output)))
+
+(defun cider-repl-emit-result (buffer string &optional bol)
+ "Emit into BUFFER the result STRING and mark it as an evaluation result.
+If BOL is non-nil insert at the beginning of the line."
+ (with-current-buffer buffer
+ (save-excursion
+ (cider-save-marker cider-repl-output-start
+ (cider-save-marker cider-repl-output-end
+ (goto-char cider-repl-input-start-mark)
+ (when (and bol (not (bolp)))
+ (insert-before-markers "\n"))
+ (insert-before-markers (propertize cider-repl-result-prefix 'font-lock-face 'font-lock-comment-face))
+ (if cider-repl-use-clojure-font-lock
+ (insert-before-markers (cider-font-lock-as-clojure string))
+ (cider-propertize-region
+ '(font-lock-face cider-repl-result-face rear-nonsticky (font-lock-face))
+ (insert-before-markers string))))))
+ (cider-repl--show-maximum-output)))
+
+(defun cider-repl-newline-and-indent ()
+ "Insert a newline, then indent the next line.
+Restrict the buffer from the prompt for indentation, to avoid being
+confused by strange characters (like unmatched quotes) appearing
+earlier in the buffer."
+ (interactive)
+ (save-restriction
+ (narrow-to-region cider-repl-prompt-start-mark (point-max))
+ (insert "\n")
+ (lisp-indent-line)))
+
+(defun cider-repl-indent-and-complete-symbol ()
+ "Indent the current line and perform symbol completion.
+First indent the line. If indenting doesn't move point, complete
+the symbol."
+ (interactive)
+ (let ((pos (point)))
+ (lisp-indent-line)
+ (when (= pos (point))
+ (if (save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
+ (completion-at-point)))))
+
+(defun cider-repl-kill-input ()
+ "Kill all text from the prompt to point."
+ (interactive)
+ (cond ((< (marker-position cider-repl-input-start-mark) (point))
+ (kill-region cider-repl-input-start-mark (point)))
+ ((= (point) (marker-position cider-repl-input-start-mark))
+ (cider-repl-delete-current-input))))
+
+(defun cider-repl--input-complete-p (start end)
+ "Return t if the region from START to END is a complete sexp."
+ (save-excursion
+ (goto-char start)
+ (cond ((looking-at-p "\\s *[@'`#]?[(\"]")
+ (ignore-errors
+ (save-restriction
+ (narrow-to-region start end)
+ ;; Keep stepping over blanks and sexps until the end of
+ ;; buffer is reached or an error occurs. Tolerate extra
+ ;; close parens.
+ (cl-loop do (skip-chars-forward " \t\r\n)")
+ until (eobp)
+ do (forward-sexp))
+ t)))
+ (t t))))
+
+(defun cider-repl-handler (buffer)
+ "Make an nREPL evaluation handler for the REPL BUFFER."
+ (nrepl-make-response-handler buffer
+ (lambda (buffer value)
+ (cider-repl-emit-result buffer value t))
+ (lambda (buffer out)
+ (cider-repl-emit-stdout buffer out))
+ (lambda (buffer err)
+ (cider-repl-emit-stderr buffer err))
+ (lambda (buffer)
+ (cider-repl-emit-prompt buffer))
+ nrepl-err-handler
+ (lambda (buffer pprint-out)
+ (cider-repl-emit-result buffer pprint-out nil))))
+
+(defun cider-repl--send-input (&optional newline)
+ "Go to the end of the input and send the current input.
+If NEWLINE is true then add a newline at the end of the input."
+ (unless (cider-repl--in-input-area-p)
+ (error "No input at point"))
+ (goto-char (point-max))
+ (let ((end (point))) ; end of input, without the newline
+ (cider-repl--add-to-input-history (buffer-substring cider-repl-input-start-mark end))
+ (when newline
+ (insert "\n")
+ (cider-repl--show-maximum-output))
+ (let ((inhibit-modification-hooks t))
+ (add-text-properties cider-repl-input-start-mark
+ (point)
+ `(cider-old-input
+ ,(cl-incf cider-repl-old-input-counter))))
+ (unless cider-repl-use-clojure-font-lock
+ (let ((overlay (make-overlay cider-repl-input-start-mark end)))
+ ;; These properties are on an overlay so that they won't be taken
+ ;; by kill/yank.
+ (overlay-put overlay 'read-only t)
+ (overlay-put overlay 'font-lock-face 'cider-repl-input-face))))
+ (let ((input (cider-repl--current-input))
+ (input-start (save-excursion (cider-repl-beginning-of-defun) (point))))
+ (goto-char (point-max))
+ (cider-repl--mark-input-start)
+ (cider-repl--mark-output-start)
+ (cider-nrepl-request:eval
+ input
+ (cider-repl-handler (current-buffer))
+ (cider-current-ns)
+ (line-number-at-pos input-start)
+ (cider-column-number-at-pos input-start)
+ (unless (or (not cider-repl-use-pretty-printing)
+ (string-match-p "\\`[ \t\r\n]*\\'" input))
+ (cider--nrepl-pprint-request-plist (cider--pretty-print-width))))))
+
+(defun cider-repl-return (&optional end-of-input)
+ "Evaluate the current input string, or insert a newline.
+Send the current input ony if a whole expression has been entered,
+i.e. the parenthesis are matched.
+When END-OF-INPUT is non-nil, send the input even if the parentheses
+are not balanced."
+ (interactive "P")
+ (cond
+ (end-of-input
+ (cider-repl--send-input))
+ ((and (get-text-property (point) 'cider-old-input)
+ (< (point) cider-repl-input-start-mark))
+ (cider-repl--grab-old-input end-of-input)
+ (cider-repl--recenter-if-needed))
+ ((cider-repl--input-complete-p cider-repl-input-start-mark (point-max))
+ (cider-repl--send-input t))
+ (t
+ (cider-repl-newline-and-indent)
+ (message "[input not complete]"))))
+
+(defun cider-repl--recenter-if-needed ()
+ "Make sure that the point is visible."
+ (unless (pos-visible-in-window-p (point-max))
+ (save-excursion
+ (goto-char (point-max))
+ (recenter -1))))
+
+(defun cider-repl--grab-old-input (replace)
+ "Resend the old REPL input at point.
+If REPLACE is non-nil the current input is replaced with the old
+input; otherwise the new input is appended. The old input has the
+text property `cider-old-input'."
+ (cl-multiple-value-bind (beg end) (cider-property-bounds 'cider-old-input)
+ (let ((old-input (buffer-substring beg end)) ;;preserve
+ ;;properties, they will be removed later
+ (offset (- (point) beg)))
+ ;; Append the old input or replace the current input
+ (cond (replace (goto-char cider-repl-input-start-mark))
+ (t (goto-char (point-max))
+ (unless (eq (char-before) ?\ )
+ (insert " "))))
+ (delete-region (point) (point-max))
+ (save-excursion
+ (insert old-input)
+ (when (equal (char-before) ?\n)
+ (delete-char -1)))
+ (forward-char offset))))
+
+(defun cider-repl-closing-return ()
+ "Evaluate the current input string after closing all open parenthesized or bracketed expressions."
+ (interactive)
+ (goto-char (point-max))
+ (save-restriction
+ (narrow-to-region cider-repl-input-start-mark (point))
+ (let ((matching-delimiter nil))
+ (while (ignore-errors (save-excursion
+ (backward-up-list 1)
+ (setq matching-delimiter (cdr (syntax-after (point))))) t)
+ (insert-char matching-delimiter))))
+ (cider-repl-return))
+
+(defun cider-repl-toggle-pretty-printing ()
+ "Toggle pretty-printing in the REPL."
+ (interactive)
+ (setq cider-repl-use-pretty-printing (not cider-repl-use-pretty-printing))
+ (message "Pretty printing in REPL %s."
+ (if cider-repl-use-pretty-printing "enabled" "disabled")))
+
+(defun cider--pretty-print-width ()
+ "Returns the width to use for pretty-printing."
+ (or cider-repl-pretty-print-width
+ fill-column
+ 80))
+
+(defun cider-repl-switch-to-other ()
+ "Switch between the Clojure and ClojureScript REPLs for the current project."
+ (interactive)
+ (if-let (other-connection (cider-other-connection))
+ (switch-to-buffer other-connection)
+ (message "There's no other REPL for the current project")))
+
+(defvar cider-repl-clear-buffer-hook)
+
+(defun cider-repl--clear-region (start end)
+ "Delete the output and its overlays between START and END."
+ (mapc #'delete-overlay (overlays-in start end))
+ (delete-region start end))
+
+(defun cider-repl-clear-buffer ()
+ "Delete the output generated by the Clojure process."
+ (interactive)
+ (let ((inhibit-read-only t))
+ (cider-repl--clear-region (point-min) cider-repl-prompt-start-mark)
+ (cider-repl--clear-region cider-repl-output-start cider-repl-output-end)
+ (when (< (point) cider-repl-input-start-mark)
+ (goto-char cider-repl-input-start-mark))
+ (recenter t))
+ (run-hooks 'cider-repl-clear-buffer-hook))
+
+(defun cider-repl--end-of-line-before-input-start ()
+ "Return the position of the end of the line preceding the beginning of input."
+ (1- (previous-single-property-change cider-repl-input-start-mark 'field nil
+ (1+ (point-min)))))
+
+(defun cider-repl-clear-output (&optional clear-repl)
+ "Delete the output inserted since the last input.
+With a prefix argument CLEAR-REPL it will clear the entire REPL buffer instead."
+ (interactive "P")
+ (if clear-repl
+ (cider-repl-clear-buffer)
+ (let ((start (save-excursion
+ (cider-repl-previous-prompt)
+ (ignore-errors (forward-sexp))
+ (forward-line)
+ (point)))
+ (end (cider-repl--end-of-line-before-input-start)))
+ (when (< start end)
+ (let ((inhibit-read-only t))
+ (cider-repl--clear-region start end)
+ (save-excursion
+ (goto-char start)
+ (insert
+ (propertize ";; output cleared" 'font-lock-face 'font-lock-comment-face))))))))
+
+(defun cider-repl-clear-banners ()
+ "Delete the REPL banners."
+ (interactive)
+ ;; TODO: Improve the boundaries detecting logic
+ ;; probably it should be based on text properties
+ ;; the current implemetation will clear warnings as well
+ (let ((start (point-min))
+ (end (save-excursion
+ (goto-char (point-min))
+ (cider-repl-next-prompt)
+ (forward-line -1)
+ (end-of-line)
+ (point))))
+ (when (< start end)
+ (let ((inhibit-read-only t))
+ (cider-repl--clear-region start (1+ end))))))
+
+(defun cider-repl-clear-help-banner ()
+ "Delete the help REPL banner."
+ (interactive)
+ ;; TODO: Improve the boundaries detecting logic
+ ;; probably it should be based on text properties
+ (let ((start (save-excursion
+ (goto-char (point-min))
+ (search-forward ";; =")
+ (beginning-of-line)
+ (point)))
+ (end (save-excursion
+ (goto-char (point-min))
+ (cider-repl-next-prompt)
+ (search-backward ";; =")
+ (end-of-line)
+ (point))))
+ (when (< start end)
+ (let ((inhibit-read-only t))
+ (cider-repl--clear-region start (1+ end))))))
+
+(defun cider-repl-switch-ns-handler (buffer)
+ "Make an nREPL evaluation handler for the REPL BUFFER's ns switching."
+ (nrepl-make-response-handler buffer
+ (lambda (_buffer _value))
+ (lambda (buffer out)
+ (cider-repl-emit-stdout buffer out))
+ (lambda (buffer err)
+ (cider-repl-emit-stderr buffer err))
+ (lambda (buffer)
+ (cider-repl-emit-prompt buffer))))
+
+(defun cider-repl-set-ns (ns)
+ "Switch the namespace of the REPL buffer to NS.
+
+If called from a cljc or cljx buffer act on both the Clojure and
+ClojureScript REPL if there are more than one REPL present.
+
+If invoked in a REPL buffer the command will prompt for the name of the
+namespace to switch to."
+ (interactive (list (if (or (derived-mode-p 'cider-repl-mode)
+ (null (cider-ns-form)))
+ (completing-read "Switch to namespace: "
+ (cider-sync-request:ns-list))
+ (cider-current-ns))))
+ (when (or (not ns) (equal ns ""))
+ (user-error "No namespace selected"))
+ (cider-map-connections
+ (lambda (connection)
+ (cider-nrepl-request:eval (format "(in-ns '%s)" ns)
+ (cider-repl-switch-ns-handler connection)))
+ :both))
+
+\f
+;;;;; History
+
+(defcustom cider-repl-wrap-history nil
+ "T to wrap history around when the end is reached."
+ :type 'boolean
+ :group 'cider-repl)
+
+;; These two vars contain the state of the last history search. We
+;; only use them if `last-command' was `cider-repl--history-replace',
+;; otherwise we reinitialize them.
+
+(defvar cider-repl-input-history-position -1
+ "Newer items have smaller indices.")
+
+(defvar cider-repl-history-pattern nil
+ "The regexp most recently used for finding input history.")
+
+(defun cider-repl--add-to-input-history (string)
+ "Add STRING to the input history.
+Empty strings and duplicates are ignored."
+ (unless (or (equal string "")
+ (equal string (car cider-repl-input-history)))
+ (push string cider-repl-input-history)
+ (cl-incf cider-repl-input-history-items-added)))
+
+(defun cider-repl-delete-current-input ()
+ "Delete all text after the prompt."
+ (goto-char (point-max))
+ (delete-region cider-repl-input-start-mark (point-max)))
+
+(defun cider-repl--replace-input (string)
+ "Replace the current REPL input with STRING."
+ (cider-repl-delete-current-input)
+ (insert-and-inherit string))
+
+(defun cider-repl--position-in-history (start-pos direction regexp)
+ "Return the position of the history item starting at START-POS.
+Search in DIRECTION for REGEXP.
+Return -1 resp the length of the history if no item matches."
+ ;; Loop through the history list looking for a matching line
+ (let* ((step (cl-ecase direction
+ (forward -1)
+ (backward 1)))
+ (history cider-repl-input-history)
+ (len (length history)))
+ (cl-loop for pos = (+ start-pos step) then (+ pos step)
+ if (< pos 0) return -1
+ if (<= len pos) return len
+ if (string-match-p regexp (nth pos history)) return pos)))
+
+(defun cider-repl--history-replace (direction &optional regexp)
+ "Replace the current input with the next line in DIRECTION.
+DIRECTION is 'forward' or 'backward' (in the history list).
+If REGEXP is non-nil, only lines matching REGEXP are considered."
+ (setq cider-repl-history-pattern regexp)
+ (let* ((min-pos -1)
+ (max-pos (length cider-repl-input-history))
+ (pos0 (cond ((cider-history-search-in-progress-p)
+ cider-repl-input-history-position)
+ (t min-pos)))
+ (pos (cider-repl--position-in-history pos0 direction (or regexp "")))
+ (msg nil))
+ (cond ((and (< min-pos pos) (< pos max-pos))
+ (cider-repl--replace-input (nth pos cider-repl-input-history))
+ (setq msg (format "History item: %d" pos)))
+ ((not cider-repl-wrap-history)
+ (setq msg (cond ((= pos min-pos) "End of history")
+ ((= pos max-pos) "Beginning of history"))))
+ (cider-repl-wrap-history
+ (setq pos (if (= pos min-pos) max-pos min-pos))
+ (setq msg "Wrapped history")))
+ (when (or (<= pos min-pos) (<= max-pos pos))
+ (when regexp
+ (setq msg (concat msg "; no matching item"))))
+ (message "%s%s" msg (cond ((not regexp) "")
+ (t (format "; current regexp: %s" regexp))))
+ (setq cider-repl-input-history-position pos)
+ (setq this-command 'cider-repl--history-replace)))
+
+(defun cider-history-search-in-progress-p ()
+ "Return t if a current history search is in progress."
+ (eq last-command 'cider-repl--history-replace))
+
+(defun cider-terminate-history-search ()
+ "Terminate the current history search."
+ (setq last-command this-command))
+
+(defun cider-repl-previous-input ()
+ "Cycle backwards through input history.
+If the `last-command' was a history navigation command use the
+same search pattern for this command.
+Otherwise use the current input as search pattern."
+ (interactive)
+ (cider-repl--history-replace 'backward (cider-repl-history-pattern t)))
+
+(defun cider-repl-next-input ()
+ "Cycle forwards through input history.
+See `cider-previous-input'."
+ (interactive)
+ (cider-repl--history-replace 'forward (cider-repl-history-pattern t)))
+
+(defun cider-repl-forward-input ()
+ "Cycle forwards through input history."
+ (interactive)
+ (cider-repl--history-replace 'forward (cider-repl-history-pattern)))
+
+(defun cider-repl-backward-input ()
+ "Cycle backwards through input history."
+ (interactive)
+ (cider-repl--history-replace 'backward (cider-repl-history-pattern)))
+
+(defun cider-repl-previous-matching-input (regexp)
+ "Find the previous input matching REGEXP."
+ (interactive "sPrevious element matching (regexp): ")
+ (cider-terminate-history-search)
+ (cider-repl--history-replace 'backward regexp))
+
+(defun cider-repl-next-matching-input (regexp)
+ "Find then next input matching REGEXP."
+ (interactive "sNext element matching (regexp): ")
+ (cider-terminate-history-search)
+ (cider-repl--history-replace 'forward regexp))
+
+(defun cider-repl-history-pattern (&optional use-current-input)
+ "Return the regexp for the navigation commands.
+If USE-CURRENT-INPUT is non-nil, use the current input."
+ (cond ((cider-history-search-in-progress-p)
+ cider-repl-history-pattern)
+ (use-current-input
+ (cl-assert (<= cider-repl-input-start-mark (point)))
+ (let ((str (cider-repl--current-input t)))
+ (cond ((string-match-p "^[ \n]*$" str) nil)
+ (t (concat "^" (regexp-quote str))))))
+ (t nil)))
+
+;;; persistent history
+(defcustom cider-repl-history-size 500
+ "The maximum number of items to keep in the REPL history."
+ :type 'integer
+ :safe 'integerp
+ :group 'cider-repl)
+
+(defcustom cider-repl-history-file nil
+ "File to save the persistent REPL history to."
+ :type 'string
+ :safe 'stringp
+ :group 'cider-repl)
+
+(defun cider-repl--history-read-filename ()
+ "Ask the user which file to use, defaulting `cider-repl-history-file'."
+ (read-file-name "Use CIDER REPL history file: "
+ cider-repl-history-file))
+
+(defun cider-repl--history-read (filename)
+ "Read history from FILENAME and return it.
+It does not yet set the input history."
+ (if (file-readable-p filename)
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (when (> (buffer-size (current-buffer)) 0)
+ (read (current-buffer))))
+ '()))
+
+(defun cider-repl-history-load (&optional filename)
+ "Load history from FILENAME into current session.
+FILENAME defaults to the value of `cider-repl-history-file' but user
+defined filenames can be used to read special history files.
+
+The value of `cider-repl-input-history' is set by this function."
+ (interactive (list (cider-repl--history-read-filename)))
+ (let ((f (or filename cider-repl-history-file)))
+ ;; TODO: probably need to set cider-repl-input-history-position as well.
+ ;; in a fresh connection the newest item in the list is currently
+ ;; not available. After sending one input, everything seems to work.
+ (setq cider-repl-input-history (cider-repl--history-read f))))
+
+(defun cider-repl--history-write (filename)
+ "Write history to FILENAME.
+Currently coding system for writing the contents is hardwired to
+utf-8-unix."
+ (let* ((mhist (cider-repl--histories-merge cider-repl-input-history
+ cider-repl-input-history-items-added
+ (cider-repl--history-read filename)))
+ ;; newest items are at the beginning of the list, thus 0
+ (hist (cl-subseq mhist 0 (min (length mhist) cider-repl-history-size))))
+ (unless (file-writable-p filename)
+ (error (format "History file not writable: %s" filename)))
+ (let ((print-length nil) (print-level nil))
+ (with-temp-file filename
+ ;; TODO: really set cs for output
+ ;; TODO: does cs need to be customizable?
+ (insert ";; -*- coding: utf-8-unix -*-\n")
+ (insert ";; Automatically written history of CIDER REPL session\n")
+ (insert ";; Edit at your own risk\n\n")
+ (prin1 (mapcar #'substring-no-properties hist) (current-buffer))))))
+
+(defun cider-repl-history-save (&optional filename)
+ "Save the current REPL input history to FILENAME.
+FILENAME defaults to the value of `cider-repl-history-file'."
+ (interactive (list (cider-repl--history-read-filename)))
+ (let* ((file (or filename cider-repl-history-file)))
+ (cider-repl--history-write file)))
+
+(defun cider-repl-history-just-save ()
+ "Just save the history to `cider-repl-history-file'.
+This function is meant to be used in hooks to avoid lambda
+constructs."
+ (cider-repl-history-save cider-repl-history-file))
+
+;; SLIME has different semantics and will not save any duplicates.
+;; we keep track of how many items were added to the history in the
+;; current session in `cider-repl--add-to-input-history' and merge only the
+;; new items with the current history found in the file, which may
+;; have been changed in the meantime by another session.
+(defun cider-repl--histories-merge (session-hist n-added-items file-hist)
+ "Merge histories from SESSION-HIST adding N-ADDED-ITEMS into FILE-HIST."
+ (append (cl-subseq session-hist 0 n-added-items)
+ file-hist))
+
+\f
+;;; REPL shortcuts
+(defcustom cider-repl-shortcut-dispatch-char ?\,
+ "Character used to distinguish REPL commands from Lisp forms."
+ :type '(character)
+ :group 'cider-repl)
+
+(defvar cider-repl-shortcuts (make-hash-table :test 'equal))
+
+(defun cider-repl-add-shortcut (name handler)
+ "Add a REPL shortcut command, defined by NAME and HANDLER."
+ (puthash name handler cider-repl-shortcuts))
+
+(declare-function cider-restart "cider-interaction")
+(declare-function cider-quit "cider-interaction")
+(declare-function cider-toggle-trace-ns "cider-interaction")
+(declare-function cider-undef "cider-interaction")
+(declare-function cider-browse-ns "cider-browse-ns")
+(declare-function cider-classpath "cider-classpath")
+(declare-function cider-repl-history "cider-repl-history")
+(declare-function cider-run "cider-interaction")
+(declare-function cider-refresh "cider-interaction")
+(cider-repl-add-shortcut "clear-output" #'cider-repl-clear-output)
+(cider-repl-add-shortcut "clear" #'cider-repl-clear-buffer)
+(cider-repl-add-shortcut "clear-banners" #'cider-repl-clear-banners)
+(cider-repl-add-shortcut "clear-help-banner" #'cider-repl-clear-help-banner)
+(cider-repl-add-shortcut "ns" #'cider-repl-set-ns)
+(cider-repl-add-shortcut "toggle-pretty" #'cider-repl-toggle-pretty-printing)
+(cider-repl-add-shortcut "browse-ns" (lambda () (cider-browse-ns (cider-current-ns))))
+(cider-repl-add-shortcut "classpath" #'cider-classpath)
+(cider-repl-add-shortcut "history" #'cider-repl-history)
+(cider-repl-add-shortcut "trace-ns" #'cider-toggle-trace-ns)
+(cider-repl-add-shortcut "undef" #'cider-undef)
+(cider-repl-add-shortcut "refresh" #'cider-refresh)
+(cider-repl-add-shortcut "help" #'cider-repl-shortcuts-help)
+(cider-repl-add-shortcut "test-ns" #'cider-test-run-ns-tests)
+(cider-repl-add-shortcut "test-all" #'cider-test-run-loaded-tests)
+(cider-repl-add-shortcut "test-project" #'cider-test-run-project-tests)
+(cider-repl-add-shortcut "test-report" #'cider-test-show-report)
+(cider-repl-add-shortcut "run" #'cider-run)
+(cider-repl-add-shortcut "conn-info" #'cider-display-connection-info)
+(cider-repl-add-shortcut "conn-rotate" #'cider-rotate-default-connection)
+(cider-repl-add-shortcut "hasta la vista" #'cider-quit)
+(cider-repl-add-shortcut "adios" #'cider-quit)
+(cider-repl-add-shortcut "sayonara" #'cider-quit)
+(cider-repl-add-shortcut "quit" #'cider-quit)
+(cider-repl-add-shortcut "restart" #'cider-restart)
+(cider-repl-add-shortcut "version" #'cider-version)
+
+(defconst cider-repl-shortcuts-help-buffer "*CIDER REPL Shortcuts Help*")
+
+(defun cider-repl-shortcuts-help ()
+ "Display a help buffer."
+ (interactive)
+ (ignore-errors (kill-buffer cider-repl-shortcuts-help-buffer))
+ (with-current-buffer (get-buffer-create cider-repl-shortcuts-help-buffer)
+ (insert "CIDER REPL shortcuts:\n\n")
+ (maphash (lambda (k v) (insert (format "%s:\n\t%s\n" k v))) cider-repl-shortcuts)
+ (goto-char (point-min))
+ (help-mode)
+ (display-buffer (current-buffer) t))
+ (cider-repl-handle-shortcut)
+ (current-buffer))
+
+(defun cider-repl--available-shortcuts ()
+ "Return the available REPL shortcuts."
+ (cider-util--hash-keys cider-repl-shortcuts))
+
+(defun cider-repl-handle-shortcut ()
+ "Execute a REPL shortcut."
+ (interactive)
+ (if (> (point) cider-repl-input-start-mark)
+ (insert (string cider-repl-shortcut-dispatch-char))
+ (let ((command (completing-read "Command: "
+ (cider-repl--available-shortcuts))))
+ (if (not (equal command ""))
+ (let ((command-func (gethash command cider-repl-shortcuts)))
+ (if command-func
+ (call-interactively (gethash command cider-repl-shortcuts))
+ (error "Unknown command %S. Available commands: %s"
+ command-func
+ (mapconcat 'identity (cider-repl--available-shortcuts) ", "))))
+ (error "No command selected")))))
+
+\f
+;;;;; CIDER REPL mode
+(defvar cider-repl-mode-hook nil
+ "Hook executed when entering `cider-repl-mode'.")
+
+(defvar cider-repl-mode-syntax-table
+ (copy-syntax-table clojure-mode-syntax-table))
+
+(declare-function cider-eval-region "cider-interaction")
+(declare-function cider-eval-last-sexp "cider-interaction")
+(declare-function cider-refresh "cider-interaction")
+(declare-function cider-toggle-trace-ns "cider-interaction")
+(declare-function cider-toggle-trace-var "cider-interaction")
+(declare-function cider-find-resource "cider-interaction")
+(declare-function cider-restart "cider-interaction")
+(declare-function cider-find-ns "cider-interaction")
+(declare-function cider-switch-to-last-clojure-buffer "cider-mode")
+
+(defvar cider-repl-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c C-d") 'cider-doc-map)
+ (define-key map (kbd "C-c ,") 'cider-test-commands-map)
+ (define-key map (kbd "C-c C-t") 'cider-test-commands-map)
+ (define-key map (kbd "M-.") #'cider-find-var)
+ (define-key map (kbd "C-c C-.") #'cider-find-ns)
+ (define-key map (kbd "M-,") #'cider-pop-back)
+ (define-key map (kbd "C-c M-.") #'cider-find-resource)
+ (define-key map (kbd "RET") #'cider-repl-return)
+ (define-key map (kbd "TAB") #'cider-repl-tab)
+ (define-key map (kbd "C-<return>") #'cider-repl-closing-return)
+ (define-key map (kbd "C-j") #'cider-repl-newline-and-indent)
+ (define-key map (kbd "C-c C-o") #'cider-repl-clear-output)
+ (define-key map (kbd "C-c M-n") #'cider-repl-set-ns)
+ (define-key map (kbd "C-c C-u") #'cider-repl-kill-input)
+ (define-key map (kbd "C-S-a") #'cider-repl-bol-mark)
+ (define-key map [S-home] #'cider-repl-bol-mark)
+ (define-key map (kbd "C-<up>") #'cider-repl-backward-input)
+ (define-key map (kbd "C-<down>") #'cider-repl-forward-input)
+ (define-key map (kbd "M-p") #'cider-repl-previous-input)
+ (define-key map (kbd "M-n") #'cider-repl-next-input)
+ (define-key map (kbd "M-r") #'cider-repl-previous-matching-input)
+ (define-key map (kbd "M-s") #'cider-repl-next-matching-input)
+ (define-key map (kbd "C-c C-n") #'cider-repl-next-prompt)
+ (define-key map (kbd "C-c C-p") #'cider-repl-previous-prompt)
+ (define-key map (kbd "C-c C-b") #'cider-interrupt)
+ (define-key map (kbd "C-c C-c") #'cider-interrupt)
+ (define-key map (kbd "C-c C-m") #'cider-macroexpand-1)
+ (define-key map (kbd "C-c M-m") #'cider-macroexpand-all)
+ (define-key map (kbd "C-c C-z") #'cider-switch-to-last-clojure-buffer)
+ (define-key map (kbd "C-c M-o") #'cider-repl-switch-to-other)
+ (define-key map (kbd "C-c M-s") #'cider-selector)
+ (define-key map (kbd "C-c M-d") #'cider-display-connection-info)
+ (define-key map (kbd "C-c C-q") #'cider-quit)
+ (define-key map (kbd "C-c M-i") #'cider-inspect)
+ (define-key map (kbd "C-c M-p") #'cider-repl-history)
+ (define-key map (kbd "C-c M-t v") #'cider-toggle-trace-var)
+ (define-key map (kbd "C-c M-t n") #'cider-toggle-trace-ns)
+ (define-key map (kbd "C-c C-x") #'cider-refresh)
+ (define-key map (kbd "C-x C-e") #'cider-eval-last-sexp)
+ (define-key map (kbd "C-c C-r") #'cider-eval-region)
+ (define-key map (string cider-repl-shortcut-dispatch-char) #'cider-repl-handle-shortcut)
+ (easy-menu-define cider-repl-mode-menu map
+ "Menu for CIDER's REPL mode"
+ `("REPL"
+ ["Complete symbol" complete-symbol]
+ "--"
+ ,cider-doc-menu
+ "--"
+ ("Find"
+ ["Find definition" cider-find-var]
+ ["Find resource" cider-find-resource]
+ ["Go back" cider-pop-back])
+ "--"
+ ["Switch to Clojure buffer" cider-switch-to-last-clojure-buffer]
+ ["Switch to other REPL" cider-repl-switch-to-other]
+ "--"
+ ("Macroexpand"
+ ["Macroexpand-1" cider-macroexpand-1]
+ ["Macroexpand-all" cider-macroexpand-all])
+ "--"
+ ,cider-test-menu
+ "--"
+ ["Run project (-main function)" cider-run]
+ ["Inspect" cider-inspect]
+ ["Toggle var tracing" cider-toggle-trace-var]
+ ["Toggle ns tracing" cider-toggle-trace-ns]
+ ["Refresh loaded code" cider-refresh]
+ "--"
+ ["Set REPL ns" cider-repl-set-ns]
+ ["Toggle pretty printing" cider-repl-toggle-pretty-printing]
+ "--"
+ ["Browse classpath" cider-classpath]
+ ["Browse classpath entry" cider-open-classpath-entry]
+ ["Browse namespace" cider-browse-ns]
+ ["Browse all namespaces" cider-browse-ns-all]
+ "--"
+ ["Next prompt" cider-repl-next-prompt]
+ ["Previous prompt" cider-repl-previous-prompt]
+ ["Clear output" cider-repl-clear-output]
+ ["Clear buffer" cider-repl-clear-buffer]
+ ["Clear banners" cider-repl-clear-banners]
+ ["Clear help banner" cider-repl-clear-help-banner]
+ ["Kill input" cider-repl-kill-input]
+ "--"
+ ["Interrupt evaluation" cider-interrupt]
+ "--"
+ ["Connection info" cider-display-connection-info]
+ "--"
+ ["Close ancillary buffers" cider-close-ancillary-buffers]
+ ["Quit" cider-quit]
+ ["Restart" cider-restart]
+ "--"
+ ["A sip of CIDER" cider-drink-a-sip]
+ ["View manual online" cider-view-manual]
+ ["View refcard online" cider-view-refcard]
+ ["Report a bug" cider-report-bug]
+ ["Version info" cider-version]))
+ map))
+
+(defun cider-repl-wrap-fontify-function (func)
+ "Return a function that will call FUNC narrowed to input region."
+ (lambda (beg end &rest rest)
+ (when (and cider-repl-input-start-mark
+ (> end cider-repl-input-start-mark))
+ (save-restriction
+ (narrow-to-region cider-repl-input-start-mark (point-max))
+ (let ((font-lock-dont-widen t))
+ (apply func (max beg cider-repl-input-start-mark) end rest))))))
+
+(declare-function cider-complete-at-point "cider-interaction")
+(defvar cider--static-font-lock-keywords)
+
+(define-derived-mode cider-repl-mode fundamental-mode "REPL"
+ "Major mode for Clojure REPL interactions.
+
+\\{cider-repl-mode-map}"
+ (clojure-mode-variables)
+ (setq-local lisp-indent-function #'clojure-indent-function)
+ (setq-local indent-line-function #'lisp-indent-line)
+ (clojure-font-lock-setup)
+ (font-lock-add-keywords nil cider--static-font-lock-keywords)
+ (setq-local font-lock-fontify-region-function
+ (cider-repl-wrap-fontify-function font-lock-fontify-region-function))
+ (setq-local font-lock-unfontify-region-function
+ (cider-repl-wrap-fontify-function font-lock-unfontify-region-function))
+ (make-local-variable 'completion-at-point-functions)
+ (add-to-list 'completion-at-point-functions
+ #'cider-complete-at-point)
+ (set-syntax-table cider-repl-mode-syntax-table)
+ (cider-eldoc-setup)
+ ;; At the REPL, we define beginning-of-defun and end-of-defun to be
+ ;; the start of the previous prompt or next prompt respectively.
+ ;; Notice the interplay with `cider-repl-beginning-of-defun'.
+ (setq-local beginning-of-defun-function #'cider-repl-mode-beginning-of-defun)
+ (setq-local end-of-defun-function #'cider-repl-mode-end-of-defun)
+ (setq-local prettify-symbols-alist clojure--prettify-symbols-alist)
+ ;; apply dir-local variables to REPL buffers
+ (hack-dir-local-variables-non-file-buffer)
+ (when cider-repl-history-file
+ (cider-repl-history-load cider-repl-history-file)
+ (add-hook 'kill-buffer-hook #'cider-repl-history-just-save t t)
+ (add-hook 'kill-emacs-hook #'cider-repl-history-just-save))
+ (add-hook 'paredit-mode-hook (lambda () (clojure-paredit-setup cider-repl-mode-map))))
+
+(provide 'cider-repl)
+
+;;; cider-repl.el ends here
--- /dev/null
+;;; cider-resolve.el --- Resolve clojure symbols according to current nREPL connection
+
+;; Copyright © 2015-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+
+;; Author: Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The ns cache is a dict of namespaces stored in the connection buffer. This
+;; file offers functions to easily get information about variables from this
+;; cache, given the variable's name and the file's namespace. This
+;; functionality is similar to that offered by the `cider-var-info' function
+;; (and others). The difference is that all functions in this file operate
+;; without contacting the server (they still rely on an active connection
+;; buffer, but no messages are actually exchanged).
+
+;; For this reason, the functions here are well suited for very
+;; performance-sentitive operations, such as font-locking or
+;; indentation. Meanwhile, operations like code-jumping are better off
+;; communicating with the middleware, just in the off chance that the cache is
+;; outdated.
+
+;; Below is a typical entry on this cache dict. Note that clojure.core symbols
+;; are excluded from the refers to save space.
+
+;; "cider.nrepl.middleware.track-state"
+;; (dict "aliases"
+;; (dict "cljs" "cider.nrepl.middleware.util.cljs"
+;; "misc" "cider.nrepl.middleware.util.misc"
+;; "set" "clojure.set")
+;; "interns" (dict a
+;; "assoc-state" (dict "arglists"
+;; (("response"
+;; (dict "as" "msg" "keys"
+;; ("session")))))
+;; "filter-core" (dict "arglists"
+;; (("refers")))
+;; "make-transport" (dict "arglists"
+;; (((dict "as" "msg" "keys"
+;; ("transport")))))
+;; "ns-as-map" (dict "arglists"
+;; (("ns")))
+;; "ns-cache" (dict)
+;; "relevant-meta" (dict "arglists"
+;; (("var")))
+;; "update-vals" (dict "arglists"
+;; (("m" "f")))
+;; "wrap-tracker" (dict "arglists"
+;; (("handler"))))
+;; "refers" (dict "set-descriptor!" "#'clojure.tools.nrepl.middleware/set-descriptor!"))
+
+;;; Code:
+
+(require 'cider-client)
+(require 'nrepl-dict)
+(require 'cider-util)
+
+(defvar cider-repl-ns-cache)
+
+(defun cider-resolve--get-in (&rest keys)
+ "Return (nrepl-dict-get-in cider-repl-ns-cache KEYS)."
+ (when cider-connections
+ (with-current-buffer (cider-current-connection)
+ (nrepl-dict-get-in cider-repl-ns-cache keys))))
+
+(defun cider-resolve-alias (ns alias)
+ "Return the namespace that ALIAS refers to in namespace NS.
+If it doesn't point anywhere, returns ALIAS."
+ (or (cider-resolve--get-in ns "aliases" alias)
+ alias))
+
+(defconst cider-resolve--prefix-regexp "\\`\\(?:#'\\)?\\([^/]+\\)/")
+
+(defun cider-resolve-var (ns var)
+ "Return a dict of the metadata of a clojure var VAR in namespace NS.
+VAR is a string.
+Return nil only if VAR cannot be resolved."
+ (let* ((var-ns (when (string-match cider-resolve--prefix-regexp var)
+ (cider-resolve-alias ns (match-string 1 var))))
+ (name (replace-regexp-in-string cider-resolve--prefix-regexp "" var)))
+ (or
+ (cider-resolve--get-in (or var-ns ns) "interns" name)
+ (unless var-ns
+ ;; If the var had no prefix, it might be referred.
+ (if-let ((referal (cider-resolve--get-in ns "refers" name)))
+ (cider-resolve-var ns referal)
+ ;; Or it might be from core.
+ (unless (equal ns "clojure.core")
+ (cider-resolve-var "clojure.core" name)))))))
+
+(defun cider-resolve-core-ns ()
+ "Return a dict of the core namespace for current connection.
+This will be clojure.core or cljs.core depending on `cider-repl-type'."
+ (when (cider-connected-p)
+ (with-current-buffer (cider-current-connection)
+ (cider-resolve--get-in (if (equal cider-repl-type "cljs")
+ "cljs.core"
+ "clojure.core")))))
+
+(defun cider-resolve-ns-symbols (ns)
+ "Return a plist of all valid symbols in NS.
+Each entry's value is the metadata of the var that the symbol refers to.
+NS can be the namespace name, or a dict of the namespace itself."
+ (when-let ((dict (if (stringp ns)
+ (cider-resolve--get-in ns)
+ ns)))
+ (nrepl-dbind-response dict (interns refers aliases)
+ (append (cdr interns)
+ (nrepl-dict-flat-map (lambda (alias namespace)
+ (nrepl-dict-flat-map (lambda (sym meta)
+ (list (concat alias "/" sym) meta))
+ (cider-resolve--get-in namespace "interns")))
+ aliases)))))
+
+(provide 'cider-resolve)
+;;; cider-resolve.el ends here
--- /dev/null
+;;; cider-scratch.el --- *scratch* buffer for Clojure -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2017 Bozhidar Batsov and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Imitate Emacs's *scratch* buffer.
+
+;;; Code:
+
+(require 'cider-interaction)
+(require 'clojure-mode)
+(require 'easymenu)
+
+(defvar cider-clojure-interaction-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map clojure-mode-map)
+ (define-key map (kbd "C-j") #'cider-eval-print-last-sexp)
+ (define-key map [remap paredit-newline] #'cider-eval-print-last-sexp)
+ (easy-menu-define cider-clojure-interaction-mode-menu map
+ "Menu for Clojure Interaction mode"
+ '("Clojure Interaction"
+ (["Eval and print last sexp" #'cider-eval-print-last-sexp]
+ "--"
+ ["Reset" #'cider-scratch-reset]
+ "--"
+ ["Set buffer connection" #'cider-assoc-buffer-with-connection]
+ ["Toggle buffer connection" #'cider-toggle-buffer-connection]
+ ["Reset buffer connection" #'cider-clear-buffer-local-connection])))
+ map))
+
+(defconst cider-scratch-buffer-name "*cider-scratch*")
+
+(push cider-scratch-buffer-name cider-ancillary-buffers)
+
+;;;###autoload
+(defun cider-scratch ()
+ "Go to the scratch buffer named `cider-scratch-buffer-name'."
+ (interactive)
+ (pop-to-buffer (cider-find-or-create-scratch-buffer)))
+
+(defun cider-find-or-create-scratch-buffer ()
+ "Find or create the scratch buffer."
+ (or (get-buffer cider-scratch-buffer-name)
+ (cider-create-scratch-buffer)))
+
+(define-derived-mode cider-clojure-interaction-mode clojure-mode "Clojure Interaction"
+ "Major mode for typing and evaluating Clojure forms.
+Like clojure-mode except that \\[cider-eval-print-last-sexp] evals the Lisp expression
+before point, and prints its value into the buffer, advancing point.
+
+\\{cider-clojure-interaction-mode-map}")
+
+(defun cider--scratch-insert-welcome-message ()
+ "Insert the welcome message for the scratch buffer."
+ (insert ";; This buffer is for Clojure experiments and evaluation.\n"
+ ";; Press C-j to evaluate the last expression.\n\n"))
+
+(defun cider-create-scratch-buffer ()
+ "Create a new scratch buffer."
+ (with-current-buffer (get-buffer-create cider-scratch-buffer-name)
+ (cider-clojure-interaction-mode)
+ (cider--scratch-insert-welcome-message)
+ (current-buffer)))
+
+(defun cider-scratch-reset ()
+ "Reset the current scratch buffer."
+ (interactive)
+ (erase-buffer)
+ (cider--scratch-insert-welcome-message))
+
+(provide 'cider-scratch)
+
+;;; cider-scratch.el ends here
--- /dev/null
+;;; cider-selector.el --- Buffer selection command inspired by SLIME's selector -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Buffer selection command inspired by SLIME's selector.
+
+;;; Code:
+
+(require 'cider-client)
+(require 'cider-interaction)
+(require 'cider-scratch)
+
+(defconst cider-selector-help-buffer "*CIDER Selector Help*"
+ "The name of the selector's help buffer.")
+
+(defvar cider-selector-methods nil
+ "List of buffer-selection methods for the `cider-selector' command.
+Each element is a list (KEY DESCRIPTION FUNCTION).
+DESCRIPTION is a one-line description of what the key selects.")
+
+(defvar cider-selector-other-window nil
+ "If non-nil use `switch-to-buffer-other-window'.")
+
+(defun cider--recently-visited-buffer (mode)
+ "Return the most recently visited buffer, deriving its `major-mode' from MODE.
+Only considers buffers that are not already visible."
+ (cl-loop for buffer in (buffer-list)
+ when (and (with-current-buffer buffer
+ (derived-mode-p mode))
+ ;; names starting with space are considered hidden by Emacs
+ (not (string-match-p "^ " (buffer-name buffer)))
+ (null (get-buffer-window buffer 'visible)))
+ return buffer
+ finally (error "Can't find unshown buffer in %S" mode)))
+
+;;;###autoload
+(defun cider-selector (&optional other-window)
+ "Select a new buffer by type, indicated by a single character.
+The user is prompted for a single character indicating the method by
+which to choose a new buffer. The `?' character describes then
+available methods. OTHER-WINDOW provides an optional target.
+
+See `def-cider-selector-method' for defining new methods."
+ (interactive)
+ (message "Select [%s]: "
+ (apply #'string (mapcar #'car cider-selector-methods)))
+ (let* ((cider-selector-other-window other-window)
+ (ch (save-window-excursion
+ (select-window (minibuffer-window))
+ (read-char)))
+ (method (cl-find ch cider-selector-methods :key #'car)))
+ (cond (method
+ (funcall (cl-caddr method)))
+ (t
+ (message "No method for character: ?\\%c" ch)
+ (ding)
+ (sleep-for 1)
+ (discard-input)
+ (cider-selector)))))
+
+(defmacro def-cider-selector-method (key description &rest body)
+ "Define a new `cider-select' buffer selection method.
+
+KEY is the key the user will enter to choose this method.
+
+DESCRIPTION is a one-line sentence describing how the method
+selects a buffer.
+
+BODY is a series of forms which are evaluated when the selector
+is chosen. The returned buffer is selected with
+`switch-to-buffer'."
+ (let ((method `(lambda ()
+ (let ((buffer (progn ,@body)))
+ (cond ((not (get-buffer buffer))
+ (message "No such buffer: %S" buffer)
+ (ding))
+ ((get-buffer-window buffer)
+ (select-window (get-buffer-window buffer)))
+ (cider-selector-other-window
+ (switch-to-buffer-other-window buffer))
+ (t
+ (switch-to-buffer buffer)))))))
+ `(setq cider-selector-methods
+ (cl-sort (cons (list ,key ,description ,method)
+ (cl-remove ,key cider-selector-methods :key #'car))
+ #'< :key #'car))))
+
+(def-cider-selector-method ?? "Selector help buffer."
+ (ignore-errors (kill-buffer cider-selector-help-buffer))
+ (with-current-buffer (get-buffer-create cider-selector-help-buffer)
+ (insert "CIDER Selector Methods:\n\n")
+ (cl-loop for (key line nil) in cider-selector-methods
+ do (insert (format "%c:\t%s\n" key line)))
+ (goto-char (point-min))
+ (help-mode)
+ (display-buffer (current-buffer) t))
+ (cider-selector)
+ (current-buffer))
+
+(cl-pushnew (list ?4 "Select in other window" (lambda () (cider-selector t)))
+ cider-selector-methods :key #'car)
+
+(def-cider-selector-method ?c
+ "Most recently visited clojure-mode buffer."
+ (cider--recently-visited-buffer 'clojure-mode))
+
+(def-cider-selector-method ?e
+ "Most recently visited emacs-lisp-mode buffer."
+ (cider--recently-visited-buffer 'emacs-lisp-mode))
+
+(def-cider-selector-method ?q "Abort."
+ (top-level))
+
+(def-cider-selector-method ?r
+ "Current REPL buffer."
+ (cider-current-repl-buffer))
+
+(def-cider-selector-method ?n
+ "Connections browser buffer."
+ (cider-connection-browser)
+ cider--connection-browser-buffer-name)
+
+(def-cider-selector-method ?m
+ "Current connection's *nrepl-messages* buffer."
+ (cider-current-messages-buffer))
+
+(def-cider-selector-method ?x
+ "*cider-error* buffer."
+ cider-error-buffer)
+
+(def-cider-selector-method ?d
+ "*cider-doc* buffer."
+ cider-doc-buffer)
+
+(declare-function cider-find-or-create-scratch-buffer "cider-scratch")
+(def-cider-selector-method ?s
+ "*cider-scratch* buffer."
+ (cider-find-or-create-scratch-buffer))
+
+(provide 'cider-selector)
+
+;;; cider-selector.el ends here
--- /dev/null
+;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2017 Jeff Valk, Bozhidar Batsov and CIDER contributors
+
+;; Author: Jeff Valk <jv@jeffvalk.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Stacktrace filtering and stack frame source navigation
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'cider-popup)
+(require 'button)
+(require 'easymenu)
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-client)
+(require 'cider-util)
+
+(require 'seq)
+
+;; Variables
+
+(defgroup cider-stacktrace nil
+ "Stacktrace filtering and navigation."
+ :prefix "cider-stacktrace-"
+ :group 'cider)
+
+(defcustom cider-stacktrace-fill-column t
+ "Fill column for error messages in stacktrace display.
+If nil, messages will not be wrapped. If truthy but non-numeric,
+`fill-column' will be used."
+ :type 'list
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.7.0"))
+
+(defcustom cider-stacktrace-default-filters '(tooling dup)
+ "Frame types to omit from initial stacktrace display."
+ :type 'list
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defcustom cider-stacktrace-print-length 50
+ "Set the maximum length of sequences in displayed cause data.
+
+This sets the value of Clojure's `*print-length*` when pretty printing the
+`ex-data` map for exception causes in the stacktrace that are instances of
+`IExceptionInfo`.
+
+Be advised that setting this to `nil` will cause the attempted printing of
+infinite data structures."
+ :type '(choice integer (const nil))
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-stacktrace-print-level 50
+ "Set the maximum level of nesting in displayed cause data.
+
+This sets the value of Clojure's `*print-level*` when pretty printing the
+`ex-data` map for exception causes in the stacktrace that are instances of
+`IExceptionInfo`.
+
+Be advised that setting this to `nil` will cause the attempted printing of
+cyclical data structures."
+ :type '(choice integer (const nil))
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.8.0"))
+
+(defvar cider-stacktrace-detail-max 2
+ "The maximum detail level for causes.")
+
+(defvar-local cider-stacktrace-hidden-frame-count 0)
+(defvar-local cider-stacktrace-filters nil)
+(defvar-local cider-stacktrace-prior-filters nil)
+(defvar-local cider-stacktrace-cause-visibility nil)
+
+(defconst cider-error-buffer "*cider-error*")
+(add-to-list 'cider-ancillary-buffers cider-error-buffer)
+
+(defcustom cider-stacktrace-suppressed-errors '()
+ "A set of errors that won't make the stacktrace buffer 'pop-over' your active window.
+The error types are represented as strings."
+ :type 'list
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.12.0"))
+
+;; Faces
+
+(defface cider-stacktrace-error-class-face
+ '((t (:inherit font-lock-warning-face)))
+ "Face for exception class names"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-error-message-face
+ '((t (:inherit font-lock-doc-face)))
+ "Face for exception messages"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.7.0"))
+
+(defface cider-stacktrace-filter-shown-face
+ '((t (:inherit button :underline t :weight normal)))
+ "Face for filter buttons representing frames currently visible"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-filter-hidden-face
+ '((t (:inherit button :underline nil :weight normal)))
+ "Face for filter buttons representing frames currently filtered out"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-face
+ '((t (:inherit default)))
+ "Face for stack frame text"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-ns-face
+ '((t (:inherit font-lock-comment-face)))
+ "Face for stack frame namespace name"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-fn-face
+ '((t (:inherit default :weight bold)))
+ "Face for stack frame function name"
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-promoted-button-face
+ '((((type graphic))
+ :box (:line-width 3 :style released-button)
+ :inherit error)
+ (t :inverse-video t))
+ "A button with this face represents a promoted (non-suppressed) error type."
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.12.0"))
+
+(defface cider-stacktrace-suppressed-button-face
+ '((((type graphic))
+ :box (:line-width 3 :style pressed-button)
+ :inherit widget-inactive-face)
+ (t :inverse-video t))
+ "A button with this face represents a suppressed error type."
+ :group 'cider-stacktrace
+ :package-version '(cider . "0.12.0"))
+
+;; Colors & Theme Support
+
+(defvar cider-stacktrace-frames-background-color
+ (cider-scale-background-color)
+ "Background color for stacktrace frames.")
+
+(defadvice enable-theme (after cider-stacktrace-adapt-to-theme activate)
+ "When theme is changed, update `cider-stacktrace-frames-background-color'."
+ (setq cider-stacktrace-frames-background-color (cider-scale-background-color)))
+
+
+;; Mode & key bindings
+
+(defvar cider-stacktrace-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "M-p") #'cider-stacktrace-previous-cause)
+ (define-key map (kbd "M-n") #'cider-stacktrace-next-cause)
+ (define-key map (kbd "M-.") #'cider-stacktrace-jump)
+ (define-key map "q" #'cider-popup-buffer-quit-function)
+ (define-key map "j" #'cider-stacktrace-toggle-java)
+ (define-key map "c" #'cider-stacktrace-toggle-clj)
+ (define-key map "r" #'cider-stacktrace-toggle-repl)
+ (define-key map "t" #'cider-stacktrace-toggle-tooling)
+ (define-key map "d" #'cider-stacktrace-toggle-duplicates)
+ (define-key map "a" #'cider-stacktrace-toggle-all)
+ (define-key map "1" #'cider-stacktrace-cycle-cause-1)
+ (define-key map "2" #'cider-stacktrace-cycle-cause-2)
+ (define-key map "3" #'cider-stacktrace-cycle-cause-3)
+ (define-key map "4" #'cider-stacktrace-cycle-cause-4)
+ (define-key map "5" #'cider-stacktrace-cycle-cause-5)
+ (define-key map "0" #'cider-stacktrace-cycle-all-causes)
+ (define-key map (kbd "TAB") #'cider-stacktrace-cycle-current-cause)
+ (define-key map [backtab] #'cider-stacktrace-cycle-all-causes)
+ (easy-menu-define cider-stacktrace-mode-menu map
+ "Menu for CIDER's stacktrace mode"
+ '("Stacktrace"
+ ["Previous cause" cider-stacktrace-previous-cause]
+ ["Next cause" cider-stacktrace-next-cause]
+ "--"
+ ["Jump to frame source" cider-stacktrace-jump]
+ "--"
+ ["Cycle current cause detail" cider-stacktrace-cycle-current-cause]
+ ["Cycle cause #1 detail" cider-stacktrace-cycle-cause-1]
+ ["Cycle cause #2 detail" cider-stacktrace-cycle-cause-2]
+ ["Cycle cause #3 detail" cider-stacktrace-cycle-cause-3]
+ ["Cycle cause #4 detail" cider-stacktrace-cycle-cause-4]
+ ["Cycle cause #5 detail" cider-stacktrace-cycle-cause-5]
+ ["Cycle all cause detail" cider-stacktrace-cycle-all-causes]
+ "--"
+ ["Show/hide Java frames" cider-stacktrace-toggle-java]
+ ["Show/hide Clojure frames" cider-stacktrace-toggle-clj]
+ ["Show/hide REPL frames" cider-stacktrace-toggle-repl]
+ ["Show/hide tooling frames" cider-stacktrace-toggle-tooling]
+ ["Show/hide duplicate frames" cider-stacktrace-toggle-duplicates]
+ ["Show/hide all frames" cider-stacktrace-toggle-all]))
+ map))
+
+(define-derived-mode cider-stacktrace-mode special-mode "Stacktrace"
+ "Major mode for filtering and navigating CIDER stacktraces.
+
+\\{cider-stacktrace-mode-map}"
+ (setq buffer-read-only t)
+ (when cider-special-mode-truncate-lines
+ (setq-local truncate-lines t))
+ (setq-local electric-indent-chars nil)
+ (setq-local cider-stacktrace-prior-filters nil)
+ (setq-local cider-stacktrace-hidden-frame-count 0)
+ (setq-local cider-stacktrace-filters cider-stacktrace-default-filters)
+ (setq-local cider-stacktrace-cause-visibility (make-vector 10 0)))
+
+
+;; Stacktrace filtering
+
+(defun cider-stacktrace-indicate-filters (filters)
+ "Update enabled state of filter buttons.
+
+Find buttons with a 'filter property; if filter is a member of FILTERS, or
+if filter is nil ('show all') and the argument list is non-nil, fontify the
+button as disabled. Upon finding text with a 'hidden-count property, stop
+searching and update the hidden count text."
+ (with-current-buffer cider-error-buffer
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ (get-face (lambda (hide)
+ (if hide
+ 'cider-stacktrace-filter-hidden-face
+ 'cider-stacktrace-filter-shown-face))))
+ ;; Toggle buttons
+ (while (not (or (get-text-property (point) 'hidden-count) (eobp)))
+ (let ((button (button-at (point))))
+ (when button
+ (let* ((filter (button-get button 'filter))
+ (face (funcall get-face (if filter
+ (member filter filters)
+ filters))))
+ (button-put button 'face face)))
+ (goto-char (or (next-property-change (point))
+ (point-max)))))
+ ;; Update hidden count
+ (when (and (get-text-property (point) 'hidden-count)
+ (re-search-forward "[0-9]+" (line-end-position) t))
+ (replace-match
+ (number-to-string cider-stacktrace-hidden-frame-count)))))))
+
+(defun cider-stacktrace-apply-filters (filters)
+ "Set visibility on stack frames using FILTERS.
+Update `cider-stacktrace-hidden-frame-count' and indicate filters applied.
+Currently collapsed stacktraces are ignored, and do not contribute to the
+hidden count."
+ (with-current-buffer cider-error-buffer
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ (hidden 0))
+ (while (not (eobp))
+ (unless (get-text-property (point) 'collapsed)
+ (let* ((flags (get-text-property (point) 'flags))
+ (hide (if (seq-intersection filters flags) t nil)))
+ (when hide (cl-incf hidden))
+ (put-text-property (point) (line-beginning-position 2) 'invisible hide)))
+ (forward-line 1))
+ (setq cider-stacktrace-hidden-frame-count hidden)))
+ (cider-stacktrace-indicate-filters filters)))
+
+
+(defun cider-stacktrace-apply-cause-visibility ()
+ "Apply `cider-stacktrace-cause-visibility' to causes and reapply filters."
+ (with-current-buffer cider-error-buffer
+ (save-excursion
+ (goto-char (point-min))
+ (cl-flet ((next-detail (end)
+ (when-let ((pos (next-single-property-change (point) 'detail)))
+ (when (< pos end)
+ (goto-char pos)))))
+ (let ((inhibit-read-only t))
+ ;; For each cause...
+ (while (cider-stacktrace-next-cause)
+ (let* ((num (get-text-property (point) 'cause))
+ (level (elt cider-stacktrace-cause-visibility num))
+ (cause-end (cadr (cider-property-bounds 'cause))))
+ ;; For each detail level within the cause, set visibility.
+ (while (next-detail cause-end)
+ (let* ((detail (get-text-property (point) 'detail))
+ (detail-end (cadr (cider-property-bounds 'detail)))
+ (hide (if (> detail level) t nil)))
+ (add-text-properties (point) detail-end
+ (list 'invisible hide
+ 'collapsed hide))))))))
+ (cider-stacktrace-apply-filters
+ cider-stacktrace-filters))))
+
+;;; Internal/Middleware error suppression
+
+(defun cider-stacktrace-some-suppressed-errors-p (error-types)
+ "Return intersection of ERROR-TYPES and CIDER-STACKTRACE-SUPPRESSED-ERRORS.
+I.e, Return non-nil if the seq ERROR-TYPES shares any elements with
+`cider-stacktrace-suppressed-errors'. This means that even a 'well-behaved' (ie,
+promoted) error type will be 'guilty by association' if grouped with a
+suppressed error type."
+ (seq-intersection error-types cider-stacktrace-suppressed-errors))
+
+(defun cider-stacktrace-suppress-error (error-type)
+ "Destructively add element ERROR-TYPE to the `cider-stacktrace-suppressed-errors' set."
+ (setq cider-stacktrace-suppressed-errors
+ (cl-adjoin error-type cider-stacktrace-suppressed-errors :test 'equal)))
+
+(defun cider-stacktrace-promote-error (error-type)
+ "Destructively remove element ERROR-TYPE from the `cider-stacktrace-suppressed-errors' set."
+ (setq cider-stacktrace-suppressed-errors
+ (remove error-type cider-stacktrace-suppressed-errors)))
+
+(defun cider-stacktrace-suppressed-error-p (error-type)
+ "Return non-nil if element ERROR-TYPE is a member of the `cider-stacktrace-suppressed-errors' set."
+ (member error-type cider-stacktrace-suppressed-errors))
+
+;; Interactive functions
+
+(defun cider-stacktrace-previous-cause ()
+ "Move point to the previous exception cause, if one exists."
+ (interactive)
+ (with-current-buffer cider-error-buffer
+ (when-let ((pos (previous-single-property-change (point) 'cause)))
+ (goto-char pos))))
+
+(defun cider-stacktrace-next-cause ()
+ "Move point to the next exception cause, if one exists."
+ (interactive)
+ (with-current-buffer cider-error-buffer
+ (when-let ((pos (next-single-property-change (point) 'cause)))
+ (goto-char pos))))
+
+(defun cider-stacktrace-cycle-cause (num &optional level)
+ "Update element NUM of `cider-stacktrace-cause-visibility', optionally to LEVEL.
+If LEVEL is not specified, its current value is incremented. When it reaches 3,
+it wraps to 0."
+ (let ((level (or level (1+ (elt cider-stacktrace-cause-visibility num)))))
+ (aset cider-stacktrace-cause-visibility num (mod level 3))
+ (cider-stacktrace-apply-cause-visibility)))
+
+(defun cider-stacktrace-cycle-all-causes ()
+ "Cycle the visibility of all exception causes."
+ (interactive)
+ (with-current-buffer cider-error-buffer
+ (save-excursion
+ ;; Find nearest cause.
+ (unless (get-text-property (point) 'cause)
+ (cider-stacktrace-next-cause)
+ (unless (get-text-property (point) 'cause)
+ (cider-stacktrace-previous-cause)))
+ ;; Cycle its level, and apply that to all causes.
+ (let* ((num (get-text-property (point) 'cause))
+ (level (1+ (elt cider-stacktrace-cause-visibility num))))
+ (setq-local cider-stacktrace-cause-visibility
+ (make-vector 10 (mod level 3)))
+ (cider-stacktrace-apply-cause-visibility)))))
+
+(defun cider-stacktrace-cycle-current-cause ()
+ "Cycle the visibility of current exception at point, if any."
+ (interactive)
+ (with-current-buffer cider-error-buffer
+ (when-let ((num (get-text-property (point) 'cause)))
+ (cider-stacktrace-cycle-cause num))))
+
+(defun cider-stacktrace-cycle-cause-1 ()
+ "Cycle the visibility of exception cause #1."
+ (interactive)
+ (cider-stacktrace-cycle-cause 1))
+
+(defun cider-stacktrace-cycle-cause-2 ()
+ "Cycle the visibility of exception cause #2."
+ (interactive)
+ (cider-stacktrace-cycle-cause 2))
+
+(defun cider-stacktrace-cycle-cause-3 ()
+ "Cycle the visibility of exception cause #3."
+ (interactive)
+ (cider-stacktrace-cycle-cause 3))
+
+(defun cider-stacktrace-cycle-cause-4 ()
+ "Cycle the visibility of exception cause #4."
+ (interactive)
+ (cider-stacktrace-cycle-cause 4))
+
+(defun cider-stacktrace-cycle-cause-5 ()
+ "Cycle the visibility of exception cause #5."
+ (interactive)
+ (cider-stacktrace-cycle-cause 5))
+
+
+(defun cider-stacktrace-toggle-all ()
+ "Reset `cider-stacktrace-filters' if present; otherwise restore prior filters."
+ (interactive)
+ (when cider-stacktrace-filters
+ (setq-local cider-stacktrace-prior-filters
+ cider-stacktrace-filters))
+ (cider-stacktrace-apply-filters
+ (setq cider-stacktrace-filters
+ (unless cider-stacktrace-filters ; when current filters are nil,
+ cider-stacktrace-prior-filters)))) ; reenable prior filter set
+
+(defun cider-stacktrace-toggle (flag)
+ "Update `cider-stacktrace-filters' to add or remove FLAG, and apply filters."
+ (cider-stacktrace-apply-filters
+ (setq cider-stacktrace-filters
+ (if (memq flag cider-stacktrace-filters)
+ (remq flag cider-stacktrace-filters)
+ (cons flag cider-stacktrace-filters)))))
+
+(defun cider-stacktrace-toggle-java ()
+ "Toggle display of Java stack frames."
+ (interactive)
+ (cider-stacktrace-toggle 'java))
+
+(defun cider-stacktrace-toggle-clj ()
+ "Toggle display of Clojure stack frames."
+ (interactive)
+ (cider-stacktrace-toggle 'clj))
+
+(defun cider-stacktrace-toggle-repl ()
+ "Toggle display of REPL stack frames."
+ (interactive)
+ (cider-stacktrace-toggle 'repl))
+
+(defun cider-stacktrace-toggle-tooling ()
+ "Toggle display of Tooling stack frames (compiler, nREPL middleware, etc)."
+ (interactive)
+ (cider-stacktrace-toggle 'tooling))
+
+(defun cider-stacktrace-toggle-duplicates ()
+ "Toggle display of stack frames that are duplicates of their descendents."
+ (interactive)
+ (cider-stacktrace-toggle 'dup))
+
+;; Text button functions
+
+(defun cider-stacktrace-filter (button)
+ "Apply filter(s) indicated by the BUTTON."
+ (with-temp-message "Filters may also be toggled with the keyboard."
+ (let ((flag (button-get button 'filter)))
+ (if flag
+ (cider-stacktrace-toggle flag)
+ (cider-stacktrace-toggle-all)))
+ (sit-for 5)))
+
+(defun cider-stacktrace-toggle-suppression (button)
+ "Toggle stacktrace pop-over/pop-under behavior for the `error-type' in BUTTON.
+Achieved by destructively manipulating the `cider-stacktrace-suppressed-errors' set."
+ (with-current-buffer cider-error-buffer
+ (let ((inhibit-read-only t)
+ (suppressed (button-get button 'suppressed))
+ (error-type (button-get button 'error-type)))
+ (if suppressed
+ (progn
+ (cider-stacktrace-promote-error error-type)
+ (button-put button 'face 'cider-stacktrace-promoted-button-face)
+ (button-put button 'help-echo "Click to suppress these stacktraces."))
+ (cider-stacktrace-suppress-error error-type)
+ (button-put button 'face 'cider-stacktrace-suppressed-button-face)
+ (button-put button 'help-echo "Click to promote these stacktraces."))
+ (button-put button 'suppressed (not suppressed)))))
+
+(defun cider-stacktrace-navigate (button)
+ "Navigate to the stack frame source represented by the BUTTON."
+ (let* ((var (button-get button 'var))
+ (class (button-get button 'class))
+ (method (button-get button 'method))
+ (info (or (and var (cider-var-info var))
+ (and class method (cider-member-info class method))
+ (nrepl-dict)))
+ ;; Stacktrace returns more accurate line numbers, but if the function's
+ ;; line was unreliable, then so is the stacktrace by the same amount.
+ ;; Set `line-shift' to the number of lines from the beginning of defn.
+ (line-shift (- (or (button-get button 'line) 0)
+ (or (nrepl-dict-get info "line") 1)))
+ ;; give priority to `info` files as `info` returns full paths.
+ (info (nrepl-dict-put info "file" (or (nrepl-dict-get info "file")
+ (button-get button 'file)))))
+ (cider--jump-to-loc-from-info info t)
+ (forward-line line-shift)
+ (back-to-indentation)))
+
+(defun cider-stacktrace-jump (&optional arg)
+ "Find definition for stack frame at point, if available.
+The prefix ARG and `cider-prompt-for-symbol' decide whether to
+prompt and whether to use a new window. Similar to `cider-find-var'."
+ (interactive "P")
+ (let ((button (button-at (point))))
+ (if (and button (button-get button 'line))
+ (cider-stacktrace-navigate button)
+ (cider-find-var arg))))
+
+
+;; Rendering
+
+(defun cider-stacktrace-emit-indented (text indent &optional fill)
+ "Insert TEXT, and INDENT and optionally FILL the entire block."
+ (let ((beg (point)))
+ (insert text)
+ (goto-char beg)
+ (while (not (eobp))
+ (insert indent)
+ (forward-line))
+ (when (and fill cider-stacktrace-fill-column)
+ (when (and (numberp cider-stacktrace-fill-column))
+ (setq-local fill-column cider-stacktrace-fill-column))
+ (setq-local fill-prefix indent)
+ (fill-region beg (point)))))
+
+(defun cider-stacktrace-render-filters (buffer filters)
+ "Emit into BUFFER toggle buttons for each of the FILTERS."
+ (with-current-buffer buffer
+ (insert " Show: ")
+ (dolist (filter filters)
+ (insert-text-button (car filter)
+ 'filter (cadr filter)
+ 'follow-link t
+ 'action 'cider-stacktrace-filter
+ 'help-echo (format "Toggle %s stack frames"
+ (car filter)))
+ (insert " "))
+ (let ((hidden "(0 frames hidden)"))
+ (put-text-property 0 (length hidden) 'hidden-count t hidden)
+ (insert " " hidden "\n"))))
+
+(defun cider-stacktrace-render-suppression-toggle (buffer error-types)
+ "Emit into BUFFER toggle buttons for each of the ERROR-TYPES leading this stacktrace buffer."
+ (with-current-buffer buffer
+ (when error-types
+ (insert " This is an unexpected CIDER middleware error.\n Please submit a bug report via `")
+ (insert-text-button "M-x cider-report-bug"
+ 'follow-link t
+ 'action (lambda (_button) (cider-report-bug))
+ 'help-echo "Report bug to the CIDER team.")
+ (insert "`.\n\n")
+ (insert "\
+ If these stacktraces are occuring frequently, consider using the
+ button(s) below to suppress these types of errors for the duration of
+ your current CIDER session. The stacktrace buffer will still be
+ generated, but it will \"pop under\" your current buffer instead of
+ \"popping over\". The button toggles this behavior.\n\n ")
+ (dolist (error-type error-types)
+ (let ((suppressed (cider-stacktrace-suppressed-error-p error-type)))
+ (insert-text-button (format "%s %s" (if suppressed "Promote" "Suppress") error-type)
+ 'follow-link t
+ 'error-type error-type
+ 'action 'cider-stacktrace-toggle-suppression
+ 'suppressed suppressed
+ 'face (if suppressed
+ 'cider-stacktrace-suppressed-button-face
+ 'cider-stacktrace-promoted-button-face)
+ 'help-echo (format "Click to %s these stacktraces."
+ (if suppressed "promote" "suppress"))))
+ (insert " ")))))
+
+(defun cider-stacktrace-render-frame (buffer frame)
+ "Emit into BUFFER function call site info for the stack FRAME.
+This associates text properties to enable filtering and source navigation."
+ (with-current-buffer buffer
+ (nrepl-dbind-response frame (file line flags class method name var ns fn)
+ (let ((flags (mapcar 'intern flags))) ; strings -> symbols
+ (insert-text-button (format "%26s:%5d %s/%s"
+ (if (member 'repl flags) "REPL" file) line
+ (if (member 'clj flags) ns class)
+ (if (member 'clj flags) fn method))
+ 'var var 'class class 'method method
+ 'name name 'file file 'line line
+ 'flags flags 'follow-link t
+ 'action 'cider-stacktrace-navigate
+ 'help-echo "View source at this location"
+ 'font-lock-face 'cider-stacktrace-face
+ 'type 'cider-plain-button)
+ (save-excursion
+ (let ((p4 (point))
+ (p1 (search-backward " "))
+ (p2 (search-forward "/"))
+ (p3 (search-forward-regexp "[^/$]+")))
+ (put-text-property p1 p4 'font-lock-face 'cider-stacktrace-ns-face)
+ (put-text-property p2 p3 'font-lock-face 'cider-stacktrace-fn-face)))
+ (insert "\n")))))
+
+(declare-function cider-jump-to "cider-interaction")
+
+(defun cider-stacktrace-render-compile-error (buffer cause)
+ "Emit into BUFFER the compile error CAUSE, and enable jumping to it."
+ (with-current-buffer buffer
+ (nrepl-dbind-response cause (file path line column)
+ (let ((indent " ")
+ (message-face 'cider-stacktrace-error-message-face))
+ (insert indent)
+ (insert (propertize "Error compiling " 'font-lock-face message-face))
+ (insert-text-button path 'compile-error t
+ 'file file 'line line 'column column 'follow-link t
+ 'action (lambda (_button)
+ (cider-jump-to (cider-find-file file)
+ (cons line column))))
+ (insert (propertize (format " at (%d:%d)" line column)
+ 'font-lock-face message-face))))))
+
+(defun cider-stacktrace-render-cause (buffer cause num note)
+ "Emit into BUFFER the CAUSE NUM, exception class, message, data, and NOTE."
+ (with-current-buffer buffer
+ (nrepl-dbind-response cause (class message data stacktrace)
+ (let ((indent " ")
+ (class-face 'cider-stacktrace-error-class-face)
+ (message-face 'cider-stacktrace-error-message-face))
+ (cider-propertize-region `(cause ,num)
+ ;; Detail level 0: exception class
+ (cider-propertize-region '(detail 0)
+ (insert (format "%d. " num)
+ (propertize note 'font-lock-face 'font-lock-comment-face) " "
+ (propertize class 'font-lock-face class-face)
+ "\n"))
+ ;; Detail level 1: message + ex-data
+ (cider-propertize-region '(detail 1)
+ (if (equal class "clojure.lang.Compiler$CompilerException")
+ (cider-stacktrace-render-compile-error buffer cause)
+ (cider-stacktrace-emit-indented
+ (propertize (or message "(No message)")
+ 'font-lock-face message-face) indent t))
+ (insert "\n")
+ (when data
+ (cider-stacktrace-emit-indented
+ (cider-font-lock-as-clojure data) indent nil)))
+ ;; Detail level 2: stacktrace
+ (cider-propertize-region '(detail 2)
+ (insert "\n")
+ (let ((beg (point))
+ (bg `(:background ,cider-stacktrace-frames-background-color)))
+ (dolist (frame stacktrace)
+ (cider-stacktrace-render-frame buffer frame))
+ (overlay-put (make-overlay beg (point)) 'font-lock-face bg)))
+ ;; Add line break between causes, even when collapsed.
+ (cider-propertize-region '(detail 0)
+ (insert "\n")))))))
+
+(defun cider-stacktrace-initialize (causes)
+ "Set and apply CAUSES initial visibility, filters, and cursor position."
+ (nrepl-dbind-response (car causes) (class)
+ (let ((compile-error-p (equal class "clojure.lang.Compiler$CompilerException")))
+ ;; Partially display outermost cause if it's a compiler exception (the
+ ;; description reports reader location of the error).
+ (when compile-error-p
+ (cider-stacktrace-cycle-cause (length causes) 1))
+ ;; Fully display innermost cause. This also applies visibility/filters.
+ (cider-stacktrace-cycle-cause 1 cider-stacktrace-detail-max)
+ ;; Move point (DWIM) to the compile error location if present, or to the
+ ;; first stacktrace frame in displayed cause otherwise. If the error
+ ;; buffer is visible in a window, ensure that window is selected while moving
+ ;; point, so as to move both the buffer's and the window's point.
+ (with-selected-window (or (get-buffer-window cider-error-buffer)
+ (selected-window))
+ (with-current-buffer cider-error-buffer
+ (goto-char (point-min))
+ (if compile-error-p
+ (goto-char (next-single-property-change (point) 'compile-error))
+ (progn
+ (while (cider-stacktrace-next-cause))
+ (goto-char (next-single-property-change (point) 'flags)))))))))
+
+(defun cider-stacktrace-render (buffer causes &optional error-types)
+ "Emit into BUFFER useful stacktrace information for the CAUSES.
+Takes an optional ERROR-TYPES list which will render a 'suppression' toggle
+that alters the pop-over/pop-under behavorior of the stacktrace buffers
+created by these types of errors. The suppressed errors set can be customized
+through the `cider-stacktrace-suppressed-errors' variable."
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert "\n")
+ ;; Stacktrace filters
+ (cider-stacktrace-render-filters
+ buffer
+ `(("Clojure" clj) ("Java" java) ("REPL" repl)
+ ("Tooling" tooling) ("Duplicates" dup) ("All" ,nil)))
+ (insert "\n")
+ ;; Option to suppress internal/middleware errors
+ (when error-types
+ (cider-stacktrace-render-suppression-toggle buffer error-types)
+ (insert "\n\n"))
+ ;; Stacktrace exceptions & frames
+ (let ((num (length causes)))
+ (dolist (cause causes)
+ (let ((note (if (= num (length causes)) "Unhandled" "Caused by")))
+ (cider-stacktrace-render-cause buffer cause num note)
+ (setq num (1- num))))))
+ (cider-stacktrace-initialize causes)
+ (font-lock-refresh-defaults)))
+
+(provide 'cider-stacktrace)
+
+;;; cider-stacktrace.el ends here
--- /dev/null
+;;; cider-test.el --- Test result viewer -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2017 Jeff Valk, Bozhidar Batsov and CIDER contributors
+
+;; Author: Jeff Valk <jvNOSPAMjeffvalk.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; This provides execution, reporting, and navigation support for Clojure tests,
+;; specifically using the `clojure.test' machinery. This functionality replaces
+;; the venerable `clojure-test-mode' (deprecated in June 2014), and relies on
+;; nREPL middleware for report running and session support.
+
+;;; Code:
+
+(require 'cider-common)
+(require 'cider-client)
+(require 'cider-popup)
+(require 'cider-stacktrace)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-overlays)
+
+(require 'button)
+(require 'easymenu)
+(require 'seq)
+
+;;; Variables
+
+(defgroup cider-test nil
+ "Presentation and navigation for test results."
+ :prefix "cider-test-"
+ :group 'cider)
+
+(defcustom cider-test-show-report-on-success nil
+ "Whether to show the `*cider-test-report*` buffer on passing tests."
+ :type 'boolean
+ :group 'cider-test
+ :package-version '(cider . "0.8.0"))
+
+(defcustom cider-auto-select-test-report-buffer t
+ "Determines if the test-report buffer should be auto-selected."
+ :type 'boolean
+ :group 'cider-test
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-test-defining-forms '("deftest" "defspec")
+ "Forms that define individual tests.
+CIDER considers the top-level form around point to define a test if the
+form starts with one of these forms.
+Add to this list to have CIDER recognize additional test defining macros."
+ :type '(repeat string)
+ :group 'cider-test
+ :package-version '(cider . "0.15.0"))
+
+(defvar cider-test-last-summary nil
+ "The summary of the last run test.")
+
+(defvar cider-test-last-results nil
+ "The results of the last run test.")
+
+(defconst cider-test-report-buffer "*cider-test-report*"
+ "Buffer name in which to display test reports.")
+(add-to-list 'cider-ancillary-buffers cider-test-report-buffer)
+
+
+;;; Faces
+
+(defface cider-test-failure-face
+ '((((class color) (background light))
+ :background "orange red")
+ (((class color) (background dark))
+ :background "firebrick"))
+ "Face for failed tests."
+ :group 'cider-test
+ :package-version '(cider . "0.7.0"))
+
+(defface cider-test-error-face
+ '((((class color) (background light))
+ :background "orange1")
+ (((class color) (background dark))
+ :background "orange4"))
+ "Face for erring tests."
+ :group 'cider-test
+ :package-version '(cider . "0.7.0"))
+
+(defface cider-test-success-face
+ '((((class color) (background light))
+ :foreground "black"
+ :background "green")
+ (((class color) (background dark))
+ :foreground "black"
+ :background "green"))
+ "Face for passing tests."
+ :group 'cider-test
+ :package-version '(cider . "0.7.0"))
+
+
+;; Colors & Theme Support
+
+(defvar cider-test-items-background-color
+ (cider-scale-background-color)
+ "Background color for test assertion items.")
+
+(defadvice enable-theme (after cider-test-adapt-to-theme activate)
+ "When theme is changed, update `cider-test-items-background-color'."
+ (setq cider-test-items-background-color (cider-scale-background-color)))
+
+
+;;; Report mode & key bindings
+;; The primary mode of interacting with test results is the report buffer, which
+;; allows navigation among tests, jumping to test definitions, expected/actual
+;; diff-ing, and cause/stacktrace inspection for test errors.
+
+(defvar cider-test-commands-map
+ (let ((map (define-prefix-command 'cider-test-commands-map)))
+ ;; Duplicates of keys below with C- for convenience
+ (define-key map (kbd "C-r") #'cider-test-rerun-failed-tests)
+ (define-key map (kbd "C-t") #'cider-test-run-test)
+ (define-key map (kbd "C-g") #'cider-test-rerun-test)
+ (define-key map (kbd "C-n") #'cider-test-run-ns-tests)
+ (define-key map (kbd "C-l") #'cider-test-run-loaded-tests)
+ (define-key map (kbd "C-p") #'cider-test-run-project-tests)
+ (define-key map (kbd "C-b") #'cider-test-show-report)
+ ;; Single-key bindings defined last for display in menu
+ (define-key map (kbd "r") #'cider-test-rerun-failed-tests)
+ (define-key map (kbd "t") #'cider-test-run-test)
+ (define-key map (kbd "g") #'cider-test-rerun-test)
+ (define-key map (kbd "n") #'cider-test-run-ns-tests)
+ (define-key map (kbd "l") #'cider-test-run-loaded-tests)
+ (define-key map (kbd "p") #'cider-test-run-project-tests)
+ (define-key map (kbd "b") #'cider-test-show-report)
+ map))
+
+(defconst cider-test-menu
+ '("Test"
+ ["Run test" cider-test-run-test]
+ ["Run namespace tests" cider-test-run-ns-tests]
+ ["Run all loaded tests" cider-test-run-loaded-tests]
+ ["Run all project tests" cider-test-run-project-tests]
+ ["Run tests after load-file" cider-auto-test-mode
+ :style toggle :selected cider-auto-test-mode]
+ "--"
+ ["Interrupt running tests" cider-interrupt]
+ ["Rerun failed/erring tests" cider-test-rerun-failed-tests]
+ ["Show test report" cider-test-show-report]
+ "--"
+ ["Configure testing" (customize-group 'cider-test)])
+ "CIDER test submenu.")
+
+(defvar cider-test-report-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-c ,") 'cider-test-commands-map)
+ (define-key map (kbd "C-c C-t") 'cider-test-commands-map)
+ (define-key map (kbd "M-p") #'cider-test-previous-result)
+ (define-key map (kbd "M-n") #'cider-test-next-result)
+ (define-key map (kbd "M-.") #'cider-test-jump)
+ (define-key map (kbd "<backtab>") #'cider-test-previous-result)
+ (define-key map (kbd "TAB") #'cider-test-next-result)
+ (define-key map (kbd "RET") #'cider-test-jump)
+ (define-key map (kbd "t") #'cider-test-jump)
+ (define-key map (kbd "d") #'cider-test-ediff)
+ (define-key map (kbd "e") #'cider-test-stacktrace)
+ ;; `f' for "run failed".
+ (define-key map "f" #'cider-test-rerun-failed-tests)
+ (define-key map "n" #'cider-test-run-ns-tests)
+ (define-key map "l" #'cider-test-run-loaded-tests)
+ (define-key map "p" #'cider-test-run-project-tests)
+ ;; `g' generally reloads the buffer. The closest thing we have to that is
+ ;; "run the test at point". But it's not as nice as rerunning all tests in
+ ;; this buffer.
+ (define-key map "g" #'cider-test-run-test)
+ (define-key map "q" #'cider-popup-buffer-quit-function)
+ (easy-menu-define cider-test-report-mode-menu map
+ "Menu for CIDER's test result mode"
+ '("Test-Report"
+ ["Previous result" cider-test-previous-result]
+ ["Next result" cider-test-next-result]
+ "--"
+ ["Rerun current test" cider-test-run-test]
+ ["Rerun failed/erring tests" cider-test-rerun-failed-tests]
+ ["Run all ns tests" cider-test-run-ns-tests]
+ ["Run all loaded tests" cider-test-run-loaded-tests]
+ ["Run all project tests" cider-test-run-project-tests]
+ "--"
+ ["Jump to test definition" cider-test-jump]
+ ["Display test error" cider-test-stacktrace]
+ ["Display expected/actual diff" cider-test-ediff]))
+ map))
+
+(define-derived-mode cider-test-report-mode fundamental-mode "Test Report"
+ "Major mode for presenting Clojure test results.
+
+\\{cider-test-report-mode-map}"
+ (setq buffer-read-only t)
+ (when cider-special-mode-truncate-lines
+ (setq-local truncate-lines t))
+ (setq-local electric-indent-chars nil))
+
+;; Report navigation
+
+(defun cider-test-show-report ()
+ "Show the test report buffer, if one exists."
+ (interactive)
+ (if-let ((report-buffer (get-buffer cider-test-report-buffer)))
+ (switch-to-buffer report-buffer)
+ (message "No test report buffer")))
+
+(defun cider-test-previous-result ()
+ "Move point to the previous test result, if one exists."
+ (interactive)
+ (with-current-buffer (get-buffer cider-test-report-buffer)
+ (when-let ((pos (previous-single-property-change (point) 'type)))
+ (if (get-text-property pos 'type)
+ (goto-char pos)
+ (when-let ((pos (previous-single-property-change pos 'type)))
+ (goto-char pos))))))
+
+(defun cider-test-next-result ()
+ "Move point to the next test result, if one exists."
+ (interactive)
+ (with-current-buffer (get-buffer cider-test-report-buffer)
+ (when-let ((pos (next-single-property-change (point) 'type)))
+ (if (get-text-property pos 'type)
+ (goto-char pos)
+ (when-let ((pos (next-single-property-change pos 'type)))
+ (goto-char pos))))))
+
+(defun cider-test-jump (&optional arg)
+ "Find definition for test at point, if available.
+The prefix ARG and `cider-prompt-for-symbol' decide whether to
+prompt and whether to use a new window. Similar to `cider-find-var'."
+ (interactive "P")
+ (let ((ns (get-text-property (point) 'ns))
+ (var (get-text-property (point) 'var))
+ (line (get-text-property (point) 'line)))
+ (if (and ns var)
+ (cider-find-var arg (concat ns "/" var) line)
+ (cider-find-var arg))))
+
+;;; Error stacktraces
+
+(defvar cider-auto-select-error-buffer)
+
+(defun cider-test-stacktrace-for (ns var index)
+ "Display stacktrace for the erring NS VAR test with the assertion INDEX."
+ (let (causes)
+ (cider-nrepl-send-request
+ (append
+ (list "op" "test-stacktrace"
+ "ns" ns "var" var "index" index)
+ (when (cider--pprint-fn)
+ (list "pprint-fn" (cider--pprint-fn)))
+ (when cider-stacktrace-print-length
+ (list "print-length" cider-stacktrace-print-length))
+ (when cider-stacktrace-print-level
+ (list "print-level" cider-stacktrace-print-level)))
+ (lambda (response)
+ (nrepl-dbind-response response (class status)
+ (cond (class (setq causes (cons response causes)))
+ (status (when causes
+ (cider-stacktrace-render
+ (cider-popup-buffer cider-error-buffer
+ cider-auto-select-error-buffer
+ #'cider-stacktrace-mode)
+ (reverse causes))))))))))
+
+(defun cider-test-stacktrace ()
+ "Display stacktrace for the erring test at point."
+ (interactive)
+ (let ((ns (get-text-property (point) 'ns))
+ (var (get-text-property (point) 'var))
+ (index (get-text-property (point) 'index))
+ (err (get-text-property (point) 'error)))
+ (if (and err ns var index)
+ (cider-test-stacktrace-for ns var index)
+ (message "No test error at point"))))
+
+
+;;; Expected vs actual diffing
+
+(defvar cider-test-ediff-buffers nil
+ "The expected/actual buffers used to display diff.")
+
+(defun cider-test-ediff ()
+ "Show diff of the expected vs actual value for the test at point.
+With the actual value, the outermost '(not ...)' s-expression is removed."
+ (interactive)
+ (let ((expected (get-text-property (point) 'expected))
+ (actual (get-text-property (point) 'actual)))
+ (if (and expected actual)
+ (let ((expected-buffer (generate-new-buffer " *expected*"))
+ (actual-buffer (generate-new-buffer " *actual*")))
+ (with-current-buffer expected-buffer
+ (insert expected)
+ (clojure-mode))
+ (with-current-buffer actual-buffer
+ (insert actual)
+ (goto-char (point-min))
+ (forward-char)
+ (forward-sexp)
+ (forward-whitespace 1)
+ (let ((beg (point)))
+ (forward-sexp)
+ (let ((actual* (buffer-substring beg (point))))
+ (erase-buffer)
+ (insert actual*)))
+ (clojure-mode))
+ (apply 'ediff-buffers
+ (setq cider-test-ediff-buffers
+ (list (buffer-name expected-buffer)
+ (buffer-name actual-buffer)))))
+ (message "No test failure at point"))))
+
+(defun cider-test-ediff-cleanup ()
+ "Cleanup expected/actual buffers used for diff."
+ (interactive)
+ (mapc (lambda (b) (when (get-buffer b) (kill-buffer b)))
+ cider-test-ediff-buffers))
+
+(add-hook 'ediff-cleanup-hook #'cider-test-ediff-cleanup)
+
+
+;;; Report rendering
+
+(defun cider-test-type-face (type)
+ "Return the font lock face for the test result TYPE."
+ (pcase type
+ ("pass" 'cider-test-success-face)
+ ("fail" 'cider-test-failure-face)
+ ("error" 'cider-test-error-face)
+ (_ 'default)))
+
+(defun cider-test-type-simple-face (type)
+ "Return a face for the test result TYPE using the highlight color as foreground."
+ (let ((face (cider-test-type-face type)))
+ `(:foreground ,(face-attribute face :background))))
+
+(defun cider-test-render-summary (buffer summary)
+ "Emit into BUFFER the report SUMMARY statistics."
+ (with-current-buffer buffer
+ (nrepl-dbind-response summary (ns var test pass fail error)
+ (insert (format "Tested %d namespaces\n" ns))
+ (insert (format "Ran %d assertions, in %d test functions\n" test var))
+ (unless (zerop fail)
+ (cider-insert (format "%d failures" fail) 'cider-test-failure-face t))
+ (unless (zerop error)
+ (cider-insert (format "%d errors" error) 'cider-test-error-face t))
+ (when (zerop (+ fail error))
+ (cider-insert (format "%d passed" pass) 'cider-test-success-face t))
+ (insert "\n\n"))))
+
+(defun cider-test-render-assertion (buffer test)
+ "Emit into BUFFER report detail for the TEST assertion."
+ (with-current-buffer buffer
+ (nrepl-dbind-response test (var context type message expected actual error gen-input)
+ (cider-propertize-region (cider-intern-keys (cdr test))
+ (let ((beg (point))
+ (type-face (cider-test-type-simple-face type))
+ (bg `(:background ,cider-test-items-background-color)))
+ (cider-insert (capitalize type) type-face nil " in ")
+ (cider-insert var 'font-lock-function-name-face t)
+ (when context (cider-insert context 'font-lock-doc-face t))
+ (when message (cider-insert message 'font-lock-doc-string-face t))
+ (when expected
+ (cider-insert "expected: " 'font-lock-comment-face nil
+ (cider-font-lock-as-clojure expected)))
+ (when actual
+ (cider-insert " actual: " 'font-lock-comment-face nil
+ (cider-font-lock-as-clojure actual)))
+ (when error
+ (cider-insert " error: " 'font-lock-comment-face nil)
+ (insert-text-button error
+ 'follow-link t
+ 'action '(lambda (_button) (cider-test-stacktrace))
+ 'help-echo "View causes and stacktrace")
+ (insert "\n"))
+ (when gen-input
+ (cider-insert " input: " 'font-lock-comment-face nil
+ (cider-font-lock-as-clojure gen-input)))
+ (overlay-put (make-overlay beg (point)) 'font-lock-face bg))
+ (insert "\n")))))
+
+(defun cider-test-non-passing (tests)
+ "For a list of TESTS, each an nrepl-dict, return only those that did not pass."
+ (seq-filter (lambda (test)
+ (unless (equal (nrepl-dict-get test "type") "pass")
+ test))
+ tests))
+
+(defun cider-test-render-report (buffer summary results)
+ "Emit into BUFFER the report for the SUMMARY, and test RESULTS."
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (cider-test-report-mode)
+ (cider-insert "Test Summary" 'bold t)
+ (dolist (ns (nrepl-dict-keys results))
+ (insert (cider-propertize ns 'ns) "\n"))
+ (cider-insert "\n")
+ (cider-test-render-summary buffer summary)
+ (nrepl-dbind-response summary (fail error)
+ (unless (zerop (+ fail error))
+ (cider-insert "Results" 'bold t "\n")
+ ;; Results are a nested dict, keyed first by ns, then var. Within each
+ ;; var is a sequence of test assertion results.
+ (nrepl-dict-map
+ (lambda (ns vars)
+ (nrepl-dict-map
+ (lambda (_var tests)
+ (let* ((problems (cider-test-non-passing tests))
+ (count (length problems)))
+ (when (< 0 count)
+ (insert (format "%s\n%d non-passing tests:\n\n"
+ (cider-propertize ns 'ns) count))
+ (dolist (test problems)
+ (cider-test-render-assertion buffer test)))))
+ vars))
+ results)))
+ (goto-char (point-min))
+ (current-buffer))))
+
+
+;;; Message echo
+
+(defun cider-test-echo-running (ns &optional test)
+ "Echo a running message for the test NS, which may be a keyword.
+The optional arg TEST denotes an individual test name."
+ (if test
+ (message "Running test %s in %s..."
+ (cider-propertize test 'bold)
+ (cider-propertize ns 'ns))
+ (message "Running tests in %s..."
+ (concat (cider-propertize
+ (cond ((stringp ns) ns)
+ ((eq :non-passing ns) "failing")
+ ((eq :loaded ns) "all loaded")
+ ((eq :project ns) "all project"))
+ 'ns)
+ (unless (stringp ns) " namespaces")))))
+
+(defun cider-test-echo-summary (summary results)
+ "Echo SUMMARY statistics for a test run returning RESULTS."
+ (nrepl-dbind-response summary (ns test var fail error)
+ (if (nrepl-dict-empty-p results)
+ (message (concat (propertize "No assertions (or no tests) were run." 'face 'cider-test-error-face)
+ "Did you forget to use `is' in your tests?"))
+ (message (propertize
+ "%sRan %d assertions, in %d test functions. %d failures, %d errors."
+ 'face (cond ((not (zerop error)) 'cider-test-error-face)
+ ((not (zerop fail)) 'cider-test-failure-face)
+ (t 'cider-test-success-face)))
+ (concat (if (= 1 ns) ; ns count from summary
+ (cider-propertize (car (nrepl-dict-keys results)) 'ns)
+ (propertize (format "%d namespaces" ns) 'face 'default))
+ (propertize ": " 'face 'default))
+ test var fail error))))
+
+;;; Test definition highlighting
+;; On receipt of test results, failing/erring test definitions are highlighted.
+;; Highlights are cleared on the next report run, and may be cleared manually
+;; by the user.
+
+;; NOTE If keybindings specific to test sources are desired, it would be
+;; straightforward to turn this into a `cider-test-mode' minor mode, which we
+;; enable on test sources, much like the legacy `clojure-test-mode'. At present,
+;; though, there doesn't seem to be much value in this, since the report buffer
+;; provides the primary means of interacting with test results.
+
+(defun cider-test-highlight-problem (buffer test)
+ "Highlight the BUFFER test definition for the non-passing TEST."
+ (with-current-buffer buffer
+ (nrepl-dbind-response test (type file line message expected actual)
+ ;; we have to watch out for vars without proper location metadata
+ ;; right now everything evaluated interactively lacks this data
+ ;; TODO: Figure out what to do when the metadata is missing
+ (when (and file line (not (cider--tooling-file-p file)))
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (search-forward "(" nil t)
+ (let ((beg (point)))
+ (forward-sexp)
+ (cider--make-overlay beg (point) 'cider-test
+ 'font-lock-face (cider-test-type-face type)
+ 'type type
+ 'help-echo message
+ 'message message
+ 'expected expected
+ 'actual actual)))))))
+
+(defun cider-find-var-file (ns var)
+ "Return the buffer visiting the file in which the NS VAR is defined.
+Or nil if not found."
+ (cider-ensure-op-supported "info")
+ (when-let ((info (cider-var-info (concat ns "/" var)))
+ (file (nrepl-dict-get info "file")))
+ (cider-find-file file)))
+
+(defun cider-test-highlight-problems (results)
+ "Highlight all non-passing tests in the test RESULTS."
+ (nrepl-dict-map
+ (lambda (ns vars)
+ (nrepl-dict-map
+ (lambda (var tests)
+ (when-let ((buffer (cider-find-var-file ns var)))
+ (dolist (test tests)
+ (nrepl-dbind-response test (type)
+ (unless (equal "pass" type)
+ (cider-test-highlight-problem buffer test))))))
+ vars))
+ results))
+
+(defun cider-test-clear-highlights ()
+ "Clear highlighting of non-passing tests from the last test run."
+ (interactive)
+ (when cider-test-last-results
+ (nrepl-dict-map
+ (lambda (ns vars)
+ (dolist (var (nrepl-dict-keys vars))
+ (when-let ((buffer (cider-find-var-file ns var)))
+ (with-current-buffer buffer
+ (remove-overlays nil nil 'category 'cider-test)))))
+ cider-test-last-results)))
+
+
+;;; Test namespaces
+;; Test namespace inference exists to enable DWIM test running functions: the
+;; same "run-tests" function should be able to be used in a source file, and in
+;; its corresponding test namespace. To provide this, we need to map the
+;; relationship between those namespaces.
+
+(defcustom cider-test-infer-test-ns 'cider-test-default-test-ns-fn
+ "Function to infer the test namespace for NS.
+The default implementation uses the simple Leiningen convention of appending
+'-test' to the namespace name."
+ :type 'symbol
+ :group 'cider-test
+ :package-version '(cider . "0.7.0"))
+
+(defun cider-test-default-test-ns-fn (ns)
+ "For a NS, return the test namespace, which may be the argument itself.
+This uses the Leiningen convention of appending '-test' to the namespace name."
+ (when ns
+ (let ((suffix "-test"))
+ ;; string-suffix-p is only available in Emacs 24.4+
+ (if (string-match-p (rx-to-string `(: ,suffix eos) t) ns)
+ ns
+ (concat ns suffix)))))
+
+
+;;; Test execution
+
+(declare-function cider-emit-interactive-eval-output "cider-interaction")
+(declare-function cider-emit-interactive-eval-err-output "cider-interaction")
+
+(defun cider-test-execute (ns &optional tests silent)
+ "Run tests for NS, which may be a keyword, optionally specifying TESTS.
+
+This tests a single NS, or multiple namespaces when using keywords `:project',
+`:loaded' or `:non-passing'. Optional TESTS are only honored when a single
+namespace is specified. Upon test completion, results are echoed and a test
+report is optionally displayed. When test failures/errors occur, their sources
+are highlighted.
+If SILENT is non-nil, suppress all messages other then test results."
+ (cider-test-clear-highlights)
+ (cider-map-connections
+ (lambda (conn)
+ (unless silent
+ (if (and tests (= (length tests) 1))
+ ;; we generate a different message when running individual tests
+ (cider-test-echo-running ns (car tests))
+ (cider-test-echo-running ns)))
+ (cider-nrepl-send-request
+ (list "op" (cond ((stringp ns) "test")
+ ((eq :project ns) "test-all")
+ ((eq :loaded ns) "test-all")
+ ((eq :non-passing ns) "retest"))
+ "ns" (when (stringp ns) ns)
+ "tests" (when (stringp ns) tests)
+ "load?" (when (or (stringp ns)
+ (eq :project ns))
+ "true"))
+ (lambda (response)
+ (nrepl-dbind-response response (summary results status out err)
+ (cond ((member "namespace-not-found" status)
+ (unless silent
+ (message "No test namespace: %s" (cider-propertize ns 'ns))))
+ (out (cider-emit-interactive-eval-output out))
+ (err (cider-emit-interactive-eval-err-output err))
+ (results
+ (nrepl-dbind-response summary (error fail)
+ (setq cider-test-last-summary summary)
+ (setq cider-test-last-results results)
+ (cider-test-highlight-problems results)
+ (cider-test-echo-summary summary results)
+ (if (or (not (zerop (+ error fail)))
+ cider-test-show-report-on-success)
+ (cider-test-render-report
+ (cider-popup-buffer cider-test-report-buffer
+ cider-auto-select-test-report-buffer)
+ summary results)
+ (when (get-buffer cider-test-report-buffer)
+ (with-current-buffer cider-test-report-buffer
+ (let ((inhibit-read-only t))
+ (erase-buffer)))
+ (cider-test-render-report
+ cider-test-report-buffer
+ summary results))))))))
+ conn))
+ :clj))
+
+(defun cider-test-rerun-failed-tests ()
+ "Rerun failed and erring tests from the last test run."
+ (interactive)
+ (if cider-test-last-summary
+ (nrepl-dbind-response cider-test-last-summary (fail error)
+ (if (not (zerop (+ error fail)))
+ (cider-test-execute :non-passing)
+ (message "No prior failures to retest")))
+ (message "No prior results to retest")))
+
+(defun cider-test-run-loaded-tests ()
+ "Run all tests defined in currently loaded namespaces."
+ (interactive)
+ (cider-test-execute :loaded))
+
+(defun cider-test-run-project-tests ()
+ "Run all tests defined in all project namespaces, loading these as needed."
+ (interactive)
+ (cider-test-execute :project))
+
+(defun cider-test-run-ns-tests (suppress-inference &optional silent)
+ "Run all tests for the current Clojure namespace context.
+
+If SILENT is non-nil, suppress all messages other then test results.
+With a prefix arg SUPPRESS-INFERENCE it will try to run the tests in the
+current ns."
+ (interactive "P")
+ (if-let ((ns (if suppress-inference
+ (cider-current-ns t)
+ (funcall cider-test-infer-test-ns (cider-current-ns t)))))
+ (cider-test-execute ns nil silent)
+ (if (eq major-mode 'cider-test-report-mode)
+ (when (y-or-n-p (concat "Test report does not define a namespace. "
+ "Rerun failed/erring tests?"))
+ (cider-test-rerun-failed-tests))
+ (unless silent
+ (message "No namespace to test in current context")))))
+
+(defvar cider-test-last-test-ns nil
+ "The ns of the last test ran with `cider-test-run-test'.")
+(defvar cider-test-last-test-var nil
+ "The var of the last test ran with `cider-test-run-test'.")
+
+(defun cider-test-update-last-test (ns var)
+ "Update the last test by setting NS and VAR.
+
+See `cider-test-rerun-test'."
+ (setq cider-test-last-test-ns ns
+ cider-test-last-test-var var))
+
+(defun cider-test-run-test ()
+ "Run the test at point.
+The test ns/var exist as text properties on report items and on highlighted
+failed/erred test definitions. When not found, a test definition at point
+is searched."
+ (interactive)
+ (let ((ns (get-text-property (point) 'ns))
+ (var (get-text-property (point) 'var)))
+ (if (and ns var)
+ (progn
+ (cider-test-update-last-test ns var)
+ (cider-test-execute ns (list var)))
+ (let ((ns (clojure-find-ns))
+ (def (clojure-find-def)))
+ (if (and ns (member (car def) cider-test-defining-forms))
+ (progn
+ (cider-test-update-last-test ns (cdr def))
+ (cider-test-execute ns (cdr def)))
+ (message "No test at point"))))))
+
+(defun cider-test-rerun-test ()
+ "Re-run the test that was previously ran."
+ (interactive)
+ (if (and cider-test-last-test-ns cider-test-last-test-var)
+ (cider-test-execute cider-test-last-test-ns cider-test-last-test-var)
+ (user-error "No test to re-run")))
+
+;;; Auto-test mode
+(defun cider--test-silently ()
+ "Like `cider-test-run-tests', but with less feedback.
+Only notify the user if there actually were any tests to run and only after
+the results are received."
+ (when (cider-connected-p)
+ (let ((cider-auto-select-test-report-buffer nil)
+ (cider-test-show-report-on-success nil))
+ (cider-test-run-ns-tests nil 'soft))))
+
+;;;###autoload
+(define-minor-mode cider-auto-test-mode
+ "Toggle automatic testing of Clojure files.
+
+When enabled this reruns tests every time a Clojure file is loaded.
+Only runs tests corresponding to the loaded file's namespace and does
+nothing if no tests are defined or if the file failed to load."
+ nil (cider-mode " Test") nil
+ :global t
+ (if cider-auto-test-mode
+ (add-hook 'cider-file-loaded-hook #'cider--test-silently)
+ (remove-hook 'cider-file-loaded-hook #'cider--test-silently)))
+
+(provide 'cider-test)
+
+;;; cider-test.el ends here
--- /dev/null
+;;; cider-util.el --- Common utility functions that don't belong anywhere else -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Common utility functions that don't belong anywhere else.
+
+;;; Code:
+
+(require 'seq)
+(require 'cl-lib)
+(require 'clojure-mode)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'nrepl-dict)
+
+(defalias 'cider-pop-back 'pop-tag-mark)
+
+(defcustom cider-font-lock-max-length 10000
+ "The max length of strings to fontify in `cider-font-lock-as'.
+
+Setting this to nil removes the fontification restriction."
+ :group 'cider
+ :type 'boolean
+ :package-version '(cider . "0.10.0"))
+
+(defun cider-util--hash-keys (hashtable)
+ "Return a list of keys in HASHTABLE."
+ (let ((keys '()))
+ (maphash (lambda (k _v) (setq keys (cons k keys))) hashtable)
+ keys))
+
+(defun cider-util--clojure-buffers ()
+ "Return a list of all existing `clojure-mode' buffers."
+ (seq-filter
+ (lambda (buffer) (with-current-buffer buffer (derived-mode-p 'clojure-mode)))
+ (buffer-list)))
+
+(defun cider-current-dir ()
+ "Return the directory of the current buffer."
+ (if buffer-file-name
+ (file-name-directory buffer-file-name)
+ default-directory))
+
+(defun cider-in-string-p ()
+ "Return true if point is in a string."
+ (let ((beg (save-excursion (beginning-of-defun) (point))))
+ (nth 3 (parse-partial-sexp beg (point)))))
+
+(defun cider-in-comment-p ()
+ "Return true if point is in a comment."
+ (let ((beg (save-excursion (beginning-of-defun) (point))))
+ (nth 4 (parse-partial-sexp beg (point)))))
+
+(defun cider--tooling-file-p (file-name)
+ "Return t if FILE-NAME is not a 'real' source file.
+Currently, only check if the relative file name starts with 'form-init'
+which nREPL uses for temporary evaluation file names."
+ (let ((fname (file-name-nondirectory file-name)))
+ (string-match-p "^form-init" fname)))
+
+(defun cider--cljc-or-cljx-buffer-p (&optional buffer)
+ "Return true if the current buffer is visiting a cljc or cljx file.
+
+If BUFFER is provided act on that buffer instead."
+ (with-current-buffer (or buffer (current-buffer))
+ (or (derived-mode-p 'clojurec-mode) (derived-mode-p 'clojurex-mode))))
+
+\f
+;;; Thing at point
+(defun cider-defun-at-point (&optional bounds)
+ "Return the text of the top-level sexp at point.
+If BOUNDS is non-nil, return a list of its starting and ending position
+instead."
+ (save-excursion
+ (save-match-data
+ (end-of-defun)
+ (let ((end (point)))
+ (clojure-backward-logical-sexp 1)
+ (funcall (if bounds #'list #'buffer-substring-no-properties)
+ (point) end)))))
+
+(defun cider-ns-form ()
+ "Retrieve the ns form."
+ (when (clojure-find-ns)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (cider-defun-at-point))))
+
+(defun cider-symbol-at-point (&optional look-back)
+ "Return the name of the symbol at point, otherwise nil.
+Ignores the REPL prompt. If LOOK-BACK is non-nil, move backwards trying to
+find a symbol if there isn't one at point."
+ (or (when-let ((str (thing-at-point 'symbol)))
+ (unless (text-property-any 0 (length str) 'field 'cider-repl-prompt str)
+ (substring-no-properties str)))
+ (when look-back
+ (save-excursion
+ (ignore-errors
+ (while (not (looking-at "\\sw\\|\\s_\\|\\`"))
+ (forward-sexp -1)))
+ (cider-symbol-at-point)))))
+
+\f
+;;; sexp navigation
+(defun cider-sexp-at-point (&optional bounds)
+ "Return the sexp at point as a string, otherwise nil.
+If BOUNDS is non-nil, return a list of its starting and ending position
+instead."
+ (when-let ((b (or (and (equal (char-after) ?\()
+ (member (char-before) '(?\' ?\, ?\@))
+ ;; hide stuff before ( to avoid quirks with '( etc.
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (bounds-of-thing-at-point 'sexp)))
+ (bounds-of-thing-at-point 'sexp))))
+ (funcall (if bounds #'list #'buffer-substring-no-properties)
+ (car b) (cdr b))))
+
+(defun cider-last-sexp (&optional bounds)
+ "Return the sexp preceding the point.
+If BOUNDS is non-nil, return a list of its starting and ending position
+instead."
+ (apply (if bounds #'list #'buffer-substring-no-properties)
+ (save-excursion
+ (clojure-backward-logical-sexp 1)
+ (list (point)
+ (progn (clojure-forward-logical-sexp 1)
+ (skip-chars-forward "[:blank:]")
+ (when (looking-at-p "\n") (forward-char 1))
+ (point))))))
+
+(defun cider-start-of-next-sexp (&optional skip)
+ "Move to the start of the next sexp.
+Skip any non-logical sexps like ^metadata or #reader macros.
+If SKIP is an integer, also skip that many logical sexps first.
+Can only error if SKIP is non-nil."
+ (while (clojure--looking-at-non-logical-sexp)
+ (forward-sexp 1))
+ (when (and skip (> skip 0))
+ (dotimes (_ skip)
+ (forward-sexp 1)
+ (cider-start-of-next-sexp))))
+
+\f
+;;; Text properties
+
+(defun cider-maybe-intern (name)
+ "If NAME is a symbol, return it; otherwise, intern it."
+ (if (symbolp name) name (intern name)))
+
+(defun cider-intern-keys (plist)
+ "Copy PLIST, with any non-symbol keys replaced with symbols."
+ (when plist
+ (cons (cider-maybe-intern (pop plist))
+ (cons (pop plist) (cider-intern-keys plist)))))
+
+(defmacro cider-propertize-region (props &rest body)
+ "Execute BODY and add PROPS to all the inserted text.
+More precisely, PROPS are added to the region between the point's
+positions before and after executing BODY."
+ (declare (indent 1))
+ (let ((start (make-symbol "start")))
+ `(let ((,start (point)))
+ (prog1 (progn ,@body)
+ (add-text-properties ,start (point) ,props)))))
+
+(put 'cider-propertize-region 'lisp-indent-function 1)
+
+(defun cider-property-bounds (prop)
+ "Return the the positions of the previous and next change to PROP.
+PROP is the name of a text property."
+ (let ((end (next-single-char-property-change (point) prop)))
+ (list (previous-single-char-property-change end prop) end)))
+
+(defun cider-insert (text &optional face break more-text)
+ "Insert TEXT with FACE, optionally followed by a line BREAK and MORE-TEXT."
+ (insert (if face (propertize text 'font-lock-face face) text))
+ (when more-text (insert more-text))
+ (when break (insert "\n")))
+
+\f
+;;; Font lock
+
+(defalias 'cider--font-lock-ensure
+ (if (fboundp 'font-lock-ensure)
+ #'font-lock-ensure
+ (with-no-warnings
+ (lambda (&optional _beg _end)
+ (when font-lock-mode
+ (font-lock-fontify-buffer))))))
+
+(defalias 'cider--font-lock-flush
+ (if (fboundp 'font-lock-flush)
+ #'font-lock-flush
+ (with-no-warnings
+ (lambda (&optional _beg _end)
+ (when font-lock-mode
+ (font-lock-fontify-buffer))))))
+
+(defvar cider--mode-buffers nil
+ "A list of buffers for different major modes.")
+
+(defun cider--make-buffer-for-mode (mode)
+ "Return a temp buffer using major-mode MODE.
+This buffer is not designed to display anything to the user. For that, use
+`cider-make-popup-buffer' instead."
+ (setq cider--mode-buffers (seq-filter (lambda (x) (buffer-live-p (cdr x)))
+ cider--mode-buffers))
+ (or (cdr (assq mode cider--mode-buffers))
+ (let ((b (generate-new-buffer (format " *cider-temp %s*" mode))))
+ (push (cons mode b) cider--mode-buffers)
+ (with-current-buffer b
+ ;; suppress major mode hooks as we care only about their font-locking
+ ;; otherwise modes like whitespace-mode and paredit might interfere
+ (setq-local delay-mode-hooks t)
+ (setq delayed-mode-hooks nil)
+ (funcall mode))
+ b)))
+
+(defun cider-font-lock-as (mode string)
+ "Use MODE to font-lock the STRING."
+ (if (or (null cider-font-lock-max-length)
+ (< (length string) cider-font-lock-max-length))
+ (with-current-buffer (cider--make-buffer-for-mode mode)
+ (erase-buffer)
+ (insert string)
+ (font-lock-fontify-region (point-min) (point-max))
+ (buffer-string))
+ string))
+
+(defun cider-font-lock-region-as (mode beg end &optional buffer)
+ "Use MODE to font-lock text between BEG and END.
+
+Unless you specify a BUFFER it will default to the current one."
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((text (buffer-substring beg end)))
+ (delete-region beg end)
+ (goto-char beg)
+ (insert (cider-font-lock-as mode text)))))
+
+(defun cider-font-lock-as-clojure (string)
+ "Font-lock STRING as Clojure code."
+ (cider-font-lock-as 'clojure-mode string))
+
+;; Button allowing use of `font-lock-face', ignoring any inherited `face'
+(define-button-type 'cider-plain-button
+ 'face nil)
+
+;;; Colors
+
+(defun cider-scale-color (color scale)
+ "For a COLOR hex string or name, adjust intensity of RGB components by SCALE."
+ (let* ((rgb (color-values color))
+ (scaled-rgb (mapcar (lambda (n)
+ (format "%04x" (round (+ n (* scale 65535)))))
+ rgb)))
+ (apply #'concat "#" scaled-rgb)))
+
+(defun cider-scale-background-color ()
+ "Scale the current background color to get a slighted muted version."
+ (let ((color (frame-parameter nil 'background-color))
+ (dark (eq (frame-parameter nil 'background-mode) 'dark)))
+ (cider-scale-color color (if dark 0.05 -0.05))))
+
+(autoload 'pkg-info-version-info "pkg-info.el")
+
+(defvar cider-version)
+(defvar cider-codename)
+
+(defun cider--version ()
+ "Retrieve CIDER's version.
+A codename is added to stable versions."
+ (let ((version (condition-case nil
+ (pkg-info-version-info 'cider)
+ (error cider-version))))
+ (if (string-match-p "-snapshot" cider-version)
+ version
+ (format "%s (%s)" version cider-codename))))
+
+\f
+;;; Strings
+
+(defun cider-join-into-alist (candidates &optional separator)
+ "Make an alist from CANDIDATES.
+The keys are the elements joined with SEPARATOR and values are the original
+elements. Useful for `completing-read' when candidates are complex
+objects."
+ (mapcar (lambda (el)
+ (if (listp el)
+ (cons (string-join el (or separator ":")) el)
+ (cons el el)))
+ candidates))
+
+(defun cider-add-to-alist (symbol car cadr)
+ "Add '(CAR CADR) to the alist stored in SYMBOL.
+If CAR already corresponds to an entry in the alist, destructively replace
+the entry's second element with CADR.
+
+This can be used, for instance, to update the version of an injected
+plugin or dependency with:
+ (cider-add-to-alist 'cider-jack-in-lein-plugins
+ \"plugin/artifact-name\" \"THE-NEW-VERSION\")"
+ (let ((alist (symbol-value symbol)))
+ (if-let ((cons (assoc car alist)))
+ (setcdr cons (list cadr))
+ (set symbol (cons (list car cadr) alist)))))
+
+(defun cider-namespace-qualified-p (sym)
+ "Return t if SYM is namespace-qualified."
+ (string-match-p "[^/]+/" sym))
+
+(defvar cider-version)
+
+(defconst cider-manual-url "http://cider.readthedocs.org/en/%s/"
+ "The URL to CIDER's manual.")
+
+(defun cider--manual-version ()
+ "Convert the version to a ReadTheDocs-friendly version."
+ (if (string-match-p "-snapshot" cider-version)
+ "latest"
+ "stable"))
+
+(defun cider-manual-url ()
+ "The CIDER manual's url."
+ (format cider-manual-url (cider--manual-version)))
+
+;;;###autoload
+(defun cider-view-manual ()
+ "View the manual in your default browser."
+ (interactive)
+ (browse-url (cider-manual-url)))
+
+(defun cider--manual-button (label section-id)
+ "Return a button string that links to the online manual.
+LABEL is the displayed string, and SECTION-ID is where it points
+to."
+ (with-temp-buffer
+ (insert-text-button
+ label
+ 'follow-link t
+ 'action (lambda (&rest _) (interactive)
+ (browse-url (concat (cider-manual-url)
+ section-id))))
+ (buffer-string)))
+
+(defconst cider-refcard-url "https://github.com/clojure-emacs/cider/raw/%s/doc/cider-refcard.pdf"
+ "The URL to CIDER's refcard.")
+
+(defun cider--github-version ()
+ "Convert the version to a GitHub-friendly version."
+ (if (string-match-p "-snapshot" cider-version)
+ "master"
+ (concat "v" cider-version)))
+
+(defun cider-refcard-url ()
+ "The CIDER manual's url."
+ (format cider-refcard-url (cider--github-version)))
+
+(defun cider-view-refcard ()
+ "View the refcard in your default browser."
+ (interactive)
+ (browse-url (cider-refcard-url)))
+
+(defconst cider-report-bug-url "https://github.com/clojure-emacs/cider/issues/new"
+ "The URL to report a CIDER issue.")
+
+(defun cider-report-bug ()
+ "Report a bug in your default browser."
+ (interactive)
+ (browse-url cider-report-bug-url))
+
+(defun cider--project-name (dir)
+ "Extracts a project name from DIR, possibly nil.
+The project name is the final component of DIR if not nil."
+ (when dir
+ (file-name-nondirectory (directory-file-name dir))))
+
+;;; Vectors
+(defun cider--deep-vector-to-list (x)
+ "Convert vectors in X to lists.
+If X is a sequence, return a list of `cider--deep-vector-to-list' applied to
+each of its elements.
+Any other value is just returned."
+ (if (sequencep x)
+ (mapcar #'cider--deep-vector-to-list x)
+ x))
+
+
+;;; Help mode
+
+;; Same as https://github.com/emacs-mirror/emacs/blob/86d083438dba60dc00e9e96414bf7e832720c05a/lisp/help-mode.el#L355
+;; the original function uses some buffer local variables, but the buffer used
+;; is not configurable. It defaults to (help-buffer)
+
+(defun cider--help-setup-xref (item interactive-p buffer)
+ "Invoked from commands using the \"*Help*\" buffer to install some xref info.
+
+ITEM is a (FUNCTION . ARGS) pair appropriate for recreating the help
+buffer after following a reference. INTERACTIVE-P is non-nil if the
+calling command was invoked interactively. In this case the stack of
+items for help buffer \"back\" buttons is cleared. Use BUFFER for the
+buffer local variables.
+
+This should be called very early, before the output buffer is cleared,
+because we want to record the \"previous\" position of point so we can
+restore it properly when going back."
+ (with-current-buffer buffer
+ (when help-xref-stack-item
+ (push (cons (point) help-xref-stack-item) help-xref-stack)
+ (setq help-xref-forward-stack nil))
+ (when interactive-p
+ (let ((tail (nthcdr 10 help-xref-stack)))
+ ;; Truncate the stack.
+ (if tail (setcdr tail nil))))
+ (setq help-xref-stack-item item)))
+
+(defcustom cider-doc-xref-regexp "`\\(.*?\\)`"
+ "The regexp used to search Clojure vars in doc buffers."
+ :type 'regexp
+ :safe #'stringp
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defun cider--find-symbol-xref ()
+ "Parse and return the first clojure symbol in current-buffer.
+Use `cider-doc-xref-regexp' for the search. Set match data and return a
+string of the Clojure symbol. Return nil if there are no more matches in
+the buffer."
+ (when (re-search-forward cider-doc-xref-regexp nil t)
+ (match-string 1)))
+
+(declare-function cider-doc-lookup "cider-doc")
+(declare-function cider--eldoc-remove-dot "cider-eldoc")
+
+;; Similar to https://github.com/emacs-mirror/emacs/blob/65c8c7cb96c14f9c6accd03cc8851b5a3459049e/lisp/help-mode.el#L404
+(defun cider--doc-make-xrefs ()
+ "Parse and hyperlink documentation cross-references in current-buffer.
+Find cross-reference information in a buffer and activate such cross
+references for selection with `help-xref'. Cross-references are parsed
+using `cider--find-symbol-xref'.
+
+Special references `back' and `forward' are made to go back and forth
+through a stack of help buffers. Variables `help-back-label' and
+`help-forward-label' specify the text for that."
+ (interactive "b")
+
+ ;; parse the docstring and create xrefs for symbols
+ (save-excursion
+ (goto-char (point-min))
+ (let ((symbol))
+ (while (setq symbol (cider--find-symbol-xref))
+ (replace-match "")
+ (insert-text-button symbol
+ 'type 'help-xref
+ 'help-function (apply-partially #'cider-doc-lookup
+ (cider--eldoc-remove-dot symbol))))))
+
+ ;; create back and forward buttons if appropiate
+ (insert "\n")
+ (when (or help-xref-stack help-xref-forward-stack)
+ (insert "\n"))
+ ;; Make a back-reference in this buffer if appropriate.
+ (when help-xref-stack
+ (help-insert-xref-button help-back-label 'help-back
+ (current-buffer)))
+ ;; Make a forward-reference in this buffer if appropriate.
+ (when help-xref-forward-stack
+ (when help-xref-stack
+ (insert "\t"))
+ (help-insert-xref-button help-forward-label 'help-forward
+ (current-buffer)))
+ (when (or help-xref-stack help-xref-forward-stack)
+ (insert "\n")))
+
+\f
+;;; Words of inspiration
+(defun cider-user-first-name ()
+ "Find the current user's first name."
+ (let ((name (if (string= (user-full-name) "")
+ (user-login-name)
+ (user-full-name))))
+ (string-match "^[^ ]*" name)
+ (capitalize (match-string 0 name))))
+
+(defvar cider-words-of-inspiration
+ `("The best way to predict the future is to invent it. -Alan Kay"
+ "A point of view is worth 80 IQ points. -Alan Kay"
+ "Lisp isn't a language, it's a building material. -Alan Kay"
+ "Simple things should be simple, complex things should be possible. -Alan Kay"
+ "Everything should be as simple as possible, but not simpler. -Albert Einstein"
+ "Measuring programming progress by lines of code is like measuring aircraft building progress by weight. -Bill Gates"
+ "Controlling complexity is the essence of computer programming. -Brian Kernighan"
+ "The unavoidable price of reliability is simplicity. -C.A.R. Hoare"
+ "You're bound to be unhappy if you optimize everything. -Donald Knuth"
+ "Simplicity is prerequisite for reliability. -Edsger W. Dijkstra"
+ "Elegance is not a dispensable luxury but a quality that decides between success and failure. -Edsger W. Dijkstra"
+ "Deleted code is debugged code. -Jeff Sickel"
+ "The key to performance is elegance, not battalions of special cases. -Jon Bentley and Doug McIlroy"
+ "First, solve the problem. Then, write the code. -John Johnson"
+ "Simplicity is the ultimate sophistication. -Leonardo da Vinci"
+ "Programming is not about typing... it's about thinking. -Rich Hickey"
+ "Design is about pulling things apart. -Rich Hickey"
+ "Programmers know the benefits of everything and the tradeoffs of nothing. -Rich Hickey"
+ "Code never lies, comments sometimes do. -Ron Jeffries"
+ "The true delight is in the finding out rather than in the knowing. -Isaac Asimov"
+ "If paredit is not for you, then you need to become the sort of person that paredit is for. -Phil Hagelberg"
+ "Express Yourself. -Madonna"
+ "Put on your red shoes and dance the blues. -David Bowie"
+ "Do. Or do not. There is no try. -Yoda"
+ "The enjoyment of one's tools is an essential ingredient of successful work. -Donald E. Knuth"
+ "Not all those who wander are lost. -J.R.R. Tolkien"
+ "The best way to learn is to do. -P.R. Halmos"
+ "If you wish to make an apple pie from scratch, you must first invent the universe. -Carl Sagan"
+ "Learn the rules like a pro, so you can break them like an artist. -Pablo Picasso"
+ "The only way of discovering the limits of the possible is to venture a little way past them into the impossible. -Arthur C. Clarke"
+ "Don't wish it were easier. Wish you were better. -Jim Rohn"
+ "One chord is fine. Two chords is pushing it. Three chords and you're into jazz. -Lou Reed"
+ "We are all apprentices in a craft where no one ever becomes a master. -Ernest Hemingway"
+ "Clojure isn't a language, it's a building material."
+ "Think big!"
+ "Think bold!"
+ "Think fun!"
+ "Code big!"
+ "Code bold!"
+ "Code fun!"
+ "Take this REPL, fellow hacker, and may it serve you well."
+ "Let the hacking commence!"
+ "Hacks and glory await!"
+ "Hack and be merry!"
+ "Your hacking starts... NOW!"
+ "May the Source be with you!"
+ "May the Source shine upon thy REPL!"
+ "Code long and prosper!"
+ "Happy hacking!"
+ "nREPL server is up, CIDER REPL is online!"
+ "CIDER REPL operational!"
+ "Your imagination is the only limit to what you can do with this REPL!"
+ "This REPL is yours to command!"
+ "Fame is but a hack away!"
+ "The REPL is not enough, but it is such a perfect place to start..."
+ "Keep on codin' in the free world!"
+ "What we do in the REPL echoes in eternity!"
+ "Evaluating is believing."
+ "To infinity... and beyond."
+ "Showtime!"
+ "Unfortunately, no one can be told what CIDER is. You have to figure this out yourself."
+ "Procure a bottle of cider to achieve optimum programming results."
+ "In parentheses we trust!"
+ "Write you some Clojure for Great Good!"
+ "Oh, what a day... what a lovely day!"
+ "What a day! What cannot be accomplished on such a splendid day!"
+ "Home is where your REPL is."
+ ,(format "%s, I've a feeling we're not in Kansas anymore."
+ (cider-user-first-name))
+ ,(format "%s, this could be the start of a beautiful program."
+ (cider-user-first-name)))
+ "Scientifically-proven optimal words of hackerish encouragement.")
+
+(defun cider-random-words-of-inspiration ()
+ "Select a random entry from `cider-words-of-inspiration'."
+ (eval (nth (random (length cider-words-of-inspiration))
+ cider-words-of-inspiration)))
+
+(defvar cider-tips
+ '("Press <\\[cider-connect]> to connect to a running nREPL server."
+ "Press <\\[cider-quit]> to quit the current connection."
+ "Press <\\[cider-view-manual]> to view CIDER's manual."
+ "Press <\\[cider-view-refcard]> to view CIDER's refcard."
+ "Press <\\[describe-mode]> to see a list of the keybindings available (this will work in every Emacs buffer)."
+ "Press <\\[cider-repl-handle-shortcut]> to quickly invoke some REPL command."
+ "Press <\\[cider-switch-to-last-clojure-buffer]> to switch between the REPL and a Clojure source buffer."
+ "Press <\\[cider-find-var]> to jump to the source of something (e.g. a var, a Java method)."
+ "Press <\\[cider-doc]> to view the documentation for something (e.g. a var, a Java method)."
+ "Press <\\[cider-find-resource]> to find a resource on the classpath."
+ "Press <\\[cider-selector]> to quickly select a CIDER buffer."
+ "Press <\\[cider-test-run-ns-tests]> to run the tests for the current namespace."
+ "Press <\\[cider-test-run-loaded-tests]> to run all loaded tests."
+ "Press <\\[cider-test-run-project-tests]> to run all tests for the current project."
+ "Press <\\[cider-apropos]> to look for a symbol by some search string."
+ "Press <\\[cider-apropos-documentation]> to look for a symbol that has some string in its docstring."
+ "Press <\\[cider-eval-defun-at-point]> to eval the top-level form at point."
+ "Press <\\[cider-eval-buffer]> to eval the entire source buffer."
+ "Press <\\[cider-scratch]> to create a Clojure scratchpad. Pretty handy for prototyping."
+ "Press <\\[cider-read-and-eval]> to evaluate some Clojure expression directly in the minibuffer."
+ "Press <\\[cider-drink-a-sip]> to get more CIDER tips."
+ "Press <\\[cider-browse-ns-all]> to start CIDER's namespace browser."
+ "Press <\\[cider-classpath]> to start CIDER's classpath browser."
+ "Press <\\[cider-repl-history]> to start CIDER's REPL input history browser."
+ "Press <\\[cider-macroexpand-1]> to expand the preceding macro."
+ "Press <\\[cider-inspect]> to inspect the preceding expression's result."
+ "Press <C-u \\[cider-inspect]> to inspect the defun at point's result."
+ "Press <C-u C-u \\[cider-inspect]> to read Clojure code from the minibuffer and inspect its result."
+ "Press <\\[cider-refresh]> to reload modified and unloaded namespaces."
+ "You can define Clojure functions to be called before and after `cider-refresh' (see `cider-refresh-before-fn' and `cider-refresh-after-fn'."
+ "Press <\\[cider-display-connection-info]> to view information about the connection."
+ "Press <\\[cider-undef]> to undefine a symbol in the current namespace."
+ "Press <\\[cider-interrupt]> to interrupt an ongoing evaluation."
+ "Use <M-x customize-group RET cider RET> to see every possible setting you can customize."
+ "Use <M-x customize-group RET cider-repl RET> to see every possible REPL setting you can customize."
+ "Enable `eldoc-mode' to display function & method signatures in the minibuffer."
+ "Enable `cider-enlighten-mode' to display the locals of a function when it's executed."
+ "Use <\\[cider-close-ancillary-buffers]> to close all ancillary buffers created by CIDER (e.g. *cider-doc*)."
+ "Exploring CIDER's menu-bar entries is a great way to discover features."
+ "Keep in mind that some commands don't have a keybinding by default. Explore CIDER!"
+ "Tweak `cider-repl-prompt-function' to customize your REPL prompt."
+ "Tweak `cider-eldoc-ns-function' to customize the way namespaces are displayed by eldoc.")
+ "Some handy CIDER tips."
+ )
+
+(defun cider-random-tip ()
+ "Select a random tip from `cider-tips'."
+ (substitute-command-keys (nth (random (length cider-tips)) cider-tips)))
+
+(defun cider-drink-a-sip ()
+ "Show a random tip."
+ (interactive)
+ (message (cider-random-tip)))
+
+(defun cider-column-number-at-pos (pos)
+ "Analog to `line-number-at-pos'.
+Return buffer column number at position POS."
+ (save-excursion
+ (goto-char pos)
+ ;; we have to adjust the column number by 1 to account for the fact
+ ;; that Emacs starts counting columns from 0 and Clojure from 1
+ (1+ (current-column))))
+
+(defun cider-propertize (text kind)
+ "Propertize TEXT as KIND.
+KIND can be the symbols `ns', `var', `emph', `fn', or a face name."
+ (propertize text 'face (pcase kind
+ (`fn 'font-lock-function-name-face)
+ (`var 'font-lock-variable-name-face)
+ (`ns 'font-lock-type-face)
+ (`emph 'font-lock-keyword-face)
+ (face face))))
+
+(defun cider--menu-add-help-strings (menu-list)
+ "Add a :help entries to items in MENU-LIST."
+ (mapcar (lambda (x)
+ (cond
+ ((listp x) (cider--menu-add-help-strings x))
+ ((and (vectorp x)
+ (not (plist-get (append x nil) :help))
+ (functionp (elt x 1)))
+ (vconcat x `[:help ,(documentation (elt x 1))]))
+ (t x)))
+ menu-list))
+
+(provide 'cider-util)
+
+;;; cider-util.el ends here
--- /dev/null
+;;; cider.el --- Clojure Interactive Development Environment that Rocks -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+;; Maintainer: Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; URL: http://www.github.com/clojure-emacs/cider
+;; Version: 0.15.0-snapshot
+;; Package-Requires: ((emacs "24.4") (clojure-mode "5.6.0") (pkg-info "0.4") (queue "0.1.1") (spinner "1.7") (seq "2.16"))
+;; Keywords: languages, clojure, cider
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Provides a Clojure interactive development environment for Emacs, built on
+;; top of nREPL.
+
+;;; Installation:
+
+;; Available as a package in melpa.org and stable.melpa.org
+
+;; (add-to-list 'package-archives
+;; '("melpa" . "https://melpa.org/packages/"))
+;;
+;; or
+;;
+;; (add-to-list 'package-archives
+;; '("melpa-stable" . "https://stable.melpa.org/packages/") t)
+;;
+;; M-x package-install cider
+
+;;; Usage:
+
+;; M-x cider-jack-in
+
+;;; Code:
+
+(defgroup cider nil
+ "Clojure Interactive Development Environment that Rocks."
+ :prefix "cider-"
+ :group 'applications
+ :link '(url-link :tag "GitHub" "https://github.com/clojure-emacs/cider")
+ :link '(url-link :tag "Online Manual" "https://cider.readthedocs.org")
+ :link '(emacs-commentary-link :tag "Commentary" "cider"))
+
+(defcustom cider-prompt-for-project-on-connect 'when-needed
+ "Controls whether to prompt for associated project on `cider-connect'.
+
+When set to when-needed, the project will be derived from the buffer you're
+visiting, when invoking `cider-connect'.
+When set to t, you'll always to prompted to select the matching project.
+When set to nil, you'll never be prompted to select a project and no
+project inference will take place."
+ :type '(choice (const :tag "always" t)
+ (const when-needed)
+ (const :tag "never" nil))
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(require 'cider-client)
+(require 'cider-eldoc)
+(require 'cider-repl)
+(require 'cider-mode)
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-debug)
+(require 'tramp-sh)
+(require 'cider-repl-history)
+
+(require 'seq)
+
+(defconst cider-version "0.15.0-snapshot"
+ "Fallback version used when it cannot be extracted automatically.
+Normally it won't be used, unless `pkg-info' fails to extract the
+version from the CIDER package or library.")
+
+(defconst cider-codename "London"
+ "Codename used to denote stable releases.")
+
+(defcustom cider-lein-command
+ "lein"
+ "The command used to execute Leiningen."
+ :type 'string
+ :group 'cider)
+
+(defcustom cider-lein-global-options
+ nil
+ "Command global options used to execute Leiningen (e.g.: -o for offline)."
+ :type 'string
+ :group 'cider)
+
+(defcustom cider-lein-parameters
+ "repl :headless"
+ "Params passed to Leiningen to start an nREPL server via `cider-jack-in'."
+ :type 'string
+ :group 'cider)
+
+(defcustom cider-boot-command
+ "boot"
+ "The command used to execute Boot."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-boot-global-options
+ nil
+ "Command global options used to execute Boot (e.g.: -c for checkouts)."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.14.0"))
+
+(defcustom cider-boot-parameters
+ "repl -s wait"
+ "Params passed to boot to start an nREPL server via `cider-jack-in'."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-gradle-command
+ "gradle"
+ "The command used to execute Gradle."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-gradle-global-options
+ "--no-daemon"
+ "Command line options used to execute Gradle (e.g.: -m for dry run)."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.14.0"))
+
+(defcustom cider-gradle-parameters
+ "clojureRepl"
+ "Params passed to gradle to start an nREPL server via `cider-jack-in'."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.10.0"))
+
+(defcustom cider-default-repl-command
+ "lein"
+ "The default command and parameters to use when connecting to nREPL.
+This value will only be consulted when no identifying file types, i.e.
+project.clj for leiningen or build.boot for boot, could be found."
+ :type 'string
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-preferred-build-tool
+ nil
+ "Allow choosing a build system when there are many.
+When there are artifacts from multiple build systems (\"lein\", \"boot\",
+\"gradle\") the user is prompted to select one of them. When non-nil, this
+variable will suppress this behavior and will select whatever build system
+is indicated by the variable if present. Note, this is only when CIDER
+cannot decide which of many build systems to use and will never override a
+command when there is no ambiguity."
+ :type '(choice (const "lein")
+ (const "boot")
+ (const "gradle")
+ (const :tag "Always ask" nil))
+ :group 'cider
+ :package-version '(cider . "0.13.0"))
+
+(defcustom cider-allow-jack-in-without-project 'warn
+ "Controls what happens when doing `cider-jack-in' outside a project.
+When set to 'warn you'd prompted to confirm the command.
+When set to t `cider-jack-in' will quietly continue.
+When set to nil `cider-jack-in' will fail."
+ :type '(choice (const :tag "always" t)
+ (const 'warn)
+ (const :tag "never" nil))
+ :group 'cider
+ :package-version '(cider . "0.15.0"))
+
+(defcustom cider-known-endpoints nil
+ "A list of connection endpoints where each endpoint is a list.
+For example: \\='((\"label\" \"host\" \"port\")).
+The label is optional so that \\='(\"host\" \"port\") will suffice.
+This variable is used by `cider-connect'."
+ :type '(repeat (list (string :tag "label")
+ (string :tag "host")
+ (string :tag "port")))
+ :group 'cider)
+
+(defcustom cider-connected-hook nil
+ "List of functions to call when connected to Clojure nREPL server."
+ :type 'hook
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-disconnected-hook nil
+ "List of functions to call when disconnected from the Clojure nREPL server."
+ :type 'hook
+ :group 'cider
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-auto-mode t
+ "When non-nil, automatically enable `cider-mode' for all Clojure buffers."
+ :type 'boolean
+ :package-version '(cider . "0.9.0"))
+
+(defcustom cider-inject-dependencies-at-jack-in t
+ "When nil, do not inject repl dependencies (most likely nREPL middlewares) at `cider-jack-in' time."
+ :type 'boolean
+ :version '(cider . "0.11.0"))
+
+(defvar cider-ps-running-nrepls-command "ps u | grep leiningen"
+ "Process snapshot command used in `cider-locate-running-nrepl-ports'.")
+
+(defvar cider-ps-running-nrepl-path-regexp-list
+ '("\\(?:leiningen.original.pwd=\\)\\(.+?\\) -D"
+ "\\(?:-classpath +:?\\(.+?\\)/self-installs\\)")
+ "Regexp list to get project paths.
+Extract project paths from output of `cider-ps-running-nrepls-command'.
+Sub-match 1 must be the project path.")
+
+(defvar cider-host-history nil
+ "Completion history for connection hosts.")
+
+;;;###autoload
+(defun cider-version ()
+ "Display CIDER's version."
+ (interactive)
+ (message "CIDER %s" (cider--version)))
+
+(defun cider-jack-in-command (project-type)
+ "Determine the command `cider-jack-in' needs to invoke for the PROJECT-TYPE."
+ (pcase project-type
+ ("lein" cider-lein-command)
+ ("boot" cider-boot-command)
+ ("gradle" cider-gradle-command)
+ (_ (user-error "Unsupported project type `%s'" project-type))))
+
+(defun cider-jack-in-resolve-command (project-type)
+ "Determine the resolved file path to `cider-jack-in-command' if it can be
+found for the PROJECT-TYPE"
+ (pcase project-type
+ ("lein" (cider--lein-resolve-command))
+ ("boot" (cider--boot-resolve-command))
+ ("gradle" (cider--gradle-resolve-command))
+ (_ (user-error "Unsupported project type `%s'" project-type))))
+
+(defun cider-jack-in-global-options (project-type)
+ "Determine the command line options for `cider-jack-in' for the PROJECT-TYPE."
+ (pcase project-type
+ ("lein" cider-lein-global-options)
+ ("boot" cider-boot-global-options)
+ ("gradle" cider-gradle-global-options)
+ (_ (user-error "Unsupported project type `%s'" project-type))))
+
+(defun cider-jack-in-params (project-type)
+ "Determine the commands params for `cider-jack-in' for the PROJECT-TYPE."
+ (pcase project-type
+ ("lein" cider-lein-parameters)
+ ("boot" cider-boot-parameters)
+ ("gradle" cider-gradle-parameters)
+ (_ (user-error "Unsupported project type `%s'" project-type))))
+
+\f
+;;; Jack-in dependencies injection
+(defvar cider-jack-in-dependencies nil
+ "List of dependencies where elements are lists of artifact name and version.")
+(put 'cider-jack-in-dependencies 'risky-local-variable t)
+(cider-add-to-alist 'cider-jack-in-dependencies
+ "org.clojure/tools.nrepl" "0.2.12")
+
+(defvar cider-jack-in-dependencies-exclusions nil
+ "List of exclusions for jack in dependencies.
+
+Elements of the list are artifact name and list of exclusions to apply for the artifact.")
+(put 'cider-jack-in-dependencies-exclusions 'risky-local-variable t)
+(cider-add-to-alist 'cider-jack-in-dependencies-exclusions
+ "org.clojure/tools.nrepl" '("org.clojure/clojure"))
+
+(defcustom cider-jack-in-auto-inject-clojure nil
+ "Version of clojure to auto-inject into REPL.
+
+If nil, do not inject Clojure into the REPL. If `latest', inject
+`cider-latest-clojure-version', which should approximate to the most recent
+version of Clojure. If `minimal', inject `cider-minimum-clojure-version',
+which will be the lowest version CIDER supports. If a string, use this as
+the version number. If it is a list, the first element should be a string,
+specifying the artifact ID, and the second element the version number."
+ :type '(choice (const :tag "None" nil)
+ (const :tag "Latest" 'latest)
+ (const :tag "Minimal" 'minimal)
+ (string :tag "Specific Version")
+ (list :tag "Artifact ID and Version"
+ (string :tag "Artifact ID")
+ (string :tag "Version"))))
+
+(defvar cider-jack-in-lein-plugins nil
+ "List of Leiningen plugins where elements are lists of artifact name and version.")
+(put 'cider-jack-in-lein-plugins 'risky-local-variable t)
+(cider-add-to-alist 'cider-jack-in-lein-plugins
+ "cider/cider-nrepl" (upcase cider-version))
+
+(defvar cider-jack-in-nrepl-middlewares nil
+ "List of Clojure variable names.
+Each of these Clojure variables should hold a vector of nREPL middlewares.")
+(put 'cider-jack-in-nrepl-middlewares 'risky-local-variable t)
+(add-to-list 'cider-jack-in-nrepl-middlewares "cider.nrepl/cider-middleware")
+
+(defun cider--list-as-boot-artifact (list)
+ "Return a boot artifact string described by the elements of LIST.
+LIST should have the form (ARTIFACT-NAME ARTIFACT-VERSION). The returned
+string is quoted for passing as argument to an inferior shell."
+ (concat "-d " (shell-quote-argument (format "%s:%s" (car list) (cadr list)))))
+
+(defun cider-boot-dependencies (dependencies)
+ "Return a list of boot artifact strings created from DEPENDENCIES."
+ (concat (mapconcat #'cider--list-as-boot-artifact dependencies " ")
+ (when (not (seq-empty-p dependencies)) " ")))
+
+(defun cider-boot-middleware-task (params middlewares)
+ (concat "cider.tasks/add-middleware "
+ (mapconcat (lambda (middleware)
+ (format "-m %s" (shell-quote-argument middleware)))
+ middlewares
+ " ")
+ " " params))
+
+(defun cider-boot-jack-in-dependencies (global-opts params dependencies plugins middlewares)
+ (concat global-opts
+ (when (not (seq-empty-p global-opts)) " ")
+ "-i \"(require 'cider.tasks)\" " ;; Note the white space at the end here
+ (cider-boot-dependencies (append dependencies plugins))
+ (cider-boot-middleware-task params middlewares)))
+
+(defun cider--lein-artifact-exclusions (exclusions)
+ "Return an exclusions vector described by the elements of EXCLUSIONS."
+ (if exclusions
+ (format " :exclusions [%s]" (mapconcat #'identity exclusions " "))
+ ""))
+
+(defun cider--list-as-lein-artifact (list &optional exclusions)
+ "Return an artifact string described by the elements of LIST.
+LIST should have the form (ARTIFACT-NAME ARTIFACT-VERSION). Optionally a list
+of EXCLUSIONS can be provided as well. The returned
+string is quoted for passing as argument to an inferior shell."
+ (shell-quote-argument (format "[%s %S%s]" (car list) (cadr list) (cider--lein-artifact-exclusions exclusions))))
+
+(defun cider-lein-jack-in-dependencies (global-opts params dependencies dependencies-exclusions lein-plugins)
+ (concat
+ global-opts
+ (when (not (seq-empty-p global-opts)) " ")
+ (mapconcat #'identity
+ (append (seq-map (lambda (dep)
+ (let ((exclusions (cadr (assoc (car dep) dependencies-exclusions))))
+ (concat "update-in :dependencies conj "
+ (cider--list-as-lein-artifact dep exclusions))))
+ dependencies)
+ (seq-map (lambda (plugin)
+ (concat "update-in :plugins conj "
+ (cider--list-as-lein-artifact plugin)))
+ lein-plugins))
+ " -- ")
+ " -- "
+ params))
+
+(defun cider-add-clojure-dependencies-maybe (dependencies)
+ "Return DEPENDENCIES with an added Clojure dependency if requested.
+
+See also `cider-jack-in-auto-inject-clojure'."
+ (if cider-jack-in-auto-inject-clojure
+ (if (consp cider-jack-in-auto-inject-clojure)
+ (cons cider-jack-in-auto-inject-clojure dependencies)
+ (cons (list cider-clojure-artifact-id
+ (cond
+ ((stringp cider-jack-in-auto-inject-clojure)
+ cider-jack-in-auto-inject-clojure)
+ ((eq cider-jack-in-auto-inject-clojure 'minimal)
+ cider-minimum-clojure-version)
+ ((eq cider-jack-in-auto-inject-clojure 'latest)
+ cider-latest-clojure-version)))
+ dependencies))
+ dependencies))
+
+(defun cider-inject-jack-in-dependencies (global-opts params project-type)
+ "Return PARAMS with injected REPL dependencies.
+These are set in `cider-jack-in-dependencies', `cider-jack-in-lein-plugins' and
+`cider-jack-in-nrepl-middlewares' are injected from the CLI according to
+the used PROJECT-TYPE. Eliminates the need for hacking profiles.clj or the
+boot script for supporting cider with its nREPL middleware and
+dependencies."
+ (pcase project-type
+ ("lein" (cider-lein-jack-in-dependencies
+ global-opts
+ params
+ (cider-add-clojure-dependencies-maybe
+ cider-jack-in-dependencies)
+ cider-jack-in-dependencies-exclusions
+ cider-jack-in-lein-plugins))
+ ("boot" (cider-boot-jack-in-dependencies
+ global-opts
+ params
+ (cider-add-clojure-dependencies-maybe
+ cider-jack-in-dependencies)
+ cider-jack-in-lein-plugins
+ cider-jack-in-nrepl-middlewares))
+ ("gradle" (concat
+ global-opts
+ (when (not (seq-empty-p global-opts)) " ")
+ params))
+ (_ (error "Unsupported project type `%s'" project-type))))
+
+\f
+;;; ClojureScript REPL creation
+(defconst cider--cljs-repl-types
+ '(("(cemerick.piggieback/cljs-repl (cljs.repl.rhino/repl-env))"
+ "Rhino" "")
+ ("(do (require 'figwheel-sidecar.repl-api) (figwheel-sidecar.repl-api/start-figwheel!) (figwheel-sidecar.repl-api/cljs-repl))"
+ "Figwheel-sidecar" " (add figwheel-sidecar to your plugins)")
+ ("(do (require 'cljs.repl.node) (cemerick.piggieback/cljs-repl (cljs.repl.node/repl-env)))"
+ "Node" " (requires NodeJS to be installed)")
+ ("(do (require 'weasel.repl.websocket) (cemerick.piggieback/cljs-repl (weasel.repl.websocket/repl-env :ip \"127.0.0.1\" :port 9001)))"
+ "Weasel" " (see http://cider.readthedocs.io/en/latest/up_and_running/#browser-connected-clojurescript-repl)")
+ ("(do (require 'adzerk.boot-cljs-repl) (adzerk.boot-cljs-repl/start-repl))"
+ "Boot-cljs-repl" " (see https://github.com/adzerk-oss/boot-cljs-repl/blob/master/README.md")))
+
+(defcustom cider-cljs-lein-repl "(cemerick.piggieback/cljs-repl (cljs.repl.rhino/repl-env))"
+ "Clojure form that returns a ClojureScript REPL environment.
+This is only used in lein projects. It is evaluated in a Clojure REPL and
+it should start a ClojureScript REPL."
+ :type `(choice ,@(seq-map (lambda (x) `(const :tag ,(apply #'concat (cdr x)) ,(car x)))
+ cider--cljs-repl-types)
+ (string :tag "Custom"))
+ :safe (lambda (x) (assoc x cider--cljs-repl-types))
+ :package-version '(cider . "0.11.0")
+ :group 'cider)
+
+(defcustom cider-cljs-boot-repl "(do (require 'adzerk.boot-cljs-repl) (adzerk.boot-cljs-repl/start-repl))"
+ "Clojure form that returns a ClojureScript REPL environment.
+This is only used in boot projects. It is evaluated in a Clojure REPL and
+it should start a ClojureScript REPL."
+ :type `(choice ,@(seq-map (lambda (x) `(const :tag ,(apply #'concat (cdr x)) ,(car x)))
+ cider--cljs-repl-types)
+ (string :tag "Custom"))
+ :safe (lambda (x) (assoc x cider--cljs-repl-types))
+ :package-version '(cider . "0.15.0")
+ :group 'cider)
+
+(defcustom cider-cljs-gradle-repl "(cemerick.piggieback/cljs-repl (cljs.repl.rhino/repl-env))"
+ "Clojure form that returns a ClojureScript REPL environment.
+This is only used in gradle projects. It is evaluated in a Clojure REPL and
+it should start a ClojureScript REPL."
+ :type `(choice ,@(seq-map (lambda (x) `(const :tag ,(apply #'concat (cdr x)) ,(car x)))
+ cider--cljs-repl-types)
+ (string :tag "Custom"))
+ :safe (lambda (x) (assoc x cider--cljs-repl-types))
+ :package-version '(cider . "0.15.0")
+ :group 'cider)
+
+(defun cider-cljs-repl-form (project-type)
+ "Return a Clojure form that returns a ClojureScript REPL environment
+based on PROJECT-TYPE."
+ (pcase project-type
+ ("lein" cider-cljs-lein-repl)
+ ("boot" cider-cljs-boot-repl)
+ ("gradle" cider-cljs-gradle-repl)
+ (_ (error "Unsupported project type `%s'" project-type))))
+
+(defun cider--offer-to-open-app-in-browser (server-buffer)
+ "Look for a server address in SERVER-BUFFER and offer to open it."
+ (when (buffer-live-p server-buffer)
+ (with-current-buffer server-buffer
+ (save-excursion
+ (goto-char (point-min))
+ (when-let ((url (and (search-forward-regexp "http://localhost:[0-9]+" nil 'noerror)
+ (match-string 0))))
+ (when (y-or-n-p (format "Visit ‘%s’ in a browser? " url))
+ (browse-url url)))))))
+
+(defun cider-create-sibling-cljs-repl (client-buffer)
+ "Create a ClojureScript REPL with the same server as CLIENT-BUFFER.
+The new buffer will correspond to the same project as CLIENT-BUFFER, which
+should be the regular Clojure REPL started by the server process filter."
+ (interactive (list (cider-current-connection)))
+ (let* ((nrepl-repl-buffer-name-template "*cider-repl CLJS%s*")
+ (nrepl-create-client-buffer-function #'cider-repl-create)
+ (nrepl-use-this-as-repl-buffer 'new)
+ (client-process-args (with-current-buffer client-buffer
+ (unless (or nrepl-server-buffer nrepl-endpoint)
+ (error "This is not a REPL buffer, is there a REPL active?"))
+ (list (car nrepl-endpoint)
+ (elt nrepl-endpoint 1)
+ (when (buffer-live-p nrepl-server-buffer)
+ (get-buffer-process nrepl-server-buffer)))))
+ (cljs-proc (apply #'nrepl-start-client-process client-process-args))
+ (cljs-buffer (process-buffer cljs-proc))
+ (cljs-repl-form (cider-cljs-repl-form (cider-project-type))))
+ (with-current-buffer cljs-buffer
+ ;; The new connection has now been bumped to the top, but it's still a
+ ;; Clojure REPL! Additionally, some ClojureScript REPLs can actually take
+ ;; a while to start (some even depend on the user opening a browser).
+ ;; Meanwhile, this REPL will gladly receive requests in place of the
+ ;; original Clojure REPL. Our solution is to bump the original REPL back
+ ;; up the list, so it takes priority on Clojure requests.
+ (cider-make-connection-default client-buffer)
+ (pcase (assoc cljs-repl-form cider--cljs-repl-types)
+ (`(,_ ,name ,info)
+ (message "Starting a %s REPL%s" name (or info "")))
+ (_ (message "Starting a custom ClojureScript REPL")))
+ (cider-nrepl-send-request
+ (list "op" "eval"
+ "ns" (cider-current-ns)
+ "code" cljs-repl-form)
+ (cider-repl-handler (current-buffer)))
+ (cider--offer-to-open-app-in-browser nrepl-server-buffer))))
+
+(defun cider--select-zombie-buffer (repl-buffers)
+ "Return a zombie buffer from REPL-BUFFERS, or nil if none exists."
+ (when-let ((zombie-buffs (seq-remove #'get-buffer-process repl-buffers)))
+ (when (y-or-n-p
+ (format "Zombie REPL buffers exist (%s). Reuse? "
+ (mapconcat #'buffer-name zombie-buffs ", ")))
+ (if (= (length zombie-buffs) 1)
+ (car zombie-buffs)
+ (completing-read "Choose REPL buffer: "
+ (mapcar #'buffer-name zombie-buffs)
+ nil t)))))
+
+(defun cider-find-reusable-repl-buffer (endpoint project-directory)
+ "Check whether a reusable connection buffer already exists.
+Looks for buffers where `nrepl-endpoint' matches ENDPOINT, or
+`nrepl-project-dir' matches PROJECT-DIRECTORY. If such a buffer was found,
+and has no process, return it. If the process is alive, ask the user for
+confirmation and return 'new/nil for y/n answer respectively. If other
+REPL buffers with dead process exist, ask the user if any of those should
+be reused."
+ (if-let ((repl-buffers (cider-repl-buffers))
+ (exact-buff (seq-find
+ (lambda (buff)
+ (with-current-buffer buff
+ (or (and endpoint
+ (equal endpoint nrepl-endpoint))
+ (and project-directory
+ (equal project-directory nrepl-project-dir)))))
+ repl-buffers)))
+ (if (get-buffer-process exact-buff)
+ (when (y-or-n-p (format "REPL buffer already exists (%s). \
+Do you really want to create a new one? "
+ exact-buff))
+ 'new)
+ exact-buff)
+ (or (cider--select-zombie-buffer repl-buffers) 'new)))
+
+;;;###autoload
+(defun cider-jack-in (&optional prompt-project cljs-too)
+ "Start an nREPL server for the current project and connect to it.
+If PROMPT-PROJECT is t, then prompt for the project for which to
+start the server.
+If CLJS-TOO is non-nil, also start a ClojureScript REPL session with its
+own buffer."
+ (interactive "P")
+ (setq cider-current-clojure-buffer (current-buffer))
+ (let* ((project-type (cider-project-type))
+ (command (cider-jack-in-command project-type))
+ (command-resolved (cider-jack-in-resolve-command project-type))
+ (command-global-opts (cider-jack-in-global-options project-type))
+ (command-params (cider-jack-in-params project-type)))
+ (if command-resolved
+ (let* ((project (when prompt-project
+ (read-directory-name "Project: ")))
+ (project-dir (clojure-project-dir
+ (or project (cider-current-dir))))
+ (params (if prompt-project
+ (read-string (format "nREPL server command: %s "
+ command-params)
+ command-params)
+ command-params))
+ (params (if cider-inject-dependencies-at-jack-in
+ (cider-inject-jack-in-dependencies command-global-opts params project-type)
+ params))
+
+ (cmd (format "%s %s" command-resolved params)))
+ (if (or project-dir cider-allow-jack-in-without-project)
+ (progn
+ (when (or project-dir
+ (eq cider-allow-jack-in-without-project t)
+ (and (null project-dir)
+ (eq cider-allow-jack-in-without-project 'warn)
+ (y-or-n-p "Are you sure you want to run `cider-jack-in' without a Clojure project? ")))
+ (when-let ((repl-buff (cider-find-reusable-repl-buffer nil project-dir)))
+ (let ((nrepl-create-client-buffer-function #'cider-repl-create)
+ (nrepl-use-this-as-repl-buffer repl-buff))
+ (nrepl-start-server-process
+ project-dir cmd
+ (when cljs-too #'cider-create-sibling-cljs-repl))))))
+ (user-error "`cider-jack-in' is not allowed without a Clojure project")))
+ (user-error "The %s executable isn't on your `exec-path'" command))))
+
+;;;###autoload
+(defun cider-jack-in-clojurescript (&optional prompt-project)
+ "Start an nREPL server and connect to it both Clojure and ClojureScript REPLs.
+If PROMPT-PROJECT is t, then prompt for the project for which to
+start the server."
+ (interactive "P")
+ (cider-jack-in prompt-project 'cljs-too))
+
+;;;###autoload
+(defun cider-connect (host port &optional project-dir)
+ "Connect to an nREPL server identified by HOST and PORT.
+Create REPL buffer and start an nREPL client connection.
+
+When the optional param PROJECT-DIR is present, the connection
+gets associated with it."
+ (interactive (cider-select-endpoint))
+ (setq cider-current-clojure-buffer (current-buffer))
+ (when-let ((repl-buff (cider-find-reusable-repl-buffer `(,host ,port) nil)))
+ (let* ((nrepl-create-client-buffer-function #'cider-repl-create)
+ (nrepl-use-this-as-repl-buffer repl-buff)
+ (conn (process-buffer (nrepl-start-client-process host port))))
+ (with-current-buffer conn
+ (setq cider-connection-created-with 'connect))
+ (if project-dir
+ (cider-assoc-project-with-connection project-dir conn)
+ (let ((project-dir (clojure-project-dir)))
+ (cond
+ ;; associate only if we're in a project
+ ((and project-dir (null cider-prompt-for-project-on-connect)) (cider-assoc-project-with-connection project-dir conn))
+ ;; associate if we're in a project, prompt otherwise
+ ((eq cider-prompt-for-project-on-connect 'when-needed) (cider-assoc-project-with-connection project-dir conn))
+ ;; always prompt
+ (t (cider-assoc-project-with-connection nil conn))))))))
+
+(defun cider-current-host ()
+ "Retrieve the current host."
+ (if (and (stringp buffer-file-name)
+ (file-remote-p buffer-file-name))
+ tramp-current-host
+ "localhost"))
+
+(defun cider-select-endpoint ()
+ "Interactively select the host and port to connect to."
+ (dolist (endpoint cider-known-endpoints)
+ (unless (stringp (or (nth 2 endpoint)
+ (nth 1 endpoint)))
+ (user-error "The port for %s in `cider-known-endpoints' should be a string"
+ (nth 0 endpoint))))
+ (let* ((ssh-hosts (cider--ssh-hosts))
+ (hosts (seq-uniq (append (when cider-host-history
+ ;; history elements are strings of the form "host:port"
+ (list (split-string (car cider-host-history) ":")))
+ (list (list (cider-current-host)))
+ cider-known-endpoints
+ ssh-hosts
+ (when (file-remote-p default-directory)
+ ;; add localhost even in remote buffers
+ '(("localhost"))))))
+ (sel-host (cider--completing-read-host hosts))
+ (host (car sel-host))
+ (port (or (cadr sel-host)
+ (cider--completing-read-port host (cider--infer-ports host ssh-hosts)))))
+ (list host port)))
+
+(defun cider--ssh-hosts ()
+ "Retrieve all ssh host from local configuration files."
+ (seq-map (lambda (s) (list (replace-regexp-in-string ":$" "" s)))
+ (let ((tramp-completion-mode t))
+ (tramp-completion-handle-file-name-all-completions "" "/ssh:"))))
+
+(defun cider--completing-read-host (hosts)
+ "Interactively select host from HOSTS.
+Each element in HOSTS is one of: (host), (host port) or (label host port).
+Return a list of the form (HOST PORT), where PORT can be nil."
+ (let* ((hosts (cider-join-into-alist hosts))
+ (sel-host (completing-read "Host: " hosts nil nil nil
+ 'cider-host-history (caar hosts)))
+ (host (or (cdr (assoc sel-host hosts)) (list sel-host))))
+ ;; remove the label
+ (if (= 3 (length host)) (cdr host) host)))
+
+(defun cider--infer-ports (host ssh-hosts)
+ "Infer nREPL ports on HOST.
+Return a list of elements of the form (directory port). SSH-HOSTS is a list
+of remote SSH hosts."
+ (let ((localp (or (nrepl-local-host-p host)
+ (not (assoc-string host ssh-hosts)))))
+ (if localp
+ ;; change dir: current file might be remote
+ (let* ((change-dir-p (file-remote-p default-directory))
+ (default-directory (if change-dir-p "~/" default-directory)))
+ (cider-locate-running-nrepl-ports (unless change-dir-p default-directory)))
+ (let ((vec (vector "sshx" nil host "" nil))
+ ;; change dir: user might want to connect to a different remote
+ (dir (when (file-remote-p default-directory)
+ (with-parsed-tramp-file-name default-directory cur
+ (when (string= cur-host host) default-directory)))))
+ (tramp-maybe-open-connection vec)
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (cider-locate-running-nrepl-ports dir))))))
+
+(defun cider--completing-read-port (host ports)
+ "Interactively select port for HOST from PORTS."
+ (let* ((ports (cider-join-into-alist ports))
+ (sel-port (completing-read (format "Port for %s: " host) ports
+ nil nil nil nil (caar ports)))
+ (port (or (cdr (assoc sel-port ports)) sel-port))
+ (port (if (listp port) (cadr port) port)))
+ (if (stringp port) (string-to-number port) port)))
+
+(defun cider-locate-running-nrepl-ports (&optional dir)
+ "Locate ports of running nREPL servers.
+When DIR is non-nil also look for nREPL port files in DIR. Return a list
+of list of the form (project-dir port)."
+ (let* ((paths (cider--running-nrepl-paths))
+ (proj-ports (mapcar (lambda (d)
+ (when-let ((port (and d (nrepl-extract-port (cider--file-path d)))))
+ (list (file-name-nondirectory (directory-file-name d)) port)))
+ (cons (clojure-project-dir dir) paths))))
+ (seq-uniq (delq nil proj-ports))))
+
+(defun cider--running-nrepl-paths ()
+ "Retrieve project paths of running nREPL servers.
+Use `cider-ps-running-nrepls-command' and `cider-ps-running-nrepl-path-regexp-list'."
+ (let (paths)
+ (with-temp-buffer
+ (insert (shell-command-to-string cider-ps-running-nrepls-command))
+ (dolist (regexp cider-ps-running-nrepl-path-regexp-list)
+ (goto-char 1)
+ (while (re-search-forward regexp nil t)
+ (setq paths (cons (match-string 1) paths)))))
+ (seq-uniq paths)))
+
+(defun cider--identify-buildtools-present ()
+ "Identify build systems present by their build files."
+ (let* ((default-directory (clojure-project-dir (cider-current-dir)))
+ (build-files '(("lein" . "project.clj")
+ ("boot" . "build.boot")
+ ("gradle" . "build.gradle"))))
+ (delq nil
+ (mapcar (lambda (candidate)
+ (when (file-exists-p (cdr candidate))
+ (car candidate)))
+ build-files))))
+
+(defun cider-project-type ()
+ "Determine the type, either leiningen, boot or gradle, of the current project.
+If more than one project file types are present, check for a preferred
+build tool in `cider-preferred-build-tool', otherwise prompt the user to
+choose."
+ (let* ((choices (cider--identify-buildtools-present))
+ (multiple-project-choices (> (length choices) 1))
+ (default (car choices)))
+ (cond ((and multiple-project-choices
+ (member cider-preferred-build-tool choices))
+ cider-preferred-build-tool)
+ (multiple-project-choices
+ (completing-read (format "Which command should be used (default %s): " default)
+ choices nil t nil nil default))
+ (choices
+ (car choices))
+ (t cider-default-repl-command))))
+
+
+;; TODO: Implement a check for `cider-lein-command' over tramp
+(defun cider--lein-resolve-command ()
+ "Find `cider-lein-command' on `exec-path' if possible, or return `nil'.
+
+In case `default-directory' is non-local we assume the command is available."
+ (when-let ((command (or (and (file-remote-p default-directory) cider-lein-command)
+ (executable-find cider-lein-command)
+ (executable-find (concat cider-lein-command ".bat")))))
+ (shell-quote-argument command)))
+
+;; TODO: Implement a check for `cider-boot-command' over tramp
+(defun cider--boot-resolve-command ()
+ "Find `cider-boot-command' on `exec-path' if possible, or return `nil'.
+
+In case `default-directory' is non-local we assume the command is available."
+ (when-let ((command (or (and (file-remote-p default-directory) cider-boot-command)
+ (executable-find cider-boot-command)
+ (executable-find (concat cider-boot-command ".exe")))))
+ (shell-quote-argument command)))
+
+;; TODO: Implement a check for `cider-gradle-command' over tramp
+(defun cider--gradle-resolve-command ()
+ "Find `cider-gradle-command' on `exec-path' if possible, or return `nil'.
+
+In case `default-directory' is non-local we assume the command is available."
+ (when-let ((command (or (and (file-remote-p default-directory) cider-gradle-command)
+ (executable-find cider-gradle-command)
+ (executable-find (concat cider-gradle-command ".exe")))))
+ (shell-quote-argument command)))
+
+\f
+;;; Check that the connection is working well
+;; TODO: This is nrepl specific. It should eventually go into some cider-nrepl-client
+;; file.
+(defun cider--check-required-nrepl-version ()
+ "Check whether we're using a compatible nREPL version."
+ (if-let ((nrepl-version (cider--nrepl-version)))
+ (when (version< nrepl-version cider-required-nrepl-version)
+ (cider-repl-manual-warning "troubleshooting/#warning-saying-you-have-to-use-nrepl-0212"
+ "CIDER requires nREPL %s (or newer) to work properly"
+ cider-required-nrepl-version))
+ (cider-repl-manual-warning "troubleshooting/#warning-saying-you-have-to-use-nrepl-0212"
+ "Can't determine nREPL's version.\nPlease, update nREPL to %s."
+ cider-required-nrepl-version)))
+
+(defun cider--check-clojure-version-supported ()
+ "Ensure that we are meeting the minimum supported version of Clojure."
+ (if-let ((clojure-version (cider--clojure-version)))
+ (when (version< clojure-version cider-minimum-clojure-version)
+ (cider-repl-manual-warning "installation/#prerequisites"
+ "Clojure version (%s) is not supported (minimum %s). CIDER will not work."
+ clojure-version cider-minimum-clojure-version))
+ (cider-repl-manual-warning "installation/#prerequisites"
+ "Can't determine Clojure's version. CIDER requires Clojure %s (or newer)."
+ cider-minimum-clojure-version)))
+
+(defun cider--check-middleware-compatibility ()
+ "CIDER frontend/backend compatibility check.
+Retrieve the underlying connection's CIDER-nREPL version and checks if the
+middleware used is compatible with CIDER. If not, will display a warning
+message in the REPL area."
+ (let* ((version-dict (nrepl-aux-info "cider-version" (cider-current-connection)))
+ (middleware-version (nrepl-dict-get version-dict "version-string" "not installed")))
+ (unless (equal cider-version middleware-version)
+ (cider-repl-manual-warning "troubleshooting/#cider-complains-of-the-cider-nrepl-version"
+ "CIDER's version (%s) does not match cider-nrepl's version (%s). Things will break!"
+ cider-version middleware-version))))
+
+(defun cider--subscribe-repl-to-server-out ()
+ "Subscribe to the server's *out*."
+ (cider-nrepl-send-request '("op" "out-subscribe")
+ (cider-interactive-eval-handler (current-buffer))))
+
+(defun cider--connected-handler ()
+ "Handle cider initialization after nREPL connection has been established.
+This function is appended to `nrepl-connected-hook' in the client process
+buffer."
+ ;; `nrepl-connected-hook' is run in the connection buffer
+ (cider-make-connection-default (current-buffer))
+ (cider-repl-init (current-buffer))
+ (cider--check-required-nrepl-version)
+ (cider--check-clojure-version-supported)
+ (cider--check-middleware-compatibility)
+ (cider--debug-init-connection)
+ (cider--subscribe-repl-to-server-out)
+ (when cider-auto-mode
+ (cider-enable-on-existing-clojure-buffers))
+ (run-hooks 'cider-connected-hook))
+
+(defun cider--disconnected-handler ()
+ "Cleanup after nREPL connection has been lost or closed.
+This function is appended to `nrepl-disconnected-hook' in the client
+process buffer."
+ ;; `nrepl-connected-hook' is run in the connection buffer
+ (cider-possibly-disable-on-existing-clojure-buffers)
+ (run-hooks 'cider-disconnected-hook))
+
+;;;###autoload
+(eval-after-load 'clojure-mode
+ '(progn
+ (define-key clojure-mode-map (kbd "C-c M-j") #'cider-jack-in)
+ (define-key clojure-mode-map (kbd "C-c M-J") #'cider-jack-in-clojurescript)
+ (define-key clojure-mode-map (kbd "C-c M-c") #'cider-connect)))
+
+(provide 'cider)
+
+;;; cider.el ends here
--- /dev/null
+;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+;;
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; This file is not part of GNU Emacs.
+;;
+;;; Commentary:
+;;
+;; Provides an Emacs Lisp client to connect to Clojure nREPL servers.
+;;
+;; A connection is an abstract idea of the communication between Emacs (client)
+;; and nREPL server. On the Emacs side connections are represented by two
+;; running processes. The two processes are the server process and client
+;; process (the connection to the server). Each of these is represented by its
+;; own process buffer, filter and sentinel.
+;;
+;; The nREPL communication process can be broadly represented as follows:
+;;
+;; 1) The server process is started as an Emacs subprocess (usually by
+;; `cider-jack-in', which in turn fires up leiningen or boot). Note that
+;; if a connection was established using `cider-connect' there won't be
+;; a server process.
+;;
+;; 2) The server's process filter (`nrepl-server-filter') detects the
+;; connection port from the first plain text response from the server and
+;; starts a communication process (socket connection) as another Emacs
+;; subprocess. This is the nREPL client process (`nrepl-client-filter').
+;; All requests and responses handling happens through this client
+;; connection.
+;;
+;; 3) Requests are sent by `nrepl-send-request' and
+;; `nrepl-send-sync-request'. A request is simply a list containing a
+;; requested operation name and the parameters required by the
+;; operation. Each request has an associated callback that is called once
+;; the response for the request has arrived. Besides the above functions
+;; there are specialized request senders for each type of common
+;; operations. Examples are `nrepl-request:eval', `nrepl-request:clone',
+;; `nrepl-sync-request:describe'.
+;;
+;; 4) Responses from the server are decoded in `nrepl-client-filter' and are
+;; physically represented by alists whose structure depends on the type of
+;; the response. After having been decoded, the data from the response is
+;; passed over to the callback that was registered by the original
+;; request.
+;;
+;; Please see the comments in dedicated sections of this file for more detailed
+;; description.
+
+;;; Code:
+(require 'seq)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cl-lib)
+(require 'nrepl-dict)
+(require 'queue)
+(require 'tramp)
+
+\f
+;;; Custom
+
+(defgroup nrepl nil
+ "Interaction with the Clojure nREPL Server."
+ :prefix "nrepl-"
+ :group 'applications)
+
+(defcustom nrepl-buffer-name-separator " "
+ "Used in constructing the REPL buffer name.
+The `nrepl-buffer-name-separator' separates cider-repl from the project name."
+ :type '(string)
+ :group 'nrepl)
+
+(defcustom nrepl-buffer-name-show-port nil
+ "Show the connection port in the nrepl REPL buffer name, if set to t."
+ :type 'boolean
+ :group 'nrepl)
+
+(defcustom nrepl-connected-hook nil
+ "List of functions to call when connecting to the nREPL server."
+ :type 'hook
+ :group 'nrepl)
+
+(defcustom nrepl-disconnected-hook nil
+ "List of functions to call when disconnected from the nREPL server."
+ :type 'hook
+ :group 'nrepl)
+
+(defcustom nrepl-file-loaded-hook nil
+ "List of functions to call when a load file has completed."
+ :type 'hook
+ :group 'nrepl)
+
+(defcustom nrepl-force-ssh-for-remote-hosts nil
+ "If non-nil, do not attempt a direct connection for remote hosts."
+ :type 'boolean
+ :group 'nrepl)
+
+(defcustom nrepl-use-ssh-fallback-for-remote-hosts nil
+ "If non-nil, attempt to connect via ssh to remote hosts when unable to connect directly."
+ :type 'boolean
+ :group 'nrepl)
+
+(defcustom nrepl-sync-request-timeout 10
+ "The number of seconds to wait for a sync response.
+Setting this to nil disables the timeout functionality."
+ :type 'integer
+ :group 'nrepl)
+
+(defcustom nrepl-hide-special-buffers nil
+ "Control the display of some special buffers in buffer switching commands.
+When true some special buffers like the server buffer will be hidden."
+ :type 'boolean
+ :group 'nrepl)
+
+(defcustom nrepl-prompt-to-kill-server-buffer-on-quit t
+ "If non-nil, prompt the user for confirmation before killing the nrepl server buffer and associated process."
+ :type 'boolean
+ :group 'nrepl)
+
+(defvar nrepl-create-client-buffer-function 'nrepl-create-client-buffer-default
+ "Name of a function that returns a client process buffer.
+It is called with one argument, a plist containing :host, :port and :proc
+as returned by `nrepl-connect'.")
+
+(defvar nrepl-use-this-as-repl-buffer 'new
+ "Name of the buffer to use as REPL buffer.
+In case of a special value 'new, a new buffer is created.")
+
+\f
+;;; Buffer Local Declarations
+
+;; These variables are used to track the state of nREPL connections
+(defvar-local nrepl-client-buffers nil
+ "List of buffers connected to this server.")
+(defvar-local nrepl-connection-buffer nil)
+(defvar-local nrepl-server-buffer nil)
+(defvar-local nrepl-endpoint nil)
+(defvar-local nrepl-project-dir nil)
+(defvar-local nrepl-tunnel-buffer nil)
+
+(defvar-local nrepl-session nil
+ "Current nREPL session id.")
+
+(defvar-local nrepl-tooling-session nil
+ "Current nREPL tooling session id.
+To be used for tooling calls (i.e. completion, eldoc, etc)")
+
+(defvar-local nrepl-request-counter 0
+ "Continuation serial number counter.")
+
+(defvar-local nrepl-pending-requests nil)
+
+(defvar-local nrepl-completed-requests nil)
+
+(defvar-local nrepl-last-sync-response nil
+ "Result of the last sync request.")
+
+(defvar-local nrepl-last-sync-request-timestamp nil
+ "The time when the last sync request was initiated.")
+
+(defvar-local nrepl-ops nil
+ "Available nREPL server ops (from describe).")
+
+(defvar-local nrepl-versions nil
+ "Version information received from the describe op.")
+
+(defvar-local nrepl-aux nil
+ "Auxillary information received from the describe op.")
+
+\f
+;;; nREPL Buffer Names
+
+(defconst nrepl-message-buffer-name-template "*nrepl-messages %s*")
+(defconst nrepl-error-buffer-name "*nrepl-error*")
+(defconst nrepl-repl-buffer-name-template "*cider-repl%s*")
+(defconst nrepl-connection-buffer-name-template "*nrepl-connection%s*")
+(defconst nrepl-server-buffer-name-template "*nrepl-server%s*")
+(defconst nrepl-tunnel-buffer-name-template "*nrepl-tunnel%s*")
+
+(defun nrepl-format-buffer-name-template (buffer-name-template designation)
+ "Apply the DESIGNATION to the corresponding BUFFER-NAME-TEMPLATE."
+ (format buffer-name-template
+ (if (> (length designation) 0)
+ (concat nrepl-buffer-name-separator designation)
+ "")))
+
+(defun nrepl-make-buffer-name (buffer-name-template &optional project-dir host port dup-ok)
+ "Generate a buffer name using BUFFER-NAME-TEMPLATE.
+
+If not supplied PROJECT-DIR, HOST and PORT default to the buffer local
+value of the `nrepl-project-dir' and `nrepl-endpoint'.
+
+The name will include the project name if available or the endpoint host if
+it is not. The name will also include the connection port if
+`nrepl-buffer-name-show-port' is true.
+
+If optional DUP-OK is non-nil, the returned buffer is not \"uniquified\" by
+`generate-new-buffer-name'."
+ (let* ((project-dir (or project-dir nrepl-project-dir))
+ (project-name (when project-dir (file-name-nondirectory (directory-file-name project-dir))))
+ (nrepl-proj-port (or port (cadr nrepl-endpoint)))
+ (name (nrepl-format-buffer-name-template
+ buffer-name-template
+ (concat (if project-name project-name (or host (car nrepl-endpoint)))
+ (if (and nrepl-proj-port nrepl-buffer-name-show-port)
+ (format ":%s" nrepl-proj-port) "")))))
+ (if dup-ok
+ name
+ (generate-new-buffer-name name))))
+
+(defun nrepl--make-hidden-name (buffer-name)
+ "Apply a prefix to BUFFER-NAME that will hide the buffer."
+ (concat (if nrepl-hide-special-buffers " " "") buffer-name))
+
+(defun nrepl-connection-buffer-name (&optional project-dir host port)
+ "Return the name of the connection buffer.
+PROJECT-DIR, HOST and PORT are as in `/nrepl-make-buffer-name'."
+ (nrepl--make-hidden-name
+ (nrepl-make-buffer-name nrepl-connection-buffer-name-template
+ project-dir host port)))
+
+(defun nrepl-connection-identifier (conn)
+ "Return the string which identifies a connection CONN."
+ (thread-last (buffer-name conn)
+ (replace-regexp-in-string "\\`*cider-repl " "")
+ (replace-regexp-in-string "*\\'" "" )))
+
+(defun nrepl-server-buffer-name (&optional project-dir host port)
+ "Return the name of the server buffer.
+PROJECT-DIR, HOST and PORT are as in `nrepl-make-buffer-name'."
+ (nrepl--make-hidden-name
+ (nrepl-make-buffer-name nrepl-server-buffer-name-template
+ project-dir host port)))
+
+(defun nrepl-tunnel-buffer-name (&optional project-dir host port)
+ "Return the name of the tunnel buffer.
+PROJECT-DIR, HOST and PORT are as in `nrepl-make-buffer-name'."
+ (nrepl--make-hidden-name
+ (nrepl-make-buffer-name nrepl-tunnel-buffer-name-template
+ project-dir host port)))
+
+\f
+;;; Utilities
+(defun nrepl-op-supported-p (op connection)
+ "Return t iff the given operation OP is supported by the nREPL CONNECTION."
+ (with-current-buffer connection
+ (and nrepl-ops (nrepl-dict-get nrepl-ops op))))
+
+(defun nrepl-aux-info (key connection)
+ "Return KEY's aux info, as returned via the :describe op for CONNECTION."
+ (with-current-buffer connection
+ (and nrepl-aux (nrepl-dict-get nrepl-aux key))))
+
+(defun nrepl-local-host-p (host)
+ "Return t if HOST is local."
+ (string-match-p tramp-local-host-regexp host))
+
+(defun nrepl-extract-port (dir)
+ "Read port from .nrepl-port, nrepl-port or target/repl-port files in directory DIR."
+ (or (nrepl--port-from-file (expand-file-name "repl-port" dir))
+ (nrepl--port-from-file (expand-file-name ".nrepl-port" dir))
+ (nrepl--port-from-file (expand-file-name "target/repl-port" dir))))
+
+(defun nrepl--port-from-file (file)
+ "Attempts to read port from a file named by FILE."
+ (when (file-exists-p file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (buffer-string))))
+
+\f
+;;; Bencode
+
+(cl-defstruct (nrepl-response-queue
+ (:include queue)
+ (:constructor nil)
+ (:constructor nrepl-response-queue (&optional stub)))
+ stub)
+
+(put 'nrepl-response-queue 'function-documentation
+ "Create queue object used by nREPL to store decoded server responses.
+The STUB slot stores a stack of nested, incompletely parsed objects.")
+
+(defun nrepl--bdecode-list (&optional stack)
+ "Decode a bencode list or dict starting at point.
+STACK is as in `nrepl--bdecode-1'."
+ ;; skip leading l or d
+ (forward-char 1)
+ (let* ((istack (nrepl--bdecode-1 stack))
+ (pos0 (point))
+ (info (car istack)))
+ (while (null info)
+ (setq istack (nrepl--bdecode-1 (cdr istack))
+ pos0 (point)
+ info (car istack)))
+ (cond ((eq info :e)
+ (cons nil (cdr istack)))
+ ((eq info :stub)
+ (goto-char pos0)
+ istack)
+ (t istack))))
+
+(defun nrepl--bdecode-1 (&optional stack)
+ "Decode one elementary bencode object starting at point.
+Bencoded object is either list, dict, integer or string. See
+http://en.wikipedia.org/wiki/Bencode#Encoding_algorithm for the encoding
+rules.
+
+STACK is a list of so far decoded components of the current message. Car
+of STACK is the innermost incompletely decoded object. The algorithm pops
+this list when inner object was completely decoded or grows it by one when
+new list or dict was encountered.
+
+The returned value is of the form (INFO . STACK) where INFO is
+:stub, nil, :end or :eob and STACK is either an incomplete parsing state as
+above (INFO is :stub, nil or :eob) or a list of one component representing
+the completely decoded message (INFO is :end). INFO is nil when an
+elementary non-root object was successfully decoded. INFO is :end when this
+object is a root list or dict."
+ (cond
+ ;; list
+ ((eq (char-after) ?l)
+ (nrepl--bdecode-list (cons () stack)))
+ ;; dict
+ ((eq (char-after) ?d)
+ (nrepl--bdecode-list (cons '(dict) stack)))
+ ;; end of a list or a dict
+ ((eq (char-after) ?e)
+ (forward-char 1)
+ (cons (if (cdr stack) :e :end)
+ (nrepl--push (nrepl--nreverse (car stack))
+ (cdr stack))))
+ ;; string
+ ((looking-at "\\([0-9]+\\):")
+ (let ((pos0 (point))
+ (beg (goto-char (match-end 0)))
+ (end (byte-to-position (+ (position-bytes (point))
+ (string-to-number (match-string 1))))))
+ (if (null end)
+ (progn (goto-char pos0)
+ (cons :stub stack))
+ (goto-char end)
+ ;; normalise any platform-specific newlines
+ (let* ((original (buffer-substring-no-properties beg end))
+ ;; handle both \n\r and \r\n
+ (result (replace-regexp-in-string "\r\n\\|\n\r" "\n" original))
+ ;; we don't handle single carriage returns, insert newline
+ (result (replace-regexp-in-string "\r" "\n" result)))
+ (cons nil (nrepl--push result stack))))))
+ ;; integer
+ ((looking-at "i\\(-?[0-9]+\\)e")
+ (goto-char (match-end 0))
+ (cons nil (nrepl--push (string-to-number (match-string 1))
+ stack)))
+ ;; should happen in tests only as eobp is checked in nrepl-bdecode.
+ ((eobp)
+ (cons :eob stack))
+ ;; truncation in the middle of an integer or in 123: string prefix
+ ((looking-at-p "[0-9i]")
+ (cons :stub stack))
+ ;; else, throw a quiet error
+ (t
+ (message "Invalid bencode message detected. See the %s buffer for details."
+ nrepl-error-buffer-name)
+ (nrepl-log-error
+ (format "Decoder error at position %d (`%s'):"
+ (point) (buffer-substring (point) (min (+ (point) 10) (point-max)))))
+ (nrepl-log-error (buffer-string))
+ (ding)
+ ;; Ensure loop break and clean queues' states in nrepl-bdecode:
+ (goto-char (point-max))
+ (cons :end nil))))
+
+(defun nrepl--bdecode-message (&optional stack)
+ "Decode one full message starting at point.
+STACK is as in `nrepl--bdecode-1'. Return a cons (INFO . STACK)."
+ (let* ((istack (nrepl--bdecode-1 stack))
+ (info (car istack))
+ (stack (cdr istack)))
+ (while (or (null info)
+ (eq info :e))
+ (setq istack (nrepl--bdecode-1 stack)
+ info (car istack)
+ stack (cdr istack)))
+ istack))
+
+(defun nrepl-bdecode (string-q &optional response-q)
+ "Decode STRING-Q and place the results into RESPONSE-Q.
+STRING-Q is either a queue of strings or a string. RESPONSE-Q is a queue of
+server requests (nREPL dicts). STRING-Q and RESPONSE-Q are modified by side
+effects.
+
+Return a cons (STRING-Q . RESPONSE-Q) where STRING-Q is the original queue
+containing the remainder of the input strings which could not be
+decoded. RESPONSE-Q is the original queue with successfully decoded messages
+enqueued and with slot STUB containing a nested stack of an incompletely
+decoded message or nil if the strings were completely decoded."
+ (with-temp-buffer
+ (if (queue-p string-q)
+ (while (queue-head string-q)
+ (insert (queue-dequeue string-q)))
+ (insert string-q)
+ (setq string-q (queue-create)))
+ (goto-char 1)
+ (unless response-q
+ (setq response-q (nrepl-response-queue)))
+ (let ((istack (nrepl--bdecode-message
+ (nrepl-response-queue-stub response-q))))
+ (while (and (eq (car istack) :end)
+ (not (eobp)))
+ (queue-enqueue response-q (cadr istack))
+ (setq istack (nrepl--bdecode-message)))
+ (unless (eobp)
+ (queue-enqueue string-q (buffer-substring (point) (point-max))))
+ (if (not (eq (car istack) :end))
+ (setf (nrepl-response-queue-stub response-q) (cdr istack))
+ (queue-enqueue response-q (cadr istack))
+ (setf (nrepl-response-queue-stub response-q) nil))
+ (cons string-q response-q))))
+
+(defun nrepl-bencode (object)
+ "Encode OBJECT with bencode.
+Integers, lists and nrepl-dicts are treated according to bencode
+specification. Everything else is encoded as string."
+ (cond
+ ((integerp object) (format "i%de" object))
+ ((nrepl-dict-p object) (format "d%se" (mapconcat #'nrepl-bencode (cdr object) "")))
+ ((listp object) (format "l%se" (mapconcat #'nrepl-bencode object "")))
+ (t (format "%s:%s" (string-bytes object) object))))
+
+\f
+;;; Client: Process Filter
+
+(defvar nrepl-response-handler-functions nil
+ "List of functions to call on each nREPL message.
+Each of these functions should be a function with one argument, which will
+be called by `nrepl-client-filter' on every response received. The current
+buffer will be connection (REPL) buffer of the process. These functions
+should take a single argument, a dict representing the message. See
+`nrepl--dispatch-response' for an example.
+
+These functions are called before the message's own callbacks, so that they
+can affect the behaviour of the callbacks. Errors signaled by these
+functions are demoted to messages, so that they don't prevent the
+callbacks from running.")
+
+(defun nrepl-client-filter (proc string)
+ "Decode message(s) from PROC contained in STRING and dispatch them."
+ (let ((string-q (process-get proc :string-q)))
+ (queue-enqueue string-q string)
+ ;; Start decoding only if the last letter is 'e'
+ (when (eq ?e (aref string (1- (length string))))
+ (let ((response-q (process-get proc :response-q)))
+ (nrepl-bdecode string-q response-q)
+ (while (queue-head response-q)
+ (with-current-buffer (process-buffer proc)
+ (let ((response (queue-dequeue response-q)))
+ (with-demoted-errors "Error in one of the `nrepl-response-handler-functions': %s"
+ (run-hook-with-args 'nrepl-response-handler-functions response))
+ (nrepl--dispatch-response response))))))))
+
+(defun nrepl--dispatch-response (response)
+ "Dispatch the RESPONSE to associated callback.
+First we check the callbacks of pending requests. If no callback was found,
+we check the completed requests, since responses could be received even for
+older requests with \"done\" status."
+ (nrepl-dbind-response response (id)
+ (nrepl-log-message response 'response)
+ (let ((callback (or (gethash id nrepl-pending-requests)
+ (gethash id nrepl-completed-requests))))
+ (if callback
+ (funcall callback response)
+ (error "[nREPL] No response handler with id %s found" id)))))
+
+(defun nrepl-client-sentinel (process message)
+ "Handle sentinel events from PROCESS.
+Notify MESSAGE and if the process is closed run `nrepl-disconnected-hook'
+and kill the process buffer."
+ (if (string-match "deleted\\b" message)
+ (message "[nREPL] Connection closed")
+ (message "[nREPL] Connection closed unexpectedly (%s)"
+ (substring message 0 -1)))
+ (when (equal (process-status process) 'closed)
+ (when-let ((client-buffer (process-buffer process)))
+ (nrepl--clear-client-sessions client-buffer)
+ (with-current-buffer client-buffer
+ (run-hooks 'nrepl-disconnected-hook)
+ (when (buffer-live-p nrepl-server-buffer)
+ (with-current-buffer nrepl-server-buffer
+ (setq nrepl-client-buffers (delete client-buffer nrepl-client-buffers)))
+ (nrepl--maybe-kill-server-buffer nrepl-server-buffer))))))
+
+\f
+;;; Network
+
+(defun nrepl-connect (host port)
+ "Connect to the nREPL server identified by HOST and PORT.
+For local hosts use a direct connection. For remote hosts, if
+`nrepl-force-ssh-for-remote-hosts' is nil, attempt a direct connection
+first. If `nrepl-force-ssh-for-remote-hosts' is non-nil or the direct
+connection failed (and `nrepl-use-ssh-fallback-for-remote-hosts' is
+non-nil), try to start a SSH tunneled connection. Return a plist of the
+form (:proc PROC :host \"HOST\" :port PORT) that might contain additional
+key-values depending on the connection type."
+ (let ((localp (if host
+ (nrepl-local-host-p host)
+ (not (file-remote-p default-directory)))))
+ (if localp
+ (nrepl--direct-connect (or host "localhost") port)
+ ;; we're dealing with a remote host
+ (if (and host (not nrepl-force-ssh-for-remote-hosts))
+ (nrepl--direct-connect host port 'no-error)
+ ;; direct connection failed or `nrepl-force-ssh-for-remote-hosts' is non-nil
+ (when (or nrepl-use-ssh-fallback-for-remote-hosts
+ nrepl-force-ssh-for-remote-hosts)
+ (nrepl--ssh-tunnel-connect host port))))))
+
+(defun nrepl--direct-connect (host port &optional no-error)
+ "If HOST and PORT are given, try to `open-network-stream'.
+If NO-ERROR is non-nil, show messages instead of throwing an error."
+ (if (not (and host port))
+ (unless no-error
+ (error "Host (%s) and port (%s) must be provided" host port))
+ (message "[nREPL] Establishing direct connection to %s:%s ..." host port)
+ (condition-case nil
+ (prog1 (list :proc (open-network-stream "nrepl-connection" nil host port)
+ :host host :port port)
+ (message "[nREPL] Direct connection established"))
+ (error (let ((mes "[nREPL] Direct connection failed"))
+ (if no-error (message mes) (error mes))
+ nil)))))
+
+(defun nrepl--ssh-tunnel-connect (host port)
+ "Connect to a remote machine identified by HOST and PORT through SSH tunnel."
+ (message "[nREPL] Establishing SSH tunneled connection ...")
+ (let* ((remote-dir (if host (format "/ssh:%s:" host) default-directory))
+ (ssh (or (executable-find "ssh")
+ (error "[nREPL] Cannot locate 'ssh' executable")))
+ (cmd (nrepl--ssh-tunnel-command ssh remote-dir port))
+ (tunnel-buf (nrepl-tunnel-buffer-name))
+ (tunnel (start-process-shell-command "nrepl-tunnel" tunnel-buf cmd)))
+ (process-put tunnel :waiting-for-port t)
+ (set-process-filter tunnel (nrepl--ssh-tunnel-filter port))
+ (while (and (process-live-p tunnel)
+ (process-get tunnel :waiting-for-port))
+ (accept-process-output nil 0.005))
+ (if (not (process-live-p tunnel))
+ (error "[nREPL] SSH port forwarding failed. Check the '%s' buffer" tunnel-buf)
+ (message "[nREPL] SSH port forwarding established to localhost:%s" port)
+ (let ((endpoint (nrepl--direct-connect "localhost" port)))
+ (thread-first endpoint
+ (plist-put :tunnel tunnel)
+ (plist-put :remote-host host))))))
+
+(defun nrepl--ssh-tunnel-command (ssh dir port)
+ "Command string to open SSH tunnel to the host associated with DIR's PORT."
+ (with-parsed-tramp-file-name dir nil
+ ;; this abuses the -v option for ssh to get output when the port
+ ;; forwarding is set up, which is used to synchronise on, so that
+ ;; the port forwarding is up when we try to connect.
+ (format-spec
+ "%s -v -N -L %p:localhost:%p %u'%h'"
+ `((?s . ,ssh)
+ (?p . ,port)
+ (?h . ,host)
+ (?u . ,(if user (format "-l '%s' " user) ""))))))
+
+(autoload 'comint-watch-for-password-prompt "comint" "(autoload).")
+
+(defun nrepl--ssh-tunnel-filter (port)
+ "Return a process filter that waits for PORT to appear in process output."
+ (let ((port-string (format "LOCALHOST:%s" port)))
+ (lambda (proc string)
+ (when (string-match-p port-string string)
+ (process-put proc :waiting-for-port nil))
+ (when (and (process-live-p proc)
+ (buffer-live-p (process-buffer proc)))
+ (with-current-buffer (process-buffer proc)
+ (let ((moving (= (point) (process-mark proc))))
+ (save-excursion
+ (goto-char (process-mark proc))
+ (insert string)
+ (set-marker (process-mark proc) (point))
+ (comint-watch-for-password-prompt string))
+ (if moving (goto-char (process-mark proc)))))))))
+
+\f
+;;; Client: Process Handling
+
+(defun nrepl--maybe-kill-server-buffer (server-buf)
+ "Kill SERVER-BUF and its process, subject to user confirmation.
+Do nothing if there is a REPL connected to that server."
+ (with-current-buffer server-buf
+ ;; Don't kill the server if there is a REPL connected to it.
+ (when (and (not nrepl-client-buffers)
+ (or (not nrepl-prompt-to-kill-server-buffer-on-quit)
+ (y-or-n-p "Also kill server process and buffer? ")))
+ (let ((proc (get-buffer-process server-buf)))
+ (when (process-live-p proc)
+ (set-process-query-on-exit-flag proc nil)
+ (kill-process proc))
+ (kill-buffer server-buf)))))
+
+;; `nrepl-start-client-process' is called from `nrepl-server-filter'. It
+;; starts the client process described by `nrepl-client-filter' and
+;; `nrepl-client-sentinel'.
+(defun nrepl-start-client-process (&optional host port server-proc)
+ "Create new client process identified by HOST and PORT.
+In remote buffers, HOST and PORT are taken from the current tramp
+connection. SERVER-PROC must be a running nREPL server process within
+Emacs. This function creates connection buffer by a call to
+`nrepl-create-client-buffer-function'. Return newly created client
+process."
+ (let* ((endpoint (nrepl-connect host port))
+ (client-proc (plist-get endpoint :proc))
+ (host (plist-get endpoint :host))
+ (port (plist-get endpoint :port))
+ (client-buf (funcall nrepl-create-client-buffer-function endpoint)))
+
+ (set-process-buffer client-proc client-buf)
+
+ (set-process-filter client-proc 'nrepl-client-filter)
+ (set-process-sentinel client-proc 'nrepl-client-sentinel)
+ (set-process-coding-system client-proc 'utf-8-unix 'utf-8-unix)
+
+ (process-put client-proc :string-q (queue-create))
+ (process-put client-proc :response-q (nrepl-response-queue))
+
+ (with-current-buffer client-buf
+ (when-let ((server-buf (and server-proc (process-buffer server-proc))))
+ (setq nrepl-project-dir (buffer-local-value 'nrepl-project-dir server-buf)
+ nrepl-server-buffer server-buf))
+ (setq nrepl-endpoint `(,host ,port)
+ nrepl-tunnel-buffer (when-let ((tunnel (plist-get endpoint :tunnel)))
+ (process-buffer tunnel))
+ nrepl-pending-requests (make-hash-table :test 'equal)
+ nrepl-completed-requests (make-hash-table :test 'equal)))
+
+ (with-current-buffer client-buf
+ (nrepl--init-client-sessions client-proc)
+ (nrepl--init-capabilities client-buf)
+ (run-hooks 'nrepl-connected-hook))
+
+ client-proc))
+
+(defun nrepl--init-client-sessions (client)
+ "Initialize CLIENT connection nREPL sessions.
+
+We create two client nREPL sessions per connection - a main session and a
+tooling session. The main session is general purpose and is used for pretty
+much every request that needs a session. The tooling session is used only
+for functionality that's implemented in terms of the \"eval\" op, so that
+eval requests for functionality like pretty-printing won't clobber the
+values of *1, *2, etc."
+ (let* ((client-conn (process-buffer client))
+ (response-main (nrepl-sync-request:clone client-conn))
+ (response-tooling (nrepl-sync-request:clone client-conn t))) ; t for tooling
+ (nrepl-dbind-response response-main (new-session err)
+ (if new-session
+ (with-current-buffer client-conn
+ (setq nrepl-session new-session))
+ (error "Could not create new session (%s)" err)))
+ (nrepl-dbind-response response-tooling (new-session err)
+ (if new-session
+ (with-current-buffer client-conn
+ (setq nrepl-tooling-session new-session))
+ (error "Could not create new tooling session (%s)" err)))))
+
+(defun nrepl--init-capabilities (conn-buffer)
+ "Store locally in CONN-BUFFER the capabilities of nREPL server."
+ (let ((description (nrepl-sync-request:describe conn-buffer)))
+ (nrepl-dbind-response description (ops versions aux)
+ (with-current-buffer conn-buffer
+ (setq nrepl-ops ops)
+ (setq nrepl-versions versions)
+ (setq nrepl-aux aux)))))
+
+(defun nrepl--clear-client-sessions (conn-buffer)
+ "Clear information about nREPL sessions in CONN-BUFFER.
+CONN-BUFFER refers to a (presumably) dead connection, which we can eventually reuse."
+ (with-current-buffer conn-buffer
+ (setq nrepl-session nil)
+ (setq nrepl-tooling-session nil)))
+
+\f
+;;; Client: Response Handling
+;; After being decoded, responses (aka, messages from the server) are dispatched
+;; to handlers. Handlers are constructed with `nrepl-make-response-handler'.
+
+(defvar nrepl-err-handler nil
+ "Evaluation error handler.")
+
+(defun nrepl--mark-id-completed (id)
+ "Move ID from `nrepl-pending-requests' to `nrepl-completed-requests'.
+It is safe to call this function multiple times on the same ID."
+ ;; FIXME: This should go away eventually when we get rid of
+ ;; pending-request hash table
+ (when-let ((handler (gethash id nrepl-pending-requests)))
+ (puthash id handler nrepl-completed-requests)
+ (remhash id nrepl-pending-requests)))
+
+(defvar cider-buffer-ns)
+(defvar cider-special-mode-truncate-lines)
+(declare-function cider-need-input "cider-interaction")
+(declare-function cider-set-buffer-ns "cider-mode")
+
+(defun nrepl-make-response-handler (buffer value-handler stdout-handler
+ stderr-handler done-handler
+ &optional eval-error-handler
+ pprint-out-handler)
+ "Make a response handler for connection BUFFER.
+A handler is a function that takes one argument - response received from
+the server process. The response is an alist that contains at least 'id'
+and 'session' keys. Other standard response keys are 'value', 'out', 'err',
+'pprint-out' and 'status'.
+
+The presence of a particular key determines the type of the response. For
+example, if 'value' key is present, the response is of type 'value', if
+'out' key is present the response is 'stdout' etc. Depending on the type,
+the handler dispatches the appropriate value to one of the supplied
+handlers: VALUE-HANDLER, STDOUT-HANDLER, STDERR-HANDLER, DONE-HANDLER,
+EVAL-ERROR-HANDLER, and PPRINT-OUT-HANDLER. If the optional
+EVAL-ERROR-HANDLER is nil, the default `nrepl-err-handler' is used. If any
+of the other supplied handlers are nil nothing happens for the
+corresponding type of response."
+ (lambda (response)
+ (nrepl-dbind-response response (value ns out err status id pprint-out)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (when (and ns (not (derived-mode-p 'clojure-mode)))
+ (cider-set-buffer-ns ns))))
+ (cond (value
+ (when value-handler
+ (funcall value-handler buffer value)))
+ (out
+ (when stdout-handler
+ (funcall stdout-handler buffer out)))
+ (pprint-out
+ (cond (pprint-out-handler (funcall pprint-out-handler buffer pprint-out))
+ (stdout-handler (funcall stdout-handler buffer pprint-out))))
+ (err
+ (when stderr-handler
+ (funcall stderr-handler buffer err)))
+ (status
+ (when (member "interrupted" status)
+ (message "Evaluation interrupted."))
+ (when (member "eval-error" status)
+ (funcall (or eval-error-handler nrepl-err-handler)))
+ (when (member "namespace-not-found" status)
+ (message "Namespace not found."))
+ (when (member "need-input" status)
+ (cider-need-input buffer))
+ (when (member "done" status)
+ (nrepl--mark-id-completed id)
+ (when done-handler
+ (funcall done-handler buffer))))))))
+
+\f
+;;; Client: Request Core API
+
+;; Requests are messages from an nREPL client (like CIDER) to an nREPL server.
+;; Requests can be asynchronous (sent with `nrepl-send-request') or
+;; synchronous (send with `nrepl-send-sync-request'). The request is a pair list
+;; of operation name and operation parameters. The core operations are described
+;; at https://github.com/clojure/tools.nrepl/blob/master/doc/ops.md. CIDER adds
+;; many more operations through nREPL middleware. See
+;; https://github.com/clojure-emacs/cider-nrepl#supplied-nrepl-middleware for
+;; the up-to-date list.
+
+(defun nrepl-next-request-id (connection)
+ "Return the next request id for CONNECTION."
+ (with-current-buffer connection
+ (number-to-string (cl-incf nrepl-request-counter))))
+
+(defun nrepl-send-request (request callback connection &optional tooling)
+ "Send REQUEST and register response handler CALLBACK using CONNECTION.
+REQUEST is a pair list of the form (\"op\" \"operation\" \"par1-name\"
+\"par1\" ... ). See the code of `nrepl-request:clone',
+`nrepl-request:stdin', etc. This expects that the REQUEST does not have a
+session already in it. This code will add it as appropriate to prevent
+connection/session drift.
+Return the ID of the sent message.
+Optional argument TOOLING Set to t if desiring the tooling session rather than the standard session."
+ (with-current-buffer connection
+ (when-let ((session (if tooling nrepl-tooling-session nrepl-session)))
+ (setq request (append request
+ (list "session" session))))
+ (let* ((id (nrepl-next-request-id connection))
+ (request (cons 'dict (lax-plist-put request "id" id)))
+ (message (nrepl-bencode request)))
+ (nrepl-log-message request 'request)
+ (puthash id callback nrepl-pending-requests)
+ (process-send-string nil message)
+ id)))
+
+(defvar nrepl-ongoing-sync-request nil
+ "Dynamically bound to t while a sync request is ongoing.")
+
+(declare-function cider-repl-emit-interactive-stderr "cider-repl")
+(declare-function cider--render-stacktrace-causes "cider-interaction")
+
+(defun nrepl-send-sync-request (request connection &optional abort-on-input tooling)
+ "Send REQUEST to the nREPL server synchronously using CONNECTION.
+Hold till final \"done\" message has arrived and join all response messages
+of the same \"op\" that came along.
+If ABORT-ON-INPUT is non-nil, the function will return nil at the first
+sign of user input, so as not to hang the interface.
+If TOOLING, use the tooling session rather than the standard session."
+ (let* ((time0 (current-time))
+ (response (cons 'dict nil))
+ (nrepl-ongoing-sync-request t)
+ status)
+ (nrepl-send-request request
+ (lambda (resp) (nrepl--merge response resp))
+ connection
+ tooling)
+ (while (and (not (member "done" status))
+ (not (and abort-on-input
+ (input-pending-p))))
+ (setq status (nrepl-dict-get response "status"))
+ ;; If we get a need-input message then the repl probably isn't going
+ ;; anywhere, and we'll just timeout. So we forward it to the user.
+ (if (member "need-input" status)
+ (progn (cider-need-input (current-buffer))
+ ;; If the used took a few seconds to respond, we might
+ ;; unnecessarily timeout, so let's reset the timer.
+ (setq time0 (current-time)))
+ ;; break out in case we don't receive a response for a while
+ (when (and nrepl-sync-request-timeout
+ (> (cadr (time-subtract (current-time) time0))
+ nrepl-sync-request-timeout))
+ (error "Sync nREPL request timed out %s" request)))
+ ;; Clean up the response, otherwise we might repeatedly ask for input.
+ (nrepl-dict-put response "status" (remove "need-input" status))
+ (accept-process-output nil 0.01))
+ ;; If we couldn't finish, return nil.
+ (when (member "done" status)
+ (nrepl-dbind-response response (ex err eval-error pp-stacktrace id)
+ (when (and ex err)
+ (cond (eval-error (funcall nrepl-err-handler))
+ (pp-stacktrace (cider--render-stacktrace-causes
+ pp-stacktrace (remove "done" status))))) ;; send the error type
+ (when id
+ (with-current-buffer connection
+ (nrepl--mark-id-completed id)))
+ response))))
+
+(defun nrepl-request:stdin (input callback connection)
+ "Send a :stdin request with INPUT using CONNECTION.
+Register CALLBACK as the response handler."
+ (nrepl-send-request (list "op" "stdin"
+ "stdin" input)
+ callback
+ connection))
+
+(defun nrepl-request:interrupt (pending-request-id callback connection)
+ "Send an :interrupt request for PENDING-REQUEST-ID.
+The request is dispatched using CONNECTION.
+Register CALLBACK as the response handler."
+ (nrepl-send-request (list "op" "interrupt"
+ "interrupt-id" pending-request-id)
+ callback
+ connection))
+
+(define-minor-mode cider-enlighten-mode nil nil (cider-mode " light")
+ :global t)
+
+(defun nrepl--eval-request (input &optional ns line column)
+ "Prepare :eval request message for INPUT.
+NS provides context for the request.
+If LINE and COLUMN are non-nil and current buffer is a file buffer, \"line\",
+\"column\" and \"file\" are added to the message."
+ (append (and ns (list "ns" ns))
+ (list "op" "eval"
+ "code" input)
+ (when cider-enlighten-mode
+ (list "enlighten" "true"))
+ (let ((file (or (buffer-file-name) (buffer-name))))
+ (when (and line column file)
+ (list "file" file
+ "line" line
+ "column" column)))))
+
+(defun nrepl-request:eval (input callback connection &optional ns line column additional-params tooling)
+ "Send the request INPUT and register the CALLBACK as the response handler.
+The request is dispatched via CONNECTION. If NS is non-nil,
+include it in the request. LINE and COLUMN, if non-nil, define the position
+of INPUT in its buffer. A CONNECTION uniquely determines two connections
+available: the standard interaction one and the tooling session. If the
+tooling is desired, set TOOLING to true.
+ADDITIONAL-PARAMS is a plist to be appended to the request message."
+ (nrepl-send-request (append (nrepl--eval-request input ns line column) additional-params)
+ callback
+ connection
+ tooling))
+
+(defun nrepl-sync-request:clone (connection &optional tooling)
+ "Sent a :clone request to create a new client session.
+The request is dispatched via CONNECTION.
+Optional argument TOOLING Tooling is set to t if wanting the tooling session from CONNECTION."
+ (nrepl-send-sync-request '("op" "clone")
+ connection
+ nil tooling))
+
+(defun nrepl-sync-request:close (connection)
+ "Sent a :close request to close CONNECTION's SESSION."
+ (nrepl-send-sync-request (list "op" "close")
+ connection)
+ (nrepl-send-sync-request (list "op" "close")
+ connection nil t)) ;; close tooling session
+
+(defun nrepl-sync-request:describe (connection)
+ "Perform :describe request for CONNECTION and SESSION."
+ (nrepl-send-sync-request '("op" "describe")
+ connection))
+
+(defun nrepl-sync-request:ls-sessions (connection)
+ "Perform :ls-sessions request for CONNECTION."
+ (nrepl-send-sync-request '("op" "ls-sessions") connection))
+
+(defun nrepl-sync-request:eval (input connection &optional ns)
+ "Send the INPUT to the nREPL server synchronously.
+The request is dispatched via CONNECTION.
+If NS is non-nil, include it in the request."
+ (nrepl-send-sync-request
+ (nrepl--eval-request input ns)
+ connection))
+
+(defun nrepl-sessions (connection)
+ "Get a list of active sessions on the nREPL server using CONNECTION."
+ (nrepl-dict-get (nrepl-sync-request:ls-sessions connection) "sessions"))
+
+\f
+;;; Server
+
+;; The server side process is started by `nrepl-start-server-process' and has a
+;; very simple filter that pipes its output directly into its process buffer
+;; (*nrepl-server*). The main purpose of this process is to start the actual
+;; nrepl communication client (`nrepl-client-filter') when the message "nREPL
+;; server started on port ..." is detected.
+
+(defvar-local nrepl-post-client-callback nil
+ "Function called after the client process is started.
+Used by `nrepl-start-server-process'.")
+
+(defun nrepl-start-server-process (directory cmd &optional callback)
+ "Start nREPL server process in DIRECTORY using shell command CMD.
+Return a newly created process.
+Set `nrepl-server-filter' as the process filter, which starts REPL process
+with its own buffer once the server has started.
+If CALLBACK is non-nil, it should be function of 1 argument. Once the
+client process is started, the function is called with the client buffer."
+ (let* ((default-directory (or directory default-directory))
+ (serv-buf (get-buffer-create (generate-new-buffer-name
+ (nrepl-server-buffer-name directory))))
+ (serv-proc (start-file-process-shell-command
+ "nrepl-server" serv-buf cmd)))
+ (set-process-filter serv-proc 'nrepl-server-filter)
+ (set-process-sentinel serv-proc 'nrepl-server-sentinel)
+ (set-process-coding-system serv-proc 'utf-8-unix 'utf-8-unix)
+ (with-current-buffer serv-buf
+ (setq nrepl-project-dir directory)
+ (setq nrepl-post-client-callback callback)
+ ;; Ensure that `nrepl-start-client-process' sees right things. This
+ ;; causes warnings about making a local within a let-bind. This is safe
+ ;; as long as `serv-buf' is not the buffer where the let-binding was
+ ;; started. http://www.gnu.org/software/emacs/manual/html_node/elisp/Creating-Buffer_002dLocal.html
+ (setq-local nrepl-create-client-buffer-function
+ nrepl-create-client-buffer-function)
+ (setq-local nrepl-use-this-as-repl-buffer
+ nrepl-use-this-as-repl-buffer))
+ (message "Starting nREPL server via %s..."
+ (propertize cmd 'face 'font-lock-keyword-face))
+ serv-proc))
+
+(defun nrepl-server-filter (process output)
+ "Process nREPL server output from PROCESS contained in OUTPUT."
+ ;; In Windows this can be false:
+ (let ((server-buffer (process-buffer process)))
+ (when (buffer-live-p server-buffer)
+ (with-current-buffer server-buffer
+ ;; auto-scroll on new output
+ (let ((moving (= (point) (process-mark process))))
+ (save-excursion
+ (goto-char (process-mark process))
+ (insert output)
+ (ansi-color-apply-on-region (process-mark process) (point))
+ (set-marker (process-mark process) (point)))
+ (when moving
+ (goto-char (process-mark process))
+ (when-let ((win (get-buffer-window)))
+ (set-window-point win (point))))))
+ ;; detect the port the server is listening on from its output
+ (when (string-match "nREPL server started on port \\([0-9]+\\)" output)
+ (let ((port (string-to-number (match-string 1 output))))
+ (message "nREPL server started on %s" port)
+ (with-current-buffer server-buffer
+ (let* ((client-proc (nrepl-start-client-process nil port process))
+ (client-buffer (process-buffer client-proc)))
+ (setq nrepl-client-buffers
+ (cons client-buffer
+ (delete client-buffer nrepl-client-buffers)))
+
+ (when (functionp nrepl-post-client-callback)
+ (funcall nrepl-post-client-callback client-buffer)))))))))
+
+(declare-function cider--close-connection-buffer "cider-client")
+
+(defun nrepl-server-sentinel (process event)
+ "Handle nREPL server PROCESS EVENT."
+ (let* ((server-buffer (process-buffer process))
+ (clients (buffer-local-value 'nrepl-client-buffers server-buffer))
+ (problem (if (and server-buffer (buffer-live-p server-buffer))
+ (with-current-buffer server-buffer
+ (buffer-substring (point-min) (point-max)))
+ "")))
+ (when server-buffer
+ (kill-buffer server-buffer))
+ (cond
+ ((string-match-p "^killed\\|^interrupt" event)
+ nil)
+ ((string-match-p "^hangup" event)
+ (mapc #'cider--close-connection-buffer clients))
+ ;; On Windows, a failed start sends the "finished" event. On Linux it sends
+ ;; "exited abnormally with code 1".
+ (t (error "Could not start nREPL server: %s" problem)))))
+
+\f
+;;; Messages
+
+(defcustom nrepl-log-messages nil
+ "If non-nil, log protocol messages to an nREPL messages buffer.
+
+This is extremely useful for debug purposes, as it allows you to
+inspect the communication between Emacs and an nREPL server.
+
+Enabling the logging might have a negative impact on performance,
+so it's not recommended to keep it enabled unless you need to
+debug something."
+ :type 'boolean
+ :group 'nrepl)
+
+(defconst nrepl-message-buffer-max-size 1000000
+ "Maximum size for the nREPL message buffer.
+Defaults to 1000000 characters, which should be an insignificant
+memory burden, while providing reasonable history.")
+
+(defconst nrepl-message-buffer-reduce-denominator 4
+ "Divisor by which to reduce message buffer size.
+When the maximum size for the nREPL message buffer is exceeded, the size of
+the buffer is reduced by one over this value. Defaults to 4, so that 1/4
+of the buffer is removed, which should ensure the buffer's maximum is
+reasonably utilized, while limiting the number of buffer shrinking
+operations.")
+
+(defvar nrepl-messages-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "n") #'next-line)
+ (define-key map (kbd "p") #'previous-line)
+ (define-key map (kbd "TAB") #'forward-button)
+ (define-key map (kbd "RET") #'nrepl-log-expand-button)
+ (define-key map (kbd "e") #'nrepl-log-expand-button)
+ (define-key map (kbd "E") #'nrepl-log-expand-all-buttons)
+ (define-key map (kbd "<backtab>") #'backward-button)
+ map))
+
+(define-derived-mode nrepl-messages-mode special-mode "nREPL Messages"
+ "Major mode for displaying nREPL messages.
+
+\\{nrepl-messages-mode-map}"
+ (setq buffer-read-only t)
+ (when cider-special-mode-truncate-lines
+ (setq-local truncate-lines t))
+ (setq-local electric-indent-chars nil)
+ (setq-local comment-start ";")
+ (setq-local comment-end "")
+ (setq-local paragraph-start "(-->\\|(<--")
+ (setq-local paragraph-separate "(<--"))
+
+(defun nrepl-decorate-msg (msg type)
+ "Decorate nREPL MSG according to its TYPE."
+ (pcase type
+ (`request (cons '--> (cdr msg)))
+ (`response (cons '<-- (cdr msg)))))
+
+(defun nrepl-log-message (msg type)
+ "Log the nREPL MSG.
+TYPE is either request or response. The message is logged to a buffer
+described by `nrepl-message-buffer-name-template'."
+ (when nrepl-log-messages
+ (with-current-buffer (nrepl-messages-buffer (current-buffer))
+ (setq buffer-read-only nil)
+ (when (> (buffer-size) nrepl-message-buffer-max-size)
+ (goto-char (/ (buffer-size) nrepl-message-buffer-reduce-denominator))
+ (re-search-forward "^(" nil t)
+ (delete-region (point-min) (- (point) 1)))
+ (goto-char (point-max))
+ (nrepl-log-pp-object (nrepl-decorate-msg msg type)
+ (nrepl-log--message-color (lax-plist-get (cdr msg) "id"))
+ t)
+ (when-let ((win (get-buffer-window)))
+ (set-window-point win (point-max)))
+ (setq buffer-read-only t))))
+
+(defun nrepl-toggle-message-logging ()
+ "Toggle the value of `nrepl-log-messages' between nil and t.
+
+This in effect enables or disables the logging of nREPL messages."
+ (interactive)
+ (setq nrepl-log-messages (not nrepl-log-messages))
+ (if nrepl-log-messages
+ (message "nREPL message logging enabled")
+ (message "nREPL message logging disabled")))
+
+(defcustom nrepl-message-colors
+ '("red" "brown" "coral" "orange" "green" "deep sky blue" "blue" "dark violet")
+ "Colors used in `nrepl-messages-buffer'."
+ :type '(repeat color)
+ :group 'nrepl)
+
+(defun nrepl-log-expand-button (&optional button)
+ "Expand the objects hidden in BUTTON's :nrepl-object property.
+BUTTON defaults the button at point."
+ (interactive)
+ (if-let ((button (or button (button-at (point)))))
+ (let* ((start (overlay-start button))
+ (end (overlay-end button))
+ (obj (overlay-get button :nrepl-object))
+ (inhibit-read-only t))
+ (save-excursion
+ (goto-char start)
+ (delete-overlay button)
+ (delete-region start end)
+ (nrepl-log-pp-object obj)
+ (delete-char -1)))
+ (error "No button at point")))
+
+(defun nrepl-log-expand-all-buttons ()
+ "Expand all buttons in nREPL log buffer."
+ (interactive)
+ (if (not (eq major-mode 'nrepl-messages-mode))
+ (user-error "Not in a `nrepl-messages-mode'")
+ (save-excursion
+ (let* ((pos (point-min))
+ (button (next-button pos)))
+ (while button
+ (setq pos (overlay-start button))
+ (nrepl-log-expand-button button)
+ (setq button (next-button pos)))))))
+
+(defun nrepl-log--expand-button-mouse (event)
+ "Expand the text hidden under overlay button.
+EVENT gives the button position on window."
+ (interactive "e")
+ (pcase (elt event 1)
+ (`(,window ,_ ,_ ,_ ,_ ,point . ,_)
+ (with-selected-window window
+ (nrepl-log-expand-button (button-at point))))))
+
+(defun nrepl-log-insert-button (label object)
+ "Insert button with LABEL and :nrepl-object property as OBJECT."
+ (insert-button label
+ :nrepl-object object
+ 'action #'nrepl-log-expand-button
+ 'face 'link
+ 'help-echo "RET: Expand object."
+ ;; Workaround for bug#1568 (don't use local-map here; it
+ ;; overwrites major mode map.)
+ 'keymap `(keymap (mouse-1 . nrepl-log--expand-button-mouse)))
+ (insert "\n"))
+
+(defun nrepl-log--message-color (id)
+ "Return the color to use when pretty-printing the nREPL message with ID.
+If ID is nil, return nil."
+ (when id
+ (thread-first (string-to-number id)
+ (mod (length nrepl-message-colors))
+ (nth nrepl-message-colors))))
+
+(defun nrepl-log--pp-listlike (object &optional foreground button)
+ "Pretty print nREPL list like OBJECT.
+FOREGROUND and BUTTON are as in `nrepl-log-pp-object'."
+ (cl-flet ((color (str)
+ (propertize str 'face
+ (append '(:weight ultra-bold)
+ (when foreground `(:foreground ,foreground))))))
+ (let ((head (format "(%s" (car object))))
+ (insert (color head))
+ (let ((indent (+ 2 (- (current-column) (length head))))
+ (l (point)))
+ (if (null (cdr object))
+ (insert ")\n")
+ (insert " \n")
+ (cl-loop for l on (cdr object) by #'cddr
+ do (let ((str (format "%s%s " (make-string indent ?\s)
+ (propertize (car l) 'face
+ ;; Only highlight top-level keys.
+ (unless (eq (car object) 'dict)
+ 'font-lock-keyword-face)))))
+ (insert str)
+ (nrepl-log-pp-object (cadr l) nil button)))
+ (when (eq (car object) 'dict)
+ (delete-char -1))
+ (insert (color ")\n")))))))
+
+(defun nrepl-log-pp-object (object &optional foreground button)
+ "Pretty print nREPL OBJECT, delimited using FOREGROUND.
+If BUTTON is non-nil, try making a button from OBJECT instead of inserting
+it into the buffer."
+ (let ((min-dict-fold-size 1)
+ (min-list-fold-size 10)
+ (min-string-fold-size 60))
+ (if-let ((head (car-safe object)))
+ ;; list-like objects
+ (cond
+ ;; top level dicts (always expanded)
+ ((memq head '(<-- -->))
+ (nrepl-log--pp-listlike object foreground button))
+ ;; inner dicts
+ ((eq head 'dict)
+ (if (and button (> (length object) min-dict-fold-size))
+ (nrepl-log-insert-button "(dict ...)" object)
+ (nrepl-log--pp-listlike object foreground button)))
+ ;; lists
+ (t
+ (if (and button (> (length object) min-list-fold-size))
+ (nrepl-log-insert-button (format "(%s ...)" (prin1-to-string head)) object)
+ (pp object (current-buffer)))))
+ ;; non-list objects
+ (if (stringp object)
+ (if (and button (> (length object) min-string-fold-size))
+ (nrepl-log-insert-button (format "\"%s...\"" (substring object 0 min-string-fold-size)) object)
+ (insert (prin1-to-string object) "\n"))
+ (pp object (current-buffer))
+ (insert "\n")))))
+
+(defun nrepl-messages-buffer-name (conn)
+ "Return the name for the message buffer matching CONN."
+ (format nrepl-message-buffer-name-template (nrepl-connection-identifier conn)))
+
+(defun nrepl-messages-buffer (conn)
+ "Return or create the buffer for CONN.
+The default buffer name is *nrepl-messages connection*."
+ (let ((msg-buffer-name (nrepl-messages-buffer-name conn)))
+ (or (get-buffer msg-buffer-name)
+ (let ((buffer (get-buffer-create msg-buffer-name)))
+ (with-current-buffer buffer
+ (buffer-disable-undo)
+ (nrepl-messages-mode)
+ buffer)))))
+
+(defun nrepl-error-buffer ()
+ "Return or create the buffer.
+The default buffer name is *nrepl-error*."
+ (or (get-buffer nrepl-error-buffer-name)
+ (let ((buffer (get-buffer-create nrepl-error-buffer-name)))
+ (with-current-buffer buffer
+ (buffer-disable-undo)
+ (fundamental-mode)
+ buffer))))
+
+(defun nrepl-log-error (msg)
+ "Log the given MSG to the buffer given by `nrepl-error-buffer'."
+ (with-current-buffer (nrepl-error-buffer)
+ (setq buffer-read-only nil)
+ (goto-char (point-max))
+ (insert msg)
+ (when-let ((win (get-buffer-window)))
+ (set-window-point win (point-max)))
+ (setq buffer-read-only t)))
+
+(defun nrepl-create-client-buffer-default (endpoint)
+ "Create an nREPL client process buffer.
+ENDPOINT is a plist returned by `nrepl-connect'."
+ (let ((buffer (generate-new-buffer
+ (nrepl-connection-buffer-name default-directory
+ (plist-get endpoint :host)
+ (plist-get endpoint :port)))))
+ (with-current-buffer buffer
+ (buffer-disable-undo)
+ (setq-local kill-buffer-query-functions nil))
+ buffer))
+
+(provide 'nrepl-client)
+
+;;; nrepl-client.el ends here
--- /dev/null
+;;; nrepl-dict.el --- Dictionary functions for Clojure nREPL -*- lexical-binding: t -*-
+
+;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov
+;; Copyright © 2013-2017 Bozhidar Batsov, Artur Malabarba and CIDER contributors
+;;
+;; Author: Tim King <kingtimNOSPAMgmail.com>
+;; Phil Hagelberg <technomancyNOSPAMgmail.com>
+;; Bozhidar Batsov <bozhidarNOSPAMbatsov.com>
+;; Artur Malabarba <bruce.connor.amNOSPAMgmail.com>
+;; Hugo Duncan <hugoNOSPAMhugoduncan.org>
+;; Steve Purcell <steveNOSPAMsanityinc.com>
+;;
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;
+;; This file is not part of GNU Emacs.
+;;
+;;; Commentary:
+;;
+;; Provides functions to interact with and create `nrepl-dict's. These are
+;; simply plists with an extra element at the head.
+
+;;; Code:
+(require 'cl-lib)
+
+
+(defun nrepl-dict (&rest key-vals)
+ "Create nREPL dict from KEY-VALS."
+ (cons 'dict key-vals))
+
+(defun nrepl-dict-p (object)
+ "Return t if OBJECT is an nREPL dict."
+ (and (listp object)
+ (eq (car object) 'dict)))
+
+(defun nrepl-dict-empty-p (dict)
+ "Return t if nREPL dict DICT is empty."
+ (null (cdr dict)))
+
+(defun nrepl-dict-contains (dict key)
+ "Return nil if nREPL dict DICT doesn't contain KEY.
+If DICT does contain KEY, then a non-nil value is returned. Due to the
+current implementation, this return value is the tail of DICT's key-list
+whose car is KEY. Comparison is done with `equal'."
+ (member key (nrepl-dict-keys dict)))
+
+(defun nrepl-dict-get (dict key &optional default)
+ "Get from DICT value associated with KEY, optional DEFAULT if KEY not in DICT.
+If dict is nil, return nil. If DEFAULT not provided, and KEY not in DICT,
+return nil. If DICT is not an nREPL dict object, an error is thrown."
+ (when dict
+ (if (nrepl-dict-p dict)
+ (if (nrepl-dict-contains dict key)
+ (lax-plist-get (cdr dict) key)
+ default)
+ (error "Not an nREPL dict object: %s" dict))))
+
+(defun nrepl-dict-put (dict key value)
+ "Associate in DICT, KEY to VALUE.
+Return new dict. Dict is modified by side effects."
+ (if (null dict)
+ (list 'dict key value)
+ (if (not (nrepl-dict-p dict))
+ (error "Not an nREPL dict object: %s" dict)
+ (setcdr dict (lax-plist-put (cdr dict) key value))
+ dict)))
+
+(defun nrepl-dict-keys (dict)
+ "Return all the keys in the nREPL DICT."
+ (if (nrepl-dict-p dict)
+ (cl-loop for l on (cdr dict) by #'cddr
+ collect (car l))
+ (error "Not an nREPL dict")))
+
+(defun nrepl-dict-vals (dict)
+ "Return all the values in the nREPL DICT."
+ (if (nrepl-dict-p dict)
+ (cl-loop for l on (cdr dict) by #'cddr
+ collect (cadr l))
+ (error "Not an nREPL dict")))
+
+(defun nrepl-dict-map (fn dict)
+ "Map FN on nREPL DICT.
+FN must accept two arguments key and value."
+ (if (nrepl-dict-p dict)
+ (cl-loop for l on (cdr dict) by #'cddr
+ collect (funcall fn (car l) (cadr l)))
+ (error "Not an nREPL dict")))
+
+(defun nrepl-dict-merge (dict1 dict2)
+ "Destructively merge DICT2 into DICT1.
+Keys in DICT2 override those in DICT1."
+ (let ((base (or dict1 '(dict))))
+ (nrepl-dict-map (lambda (k v)
+ (nrepl-dict-put base k v))
+ (or dict2 '(dict)))
+ base))
+
+(defun nrepl-dict-get-in (dict keys)
+ "Return the value in a nested DICT.
+KEYS is a list of keys. Return nil if any of the keys is not present or if
+any of the values is nil."
+ (let ((out dict))
+ (while (and keys out)
+ (setq out (nrepl-dict-get out (pop keys))))
+ out))
+
+(defun nrepl-dict-flat-map (function dict)
+ "Map FUNCTION over DICT and flatten the result.
+FUNCTION follows the same restrictions as in `nrepl-dict-map', and it must
+also alway return a sequence (since the result will be flattened)."
+ (when dict
+ (apply #'append (nrepl-dict-map function dict))))
+
+\f
+;;; More specific functions
+(defun nrepl--cons (car list-or-dict)
+ "Generic cons of CAR to LIST-OR-DICT."
+ (if (eq (car list-or-dict) 'dict)
+ (cons 'dict (cons car (cdr list-or-dict)))
+ (cons car list-or-dict)))
+
+(defun nrepl--nreverse (list-or-dict)
+ "Generic `nreverse' which works on LIST-OR-DICT."
+ (if (eq (car list-or-dict) 'dict)
+ (cons 'dict (nreverse (cdr list-or-dict)))
+ (nreverse list-or-dict)))
+
+(defun nrepl--push (obj stack)
+ "Cons OBJ to the top element of the STACK."
+ ;; stack is assumed to be a list
+ (if (eq (caar stack) 'dict)
+ (cons (cons 'dict (cons obj (cdar stack)))
+ (cdr stack))
+ (cons (if (null stack)
+ obj
+ (cons obj (car stack)))
+ (cdr stack))))
+
+(defun nrepl--merge (dict1 dict2 &optional no-join)
+ "Join nREPL dicts DICT1 and DICT2 in a meaningful way.
+String values for non \"id\" and \"session\" keys are concatenated. Lists
+are appended. nREPL dicts merged recursively. All other objects are
+accumulated into a list. DICT1 is modified destructively and
+then returned.
+If NO-JOIN is given, return the first non nil dict."
+ (if no-join
+ (or dict1 dict2)
+ (cond ((null dict1) dict2)
+ ((null dict2) dict1)
+ ((stringp dict1) (concat dict1 dict2))
+ ((nrepl-dict-p dict1)
+ (nrepl-dict-map
+ (lambda (k2 v2)
+ (nrepl-dict-put dict1 k2
+ (nrepl--merge (nrepl-dict-get dict1 k2) v2
+ (member k2 '("id" "session")))))
+ dict2)
+ dict1)
+ ((and (listp dict2) (listp dict1)) (append dict1 dict2))
+ ((listp dict1) (append dict1 (list dict2)))
+ (t (list dict1 dict2)))))
+
+\f
+;;; Dbind
+(defmacro nrepl-dbind-response (response keys &rest body)
+ "Destructure an nREPL RESPONSE dict.
+Bind the value of the provided KEYS and execute BODY."
+ (declare (debug (form (&rest symbolp) body)))
+ `(let ,(cl-loop for key in keys
+ collect `(,key (nrepl-dict-get ,response ,(format "%s" key))))
+ ,@body))
+(put 'nrepl-dbind-response 'lisp-indent-function 2)
+
+(provide 'nrepl-dict)
+
+;;; nrepl-dict.el ends here
--- /dev/null
+;;; circe-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (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))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; circe-autoloads.el ends here
--- /dev/null
+;;; circe-chanop.el --- Provide common channel operator commands
+
+;; Copyright (C) 2006, 2015 Jorgen Schaefer
+
+;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
+
+;; 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
--- /dev/null
+;;; circe-color-nicks.el --- Color nicks in the channel
+
+;; Copyright (C) 2012 Taylan Ulrich Bayırlı/Kammer
+
+;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirliNOSPAMgmail.com>
+
+;; 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
--- /dev/null
+;;; circe-compat.el --- Compatibility definitions
+
+;; Copyright (C) 2015 Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
+
+;; Author: Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License
+;; as published by the Free Software Foundation; either version 3
+;; of the License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; 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
--- /dev/null
+;;; circe-highlight-all-nicks.el --- Highlight all nicks in the current channel
+
+;; Copyright (C) 2005 Jorgen Schaefer
+
+;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
+
+;; 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
--- /dev/null
+;;; circe-lagmon.el --- Lag Monitor for Circe
+
+;; Copyright (C) 2011-2012 Jorgen Schaefer
+
+;; Author: John J Foerch <jjfoerchNOSPAMearthlink.net>,
+;; 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
--- /dev/null
+;;; 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 <model87NOSPAMfreemail.hu>
+
+;; 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
--- /dev/null
+(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:
--- /dev/null
+;;; 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 <forcerNOSPAMforcix.cx>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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-<password>\C-b"
+ :nickserv-identify-command "PRIVMSG NickServ :IDENTIFY {nick} {password}"
+ :nickserv-identify-confirmation "^You are now identified for \ 2.*\ 2\\.$"
+ :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 \ 2.*\ 2\\.$"
+ )
+ )
+ "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!uhuserNOSPAMhost212223.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 "\\<server\\>" name)
+ 'circe-server-face)
+ ((string-match "\\<self\\>" 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 \<forcer-\> 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 <who> <what>")))
+ (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 <nick> <channel>"))))
+ (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 <who> <what>")))
+ (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 <nick> [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:
+
+:<server> 317 <ournick> <nick> <idle> :seconds idle
+:<server> 317 <ournick> <nick> <idle> <signon> :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:
+
+:<server> 333 <target> <channel> <nick> 1434996762
+:<server> 333 <target> <channel> <nick>!<user>@<host> 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 <nick> 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 <nick> 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
--- /dev/null
+;;; irc.el --- Library to handle IRC connections -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015 Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
+
+;; Author: Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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):
+
+<nick> ::= <letter> { <letter> | <number> | <special> }
+<special> ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'"
+ (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
--- /dev/null
+;;; 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 <forcerNOSPAMforcix.cx>
+;; 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
--- /dev/null
+;;; lui-autopaste.el --- Extension for lui for long text input
+
+;; Copyright (C) 2012 Jorgen Schaefer <forcerNOSPAMforcix.cx>
+
+;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
+;;; lui-format.el --- A formatting function for use with Lui
+
+;; Copyright (C) 2005, 2012 Jorgen Schaefer
+
+;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
+;;; lui-irc-colors.el --- Add IRC color support to LUI
+
+;; Copyright (C) 2005 Jorgen Schaefer
+
+;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
+
+;; 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 "\ 2")
+ (setq boldp (not boldp)))
+ ((string= code "\16")
+ (setq inversep (not inversep)))
+ ((string= code "\1d")
+ (setq italicp (not italicp)))
+ ((string= code "\1f")
+ (setq underlinep (not underlinep)))
+ ((string= code "\ f")
+ (setq boldp nil
+ inversep nil
+ italicp nil
+ underlinep nil
+ fg nil
+ bg nil))
+ ((string= code "\ 3")
+ (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
--- /dev/null
+;;; lui-logging.el --- Logging support for lui
+
+;; Copyright (C) 2006 Jorgen Schaefer,
+;; 2012 Anthony Martinez
+
+;; Author: Anthony Martinez <pi+circeNOSPAMpihost.us>
+
+;; 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
--- /dev/null
+;;; lui-track-bar.el --- Provides a bar to track the last read position
+
+;; Copyright (C) 2016 Vasilij Schneidermann <v.schneidermannNOSPAMgmail.com>
+
+;; Author: Vasilij Schneidermann <v.schneidermannNOSPAMgmail.com>
+
+;; 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
--- /dev/null
+;;; lui.el --- Linewise User Interface -*- lexical-binding: t -*-
+
+;; Copyright (C) 2005 - 2016 Jorgen Schaefer
+
+;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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)
+
+\f
+;;;;;;;;;;;;;;;;;;;;;
+;;; 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)
+ ("\\<debbugs[#:]\\([0-9]+\\)" 0
+ "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s" 1)
+ ("\\<RFC ?\\([0-9]+\\)" 0
+ "http://www.ietf.org/rfc/rfc%s.txt" 1)
+ ("\\<CVE[- ]\\([0-9]+-[0-9]+\\)" 0
+ "https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-%s" 1)
+ ("\\<SRFI[- ]?\\([0-9]+\\)" 0
+ "http://srfi.schemers.org/srfi-%s/srfi-%s.html" 1 1)
+ ("\\<PEP[- ]?\\([0-9]+\\)" 0 lui-button-pep 1)
+ ("\\<xkcd[ #]*\\([0-9]+\\)" 0
+ "https://xkcd.com/%s" 1)
+ ("\\([0-9a-zA-Z_.-]+/[0-9a-zA-Z_.-]+\\)#\\([0-9]+\\)" 0
+ "https://github.com/%s/issues/%s" 1 2))
+ "The list of buttons to buttonize.
+This consists of lists of four elements each:
+
+ (REGEXP SUBMATCH FUNCTION ARG-MATCH...)
+
+Whenever REGEXP is found, SUBMATCH is marked as a button. When
+that button is activated, FUNCTION is called with the matches
+specified in ARG-MATCHES as its arguments.
+
+If FUNCTION is a string, it is formatted with %s replaced by
+the matches in ARG-MATCHES."
+ :type '(repeat (list (regexp :tag "Regular expression")
+ (integer :tag "Submatch to buttonize")
+ (function :tag "Function to call for this button")
+ (integer :tag "Submatch to pass as an argument")))
+ :group 'lui)
+
+(defcustom lui-button-issue-tracker nil
+ "A tracker URL for the current channel.
+
+This will cause simple #123 links to highlight as issue links to
+the given repository. Use %s to insert the actual number."
+ :type 'string
+ :group 'lui)
+
+(defcustom lui-fill-type " "
+ "How Lui should fill its output.
+This can be one of the following values:
+
+ A string
+ This is used as the fill prefix
+ 'variable
+ The first sequence of non-whitespace characters in the
+ output is used as an alignment, and the rest is filled with
+ spaces.
+ A number
+ The first sequence of non-whitespace characters is
+ right-aligned at this column, and the rest is filled to
+ this column.
+ nil
+ Turn filling off."
+ :type '(choice (string :tag "Fill Prefix")
+ (const :tag "Variable Fill Prefix" variable)
+ (integer :tag "Fill Column")
+ (const :tag "No filling" nil))
+ :group 'lui)
+
+(defcustom lui-fill-column 70
+ "The column at which Lui should break output.
+See `fill-column'."
+ :type 'integer
+ :group 'lui)
+
+(defcustom lui-fill-remove-face-from-newline t
+ "Non-nil when filling should remove faces from newlines.
+Faces on a newline extend to the end of the displayed line, which
+is often not was is wanted."
+ :type 'boolean
+ :group 'lui)
+
+(defcustom lui-time-stamp-format "[%H:%M]"
+ "The format of time stamps.
+See `format-time-string' for a full description of available
+formatting directives."
+ :type 'string
+ :group 'lui)
+
+(defcustom lui-time-stamp-position 'right
+ "Where Lui should put time-stamps.
+This can be one of the following values:
+
+ A number
+ At this column of the first line of output
+ 'right
+ At a column just right to `lui-fill-column'
+ 'left
+ At the left side of the output. The output is thereby moved
+ to the right.
+ 'right-margin
+ In the right margin. You will need to set `right-margin-width'
+ in all circe buffers.
+ 'left-margin
+ In the left margin. You will need to set `left-margin-width'
+ in all circe buffers.
+ nil
+ Do not add any time stamp."
+ :type '(choice (const :tag "Right" right)
+ (integer :tag "Column")
+ (const :tag "Left" left)
+ (const :tag "Right Margin" right-margin)
+ (const :tag "Left Margin" left-margin)
+ (const :tag "None" nil))
+ :group 'lui)
+
+(defcustom lui-time-stamp-only-when-changed-p t
+ "Non-nil if Lui should only add a time stamp when the time changes.
+If `lui-time-stamp-position' is 'left, this will still add the
+necessary whitespace."
+ :type 'boolean
+ :group 'lui)
+
+(defcustom lui-read-only-output-p t
+ "Non-nil if Lui should make the output read-only.
+Switching this off makes copying (by killing) easier for some."
+ :type 'boolean
+ :group 'lui)
+
+(defcustom lui-max-buffer-size 102400
+ "Non-nil if Lui should truncate the buffer if it grows too much.
+If the buffer size (in characters) exceeds this number, it is
+truncated at the top."
+ :type '(choice (const :tag "Never Truncate" nil)
+ (integer :tag "Maximum Buffer Size"))
+ :group 'lui)
+
+(defcustom lui-input-ring-size 32
+ "The size of the input history of Lui.
+This is the size of the input history used by
+\\[lui-previous-input] and \\[lui-next-input]."
+ :type 'integer
+ :group 'lui)
+
+(defcustom lui-mode-hook nil
+ "The hook run when Lui is started."
+ :type 'hook
+ :group 'lui)
+
+(defcustom lui-pre-input-hook nil
+ "A hook run before Lui interprets the user input.
+It is called with the buffer narrowed to the input line.
+Functions can modify the input if they really want to, but the
+user won't see the modifications, so that's a bad idea."
+ :type 'hook
+ :group 'lui)
+
+(defcustom lui-pre-output-hook nil
+ "The hook run before output is formatted."
+ :type 'hook
+ :group 'lui)
+
+(defcustom lui-post-output-hook nil
+ "The hook run after output has been formatted."
+ :type 'hook
+ :group 'lui)
+
+(defface lui-time-stamp-face
+ '((t (:foreground "SlateBlue" :weight bold)))
+ "Lui mode face used for time stamps."
+ :group 'lui)
+
+(defface lui-highlight-face
+ ;; Taken from `font-lock-keyword-face'
+ '((((class grayscale) (background light)) (:foreground "LightGray" :weight bold))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
+ (((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan1"))
+ (t (:weight bold)))
+ "Lui mode face used for highlighting."
+ :group 'lui)
+
+(defface lui-button-face
+ '((((class color) (background light)) (:foreground "Purple" :underline t))
+ (((class color) (background dark)) (:foreground "Cyan" :underline t))
+ (t (:underline t)))
+ "Default face used for LUI buttons."
+ :group 'lui)
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Client interface ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar lui-input-function nil
+ "The function to be called for Lui input.
+This function is called with a single argument, the input
+string.")
+(make-variable-buffer-local 'lui-input-function)
+
+(defvar lui-completion-function 'completion-at-point
+ "A function called to actually do completion.")
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Private variables ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar lui-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "RET") 'lui-send-input)
+ (define-key map (kbd "TAB") 'lui-next-button-or-complete)
+ (define-key map (kbd "<backtab>") 'lui-previous-button)
+ (define-key map (kbd "<S-tab>") '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)
+
+\f
+;;;;;;;;;;;;;;
+;;; 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)))
+
+\f
+;;;;;;;;;;;;;;;;;;
+;;; 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))))))))
+
+\f
+;;;;;;;;;;;;;
+;;; 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))
+
+\f
+;;;;;;;;;;;;;;;
+;;; 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'")))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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)))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;
+;;; 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)))
+
+\f
+;;;;;;;;;;;;;
+;;; 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))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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))))
+
+\f
+;;;;;;;;;;;;;;;;
+;;; 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))
+
+\f
+;;;;;;;;;;;;;;
+;;; 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 "<end>") '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))
+
+
+\f
+;;;;;;;;;;;;;;;;;;;;
+;;; 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)))))))
+
+\f
+;;;;;;;;;;;;;;;
+;;; 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))))
+
+\f
+;;;;;;;;;;;;;;;;;;;
+;;; 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))
+
+\f
+;;;;;;;;;;;;;;;;;;
+;;; 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)))))
+
+\f
+;;;;;;;;;;;;;;;;;
+;;; 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))))
+
+\f
+(provide 'lui)
+;;; lui.el ends here
--- /dev/null
+;;; make-tls-process.el --- A non-blocking TLS connection function
+
+;; Copyright (C) 2015 Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
+
+;; Author: Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
+;;; shorten.el --- component-wise string shortener
+
+;; Copyright (C) 2013 John J Foerch <jjfoerchNOSPAMearthlink.net>
+
+;; Keywords: extensions
+;; Author: John J Foerch <jjfoerchNOSPAMearthlink.net>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
+;;; tracking.el --- Buffer modification tracking
+
+;; Copyright (C) 2006, 2012 - 2015 Jorgen Schaefer
+
+;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
--- /dev/null
+;;; command-log-mode-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
+\f
+;;;### (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)
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; command-log-mode-autoloads.el ends here
--- /dev/null
+;;; -*- 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"))
--- /dev/null
+;;; 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 <michaelwNOSPAMfoldr.org>
+;; 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) "<bytecode>" 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
--- /dev/null
+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.
+++ /dev/null
-;;; dash-autoloads.el --- automatically extracted autoloads
-;;
-;;; Code:
-(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
-\f
-;;;### (autoloads nil nil ("dash.el") (22576 8238 0 0))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; End:
-;;; dash-autoloads.el ends here
+++ /dev/null
-;;; -*- no-byte-compile: t -*-
-(define-package "dash" "20161116.920" "A modern list library for Emacs" 'nil :keywords '("lists"))
+++ /dev/null
-;;; dash.el --- A modern list library for Emacs -*- lexical-binding: t -*-
-
-;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
-
-;; Author: Magnar Sveen <magnarsNOSPAMgmail.com>
-;; Version: 2.13.0
-;; Package-Version: 20161116.920
-;; Keywords: lists
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; A modern list api for Emacs.
-;;
-;; See documentation on https://github.com/magnars/dash.el#functions
-;;
-;; **Please note** The lexical binding in this file is not utilised at the
-;; moment. We will take full advantage of lexical binding in an upcoming 3.0
-;; release of Dash. In the meantime, we've added the pragma to avoid a bug that
-;; you can read more about in https://github.com/magnars/dash.el/issues/130.
-;;
-
-;;; Code:
-
-(defgroup dash ()
- "Customize group for dash.el"
- :group 'lisp
- :prefix "dash-")
-
-(defun dash--enable-fontlock (symbol value)
- (when value
- (dash-enable-font-lock))
- (set-default symbol value))
-
-(defcustom dash-enable-fontlock nil
- "If non-nil, enable fontification of dash functions, macros and
-special values."
- :type 'boolean
- :set 'dash--enable-fontlock
- :group 'dash)
-
-(defmacro !cons (car cdr)
- "Destructive: Set CDR to the cons of CAR and CDR."
- `(setq ,cdr (cons ,car ,cdr)))
-
-(defmacro !cdr (list)
- "Destructive: Set LIST to the cdr of LIST."
- `(setq ,list (cdr ,list)))
-
-(defmacro --each (list &rest body)
- "Anaphoric form of `-each'."
- (declare (debug (form body))
- (indent 1))
- (let ((l (make-symbol "list")))
- `(let ((,l ,list)
- (it-index 0))
- (while ,l
- (let ((it (car ,l)))
- ,@body)
- (setq it-index (1+ it-index))
- (!cdr ,l)))))
-
-(defmacro -doto (eval-initial-value &rest forms)
- "Eval a form, then insert that form as the 2nd argument to other forms.
-The EVAL-INITIAL-VALUE form is evaluated once. Its result is
-passed to FORMS, which are then evaluated sequentially. Returns
-the target form."
- (declare (indent 1))
- (let ((retval (make-symbol "value")))
- `(let ((,retval ,eval-initial-value))
- ,@(mapcar (lambda (form)
- (if (sequencep form)
- `(,(-first-item form) ,retval ,@(cdr form))
- `(funcall form ,retval)))
- forms)
- ,retval)))
-
-(defun -each (list fn)
- "Call FN with every item in LIST. Return nil, used for side-effects only."
- (--each list (funcall fn it)))
-
-(put '-each 'lisp-indent-function 1)
-
-(defalias '--each-indexed '--each)
-
-(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`.
-
-See also: `-map-indexed'."
- (--each list (funcall fn it-index it)))
-(put '-each-indexed 'lisp-indent-function 1)
-
-(defmacro --each-while (list pred &rest body)
- "Anaphoric form of `-each-while'."
- (declare (debug (form form body))
- (indent 2))
- (let ((l (make-symbol "list"))
- (c (make-symbol "continue")))
- `(let ((,l ,list)
- (,c t)
- (it-index 0))
- (while (and ,l ,c)
- (let ((it (car ,l)))
- (if (not ,pred) (setq ,c nil) ,@body))
- (setq it-index (1+ it-index))
- (!cdr ,l)))))
-
-(defun -each-while (list pred fn)
- "Call FN with every item in LIST while (PRED item) is non-nil.
-Return nil, used for side-effects only."
- (--each-while list (funcall pred it) (funcall fn it)))
-
-(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."
- (declare (debug (form body))
- (indent 1))
- (let ((n (make-symbol "num")))
- `(let ((,n ,num)
- (it 0))
- (while (< it ,n)
- ,@body
- (setq it (1+ it))))))
-
-(defun -dotimes (num fn)
- "Repeatedly calls FN (presumably for side-effects) passing in integers from 0 through NUM-1."
- (--dotimes num (funcall fn it)))
-
-(put '-dotimes 'lisp-indent-function 1)
-
-(defun -map (fn list)
- "Return a new list consisting of the result of applying FN to the items in LIST."
- (mapcar fn list))
-
-(defmacro --map (form list)
- "Anaphoric form of `-map'."
- (declare (debug (form form)))
- `(mapcar (lambda (it) ,form) ,list))
-
-(defmacro --reduce-from (form initial-value list)
- "Anaphoric form of `-reduce-from'."
- (declare (debug (form form form)))
- `(let ((acc ,initial-value))
- (--each ,list (setq acc ,form))
- acc))
-
-(defun -reduce-from (fn initial-value list)
- "Return the result of applying FN to INITIAL-VALUE and the
-first item in LIST, then applying FN to that result and the 2nd
-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`.
-
-See also: `-reduce', `-reduce-r'"
- (--reduce-from (funcall fn acc it) initial-value list))
-
-(defmacro --reduce (form list)
- "Anaphoric form of `-reduce'."
- (declare (debug (form form)))
- (let ((lv (make-symbol "list-value")))
- `(let ((,lv ,list))
- (if ,lv
- (--reduce-from ,form (car ,lv) (cdr ,lv))
- (let (acc it) ,form)))))
-
-(defun -reduce (fn list)
- "Return the result of applying FN to the first 2 items in LIST,
-then applying FN to that result and the 3rd item, etc. If LIST
-contains no items, FN must accept no arguments as well, and
-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`.
-
-See also: `-reduce-from', `-reduce-r'"
- (if list
- (-reduce-from fn (car list) (cdr list))
- (funcall fn)))
-
-(defun -reduce-r-from (fn initial-value list)
- "Replace conses with FN, nil with INITIAL-VALUE and evaluate
-the resulting expression. If LIST is empty, INITIAL-VALUE is
-returned and FN is not called.
-
-Note: this function works the same as `-reduce-from' but the
-operation associates from right instead of from left.
-
-See also: `-reduce-r', `-reduce'"
- (if (not list) initial-value
- (funcall fn (car list) (-reduce-r-from fn initial-value (cdr list)))))
-
-(defmacro --reduce-r-from (form initial-value list)
- "Anaphoric version of `-reduce-r-from'."
- (declare (debug (form form form)))
- `(-reduce-r-from (lambda (&optional it acc) ,form) ,initial-value ,list))
-
-(defun -reduce-r (fn list)
- "Replace conses with FN and evaluate the resulting expression.
-The final nil is ignored. If LIST contains no items, FN must
-accept no arguments as well, and reduce return the result of
-calling FN with no arguments. If LIST has only 1 item, it is
-returned and FN is not called.
-
-The first argument of FN is the new item, the second is the
-accumulated value.
-
-Note: this function works the same as `-reduce' but the operation
-associates from right instead of from left.
-
-See also: `-reduce-r-from', `-reduce'"
- (cond
- ((not list) (funcall fn))
- ((not (cdr list)) (car list))
- (t (funcall fn (car list) (-reduce-r fn (cdr list))))))
-
-(defmacro --reduce-r (form list)
- "Anaphoric version of `-reduce-r'."
- (declare (debug (form form)))
- `(-reduce-r (lambda (&optional it acc) ,form) ,list))
-
-(defmacro --filter (form list)
- "Anaphoric form of `-filter'."
- (declare (debug (form form)))
- (let ((r (make-symbol "result")))
- `(let (,r)
- (--each ,list (when ,form (!cons it ,r)))
- (nreverse ,r))))
-
-(defun -filter (pred list)
- "Return a new list of the items in LIST for which PRED returns a non-nil value.
-
-Alias: `-select'
-
-See also: `-keep'"
- (--filter (funcall pred it) list))
-
-(defalias '-select '-filter)
-(defalias '--select '--filter)
-
-(defmacro --remove (form list)
- "Anaphoric form of `-remove'."
- (declare (debug (form form)))
- `(--filter (not ,form) ,list))
-
-(defun -remove (pred list)
- "Return a new list of the items in LIST for which PRED returns nil.
-
-Alias: `-reject'"
- (--remove (funcall pred it) list))
-
-(defalias '-reject '-remove)
-(defalias '--reject '--remove)
-
-(defun -remove-first (pred list)
- "Return a new list with the first item matching PRED removed.
-
-Alias: `-reject-first'
-
-See also: `-remove', `-map-first'"
- (let (front)
- (while (and list (not (funcall pred (car list))))
- (push (car list) front)
- (!cdr list))
- (if list
- (-concat (nreverse front) (cdr list))
- (nreverse front))))
-
-(defmacro --remove-first (form list)
- "Anaphoric form of `-remove-first'."
- (declare (debug (form form)))
- `(-remove-first (lambda (it) ,form) ,list))
-
-(defalias '-reject-first '-remove-first)
-(defalias '--reject-first '--remove-first)
-
-(defun -remove-last (pred list)
- "Return a new list with the last item matching PRED removed.
-
-Alias: `-reject-last'
-
-See also: `-remove', `-map-last'"
- (nreverse (-remove-first pred (reverse list))))
-
-(defmacro --remove-last (form list)
- "Anaphoric form of `-remove-last'."
- (declare (debug (form form)))
- `(-remove-last (lambda (it) ,form) ,list))
-
-(defalias '-reject-last '-remove-last)
-(defalias '--reject-last '--remove-last)
-
-(defun -remove-item (item list)
- "Remove all occurences of ITEM from LIST.
-
-Comparison is done with `equal'."
- (declare (pure t) (side-effect-free t))
- (--remove (equal it item) list))
-
-(defmacro --keep (form list)
- "Anaphoric form of `-keep'."
- (declare (debug (form form)))
- (let ((r (make-symbol "result"))
- (m (make-symbol "mapped")))
- `(let (,r)
- (--each ,list (let ((,m ,form)) (when ,m (!cons ,m ,r))))
- (nreverse ,r))))
-
-(defun -keep (fn list)
- "Return a new list of the non-nil results of applying FN to the items in LIST.
-
-If you want to select the original items satisfying a predicate use `-filter'."
- (--keep (funcall fn it) list))
-
-(defun -non-nil (list)
- "Return all non-nil elements of LIST."
- (declare (pure t) (side-effect-free t))
- (-remove 'null list))
-
-(defmacro --map-indexed (form list)
- "Anaphoric form of `-map-indexed'."
- (declare (debug (form form)))
- (let ((r (make-symbol "result")))
- `(let (,r)
- (--each ,list
- (!cons ,form ,r))
- (nreverse ,r))))
-
-(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`.
-
-See also: `-each-indexed'."
- (--map-indexed (funcall fn it-index it) list))
-
-(defmacro --map-when (pred rep list)
- "Anaphoric form of `-map-when'."
- (declare (debug (form form form)))
- (let ((r (make-symbol "result")))
- `(let (,r)
- (--each ,list (!cons (if ,pred ,rep it) ,r))
- (nreverse ,r))))
-
-(defun -map-when (pred rep list)
- "Return a new list where the elements in LIST that do not match the PRED function
-are unchanged, and where the elements in LIST that do match the PRED function are mapped
-through the REP function.
-
-Alias: `-replace-where'
-
-See also: `-update-at'"
- (--map-when (funcall pred it) (funcall rep it) list))
-
-(defalias '-replace-where '-map-when)
-(defalias '--replace-where '--map-when)
-
-(defun -map-first (pred rep list)
- "Replace first item in LIST satisfying PRED with result of REP called on this item.
-
-See also: `-map-when', `-replace-first'"
- (let (front)
- (while (and list (not (funcall pred (car list))))
- (push (car list) front)
- (!cdr list))
- (if list
- (-concat (nreverse front) (cons (funcall rep (car list)) (cdr list)))
- (nreverse front))))
-
-(defmacro --map-first (pred rep list)
- "Anaphoric form of `-map-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.
-
-See also: `-map-when', `-replace-last'"
- (nreverse (-map-first pred rep (reverse list))))
-
-(defmacro --map-last (pred rep list)
- "Anaphoric form of `-map-last'."
- `(-map-last (lambda (it) ,pred) (lambda (it) (ignore it) ,rep) ,list))
-
-(defun -replace (old new list)
- "Replace all OLD items in LIST with NEW.
-
-Elements are compared using `equal'.
-
-See also: `-replace-at'"
- (declare (pure t) (side-effect-free t))
- (--map-when (equal it old) new list))
-
-(defun -replace-first (old new list)
- "Replace the first occurence of OLD with NEW in LIST.
-
-Elements are compared using `equal'.
-
-See also: `-map-first'"
- (declare (pure t) (side-effect-free t))
- (--map-first (equal old it) new list))
-
-(defun -replace-last (old new list)
- "Replace the last occurence of OLD with NEW in LIST.
-
-Elements are compared using `equal'.
-
-See also: `-map-last'"
- (declare (pure t) (side-effect-free t))
- (--map-last (equal old it) new list))
-
-(defmacro --mapcat (form list)
- "Anaphoric form of `-mapcat'."
- (declare (debug (form form)))
- `(apply 'append (--map ,form ,list)))
-
-(defun -mapcat (fn list)
- "Return the concatenation of the result of mapping FN over LIST.
-Thus function FN should return a list."
- (--mapcat (funcall fn it) list))
-
-(defun -flatten (l)
- "Take a nested list L and return its contents as a single, flat list.
-
-Note that because `nil' represents a list of zero elements (an
-empty list), any mention of nil in L will disappear after
-flattening. If you need to preserve nils, consider `-flatten-n'
-or map them to some unique symbol and then map them back.
-
-Conses of two atoms are considered \"terminals\", that is, they
-aren't flattened further.
-
-See also: `-flatten-n'"
- (declare (pure t) (side-effect-free t))
- (if (and (listp l) (listp (cdr l)))
- (-mapcat '-flatten l)
- (list l)))
-
-(defmacro --iterate (form init n)
- "Anaphoric version of `-iterate'."
- (declare (debug (form form form)))
- `(-iterate (lambda (it) ,form) ,init ,n))
-
-(defun -flatten-n (num list)
- "Flatten NUM levels of a nested LIST.
-
-See also: `-flatten'"
- (declare (pure t) (side-effect-free t))
- (-last-item (--iterate (--mapcat (-list it) it) list (1+ num))))
-
-(defun -concat (&rest lists)
- "Return a new list with the concatenation of the elements in the supplied LISTS."
- (declare (pure t) (side-effect-free t))
- (apply 'append lists))
-
-(defalias '-copy 'copy-sequence
- "Create a shallow copy of LIST.
-
-\(fn LIST)")
-
-(defun -splice (pred fun list)
- "Splice lists generated by FUN in place of elements matching PRED in LIST.
-
-FUN takes the element matching PRED as input.
-
-This function can be used as replacement for `,@' in case you
-need to splice several lists at marked positions (for example
-with keywords).
-
-See also: `-splice-list', `-insert-at'"
- (let (r)
- (--each list
- (if (funcall pred it)
- (let ((new (funcall fun it)))
- (--each new (!cons it r)))
- (!cons it r)))
- (nreverse r)))
-
-(defmacro --splice (pred form list)
- "Anaphoric form of `-splice'."
- `(-splice (lambda (it) ,pred) (lambda (it) ,form) ,list))
-
-(defun -splice-list (pred new-list list)
- "Splice NEW-LIST in place of elements matching PRED in LIST.
-
-See also: `-splice', `-insert-at'"
- (-splice pred (lambda (_) new-list) list))
-
-(defmacro --splice-list (pred new-list list)
- "Anaphoric form of `-splice-list'."
- `(-splice-list (lambda (it) ,pred) ,new-list ,list))
-
-(defun -cons* (&rest args)
- "Make a new list from the elements of ARGS.
-
-The last 2 members of ARGS are used as the final cons of the
-result so if the final member of ARGS is not a list the result is
-a dotted list."
- (declare (pure t) (side-effect-free t))
- (-reduce-r 'cons args))
-
-(defun -snoc (list elem &rest elements)
- "Append ELEM to the end of the list.
-
-This is like `cons', but operates on the end of list.
-
-If ELEMENTS is non nil, append these to the list as well."
- (-concat list (list elem) elements))
-
-(defmacro --first (form list)
- "Anaphoric form of `-first'."
- (declare (debug (form form)))
- (let ((n (make-symbol "needle")))
- `(let (,n)
- (--each-while ,list (not ,n)
- (when ,form (setq ,n it)))
- ,n)))
-
-(defun -first (pred list)
- "Return the first x in LIST where (PRED x) is non-nil, else nil.
-
-To get the first item in the list no questions asked, use `car'.
-
-Alias: `-find'"
- (--first (funcall pred it) list))
-
-(defalias '-find '-first)
-(defalias '--find '--first)
-
-(defmacro --some (form list)
- "Anaphoric form of `-some'."
- (declare (debug (form form)))
- (let ((n (make-symbol "needle")))
- `(let (,n)
- (--each-while ,list (not ,n)
- (setq ,n ,form))
- ,n)))
-
-(defun -some (pred list)
- "Return (PRED x) for the first LIST item where (PRED x) is non-nil, else nil.
-
-Alias: `-any'"
- (--some (funcall pred it) list))
-
-(defalias '-any '-some)
-(defalias '--any '--some)
-
-(defmacro --last (form list)
- "Anaphoric form of `-last'."
- (declare (debug (form form)))
- (let ((n (make-symbol "needle")))
- `(let (,n)
- (--each ,list
- (when ,form (setq ,n it)))
- ,n)))
-
-(defun -last (pred list)
- "Return the last x in LIST where (PRED x) is non-nil, else nil."
- (--last (funcall pred it) list))
-
-(defalias '-first-item 'car
- "Return the first item of LIST, or nil on an empty list.
-
-\(fn LIST)")
-
-(gv-define-simple-setter -first-item setcar)
-
-(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))
-
-(defun -butlast (list)
- "Return a list of all items in list except for the last."
- ;; no alias as we don't want magic optional argument
- (declare (pure t) (side-effect-free t))
- (butlast list))
-
-(defmacro --count (pred list)
- "Anaphoric form of `-count'."
- (declare (debug (form form)))
- (let ((r (make-symbol "result")))
- `(let ((,r 0))
- (--each ,list (when ,pred (setq ,r (1+ ,r))))
- ,r)))
-
-(defun -count (pred list)
- "Counts the number of items in LIST where (PRED item) is non-nil."
- (--count (funcall pred it) list))
-
-(defun ---truthy? (val)
- (declare (pure t) (side-effect-free t))
- (not (null val)))
-
-(defmacro --any? (form list)
- "Anaphoric form of `-any?'."
- (declare (debug (form form)))
- `(---truthy? (--first ,form ,list)))
-
-(defun -any? (pred list)
- "Return t if (PRED x) is non-nil for any x in LIST, else nil.
-
-Alias: `-any-p', `-some?', `-some-p'"
- (--any? (funcall pred it) list))
-
-(defalias '-some? '-any?)
-(defalias '--some? '--any?)
-(defalias '-any-p '-any?)
-(defalias '--any-p '--any?)
-(defalias '-some-p '-any?)
-(defalias '--some-p '--any?)
-
-(defmacro --all? (form list)
- "Anaphoric form of `-all?'."
- (declare (debug (form form)))
- (let ((a (make-symbol "all")))
- `(let ((,a t))
- (--each-while ,list ,a (setq ,a ,form))
- (---truthy? ,a))))
-
-(defun -all? (pred list)
- "Return t if (PRED x) is non-nil for all x in LIST, else nil.
-
-Alias: `-all-p', `-every?', `-every-p'"
- (--all? (funcall pred it) list))
-
-(defalias '-every? '-all?)
-(defalias '--every? '--all?)
-(defalias '-all-p '-all?)
-(defalias '--all-p '--all?)
-(defalias '-every-p '-all?)
-(defalias '--every-p '--all?)
-
-(defmacro --none? (form list)
- "Anaphoric form of `-none?'."
- (declare (debug (form form)))
- `(--all? (not ,form) ,list))
-
-(defun -none? (pred list)
- "Return t if (PRED x) is nil for all x in LIST, else nil.
-
-Alias: `-none-p'"
- (--none? (funcall pred it) list))
-
-(defalias '-none-p '-none?)
-(defalias '--none-p '--none?)
-
-(defmacro --only-some? (form list)
- "Anaphoric form of `-only-some?'."
- (declare (debug (form form)))
- (let ((y (make-symbol "yes"))
- (n (make-symbol "no")))
- `(let (,y ,n)
- (--each-while ,list (not (and ,y ,n))
- (if ,form (setq ,y t) (setq ,n t)))
- (---truthy? (and ,y ,n)))))
-
-(defun -only-some? (pred list)
- "Return `t` if at least one item of LIST matches PRED and at least one item of LIST does not match PRED.
-Return `nil` both if all items match the predicate or if none of the items match the predicate.
-
-Alias: `-only-some-p'"
- (--only-some? (funcall pred it) list))
-
-(defalias '-only-some-p '-only-some?)
-(defalias '--only-some-p '--only-some?)
-
-(defun -slice (list from &optional to step)
- "Return copy of LIST, starting from index FROM to index TO.
-
-FROM or TO may be negative. These values are then interpreted
-modulo the length of the list.
-
-If STEP is a number, only each STEPth item in the resulting
-section is returned. Defaults to 1."
- (declare (pure t) (side-effect-free t))
- (let ((length (length list))
- (new-list nil))
- ;; to defaults to the end of the list
- (setq to (or to length))
- (setq step (or step 1))
- ;; handle negative indices
- (when (< from 0)
- (setq from (mod from length)))
- (when (< to 0)
- (setq to (mod to length)))
-
- ;; iterate through the list, keeping the elements we want
- (--each-while list (< it-index to)
- (when (and (>= it-index from)
- (= (mod (- from it-index) step) 0))
- (push it new-list)))
- (nreverse new-list)))
-
-(defun -take (n list)
- "Return a new list of the first N items in LIST, or all items if there are fewer than N.
-
-See also: `-take-last'"
- (declare (pure t) (side-effect-free t))
- (let (result)
- (--dotimes n
- (when list
- (!cons (car list) result)
- (!cdr list)))
- (nreverse result)))
-
-(defun -take-last (n list)
- "Return the last N items of LIST in order.
-
-See also: `-take'"
- (declare (pure t) (side-effect-free t))
- (copy-sequence (last list n)))
-
-(defalias '-drop 'nthcdr
- "Return the tail of LIST without the first N items.
-
-See also: `-drop-last'
-
-\(fn N LIST)")
-
-(defun -drop-last (n list)
- "Remove the last N items of LIST and return a copy.
-
-See also: `-drop'"
- ;; No alias because we don't want magic optional argument
- (declare (pure t) (side-effect-free t))
- (butlast list n))
-
-(defmacro --take-while (form list)
- "Anaphoric form of `-take-while'."
- (declare (debug (form form)))
- (let ((r (make-symbol "result")))
- `(let (,r)
- (--each-while ,list ,form (!cons it ,r))
- (nreverse ,r))))
-
-(defun -take-while (pred list)
- "Return a new list of successive items from LIST while (PRED item) returns a non-nil value."
- (--take-while (funcall pred it) list))
-
-(defmacro --drop-while (form list)
- "Anaphoric form of `-drop-while'."
- (declare (debug (form form)))
- (let ((l (make-symbol "list")))
- `(let ((,l ,list))
- (while (and ,l (let ((it (car ,l))) ,form))
- (!cdr ,l))
- ,l)))
-
-(defun -drop-while (pred list)
- "Return the tail of LIST starting from the first item for which (PRED item) returns nil."
- (--drop-while (funcall pred it) list))
-
-(defun -split-at (n list)
- "Return a list of ((-take N LIST) (-drop N LIST)), in no more than one pass through the list."
- (declare (pure t) (side-effect-free t))
- (let (result)
- (--dotimes n
- (when list
- (!cons (car list) result)
- (!cdr list)))
- (list (nreverse result) list)))
-
-(defun -rotate (n list)
- "Rotate LIST N places to the right. With N negative, rotate to the left.
-The time complexity is O(n)."
- (declare (pure t) (side-effect-free t))
- (if (> n 0)
- (append (last list n) (butlast list n))
- (append (-drop (- n) list) (-take (- n) list))))
-
-(defun -insert-at (n x list)
- "Return a list with X inserted into LIST at position N.
-
-See also: `-splice', `-splice-list'"
- (declare (pure t) (side-effect-free t))
- (let ((split-list (-split-at n list)))
- (nconc (car split-list) (cons x (cadr split-list)))))
-
-(defun -replace-at (n x list)
- "Return a list with element at Nth position in LIST replaced with X.
-
-See also: `-replace'"
- (declare (pure t) (side-effect-free t))
- (let ((split-list (-split-at n list)))
- (nconc (car split-list) (cons x (cdr (cadr split-list))))))
-
-(defun -update-at (n func list)
- "Return a list with element at Nth position in LIST replaced with `(func (nth n list))`.
-
-See also: `-map-when'"
- (let ((split-list (-split-at n list)))
- (nconc (car split-list) (cons (funcall func (car (cadr split-list))) (cdr (cadr split-list))))))
-
-(defmacro --update-at (n form list)
- "Anaphoric version of `-update-at'."
- (declare (debug (form form form)))
- `(-update-at ,n (lambda (it) ,form) ,list))
-
-(defun -remove-at (n list)
- "Return a list with element at Nth position in LIST removed.
-
-See also: `-remove-at-indices', `-remove'"
- (declare (pure t) (side-effect-free t))
- (-remove-at-indices (list n) list))
-
-(defun -remove-at-indices (indices list)
- "Return a list whose elements are elements from LIST without
-elements selected as `(nth i list)` for all i
-from INDICES.
-
-See also: `-remove-at', `-remove'"
- (declare (pure t) (side-effect-free t))
- (let* ((indices (-sort '< indices))
- (diffs (cons (car indices) (-map '1- (-zip-with '- (cdr indices) indices))))
- r)
- (--each diffs
- (let ((split (-split-at it list)))
- (!cons (car split) r)
- (setq list (cdr (cadr split)))))
- (!cons list r)
- (apply '-concat (nreverse r))))
-
-(defmacro --split-with (pred list)
- "Anaphoric form of `-split-with'."
- (declare (debug (form form)))
- (let ((l (make-symbol "list"))
- (r (make-symbol "result"))
- (c (make-symbol "continue")))
- `(let ((,l ,list)
- (,r nil)
- (,c t))
- (while (and ,l ,c)
- (let ((it (car ,l)))
- (if (not ,pred)
- (setq ,c nil)
- (!cons it ,r)
- (!cdr ,l))))
- (list (nreverse ,r) ,l))))
-
-(defun -split-with (pred list)
- "Return a list of ((-take-while PRED LIST) (-drop-while PRED LIST)), in no more than one pass through the list."
- (--split-with (funcall pred it) list))
-
-(defmacro -split-on (item list)
- "Split the LIST each time ITEM is found.
-
-Unlike `-partition-by', the ITEM is discarded from the results.
-Empty lists are also removed from the result.
-
-Comparison is done by `equal'.
-
-See also `-split-when'"
- (declare (debug (form form)))
- `(-split-when (lambda (it) (equal it ,item)) ,list))
-
-(defmacro --split-when (form list)
- "Anaphoric version of `-split-when'."
- (declare (debug (form form)))
- `(-split-when (lambda (it) ,form) ,list))
-
-(defun -split-when (fn list)
- "Split the LIST on each element where FN returns non-nil.
-
-Unlike `-partition-by', the \"matched\" element is discarded from
-the results. Empty lists are also removed from the result.
-
-This function can be thought of as a generalization of
-`split-string'."
- (let (r s)
- (while list
- (if (not (funcall fn (car list)))
- (push (car list) s)
- (when s (push (nreverse s) r))
- (setq s nil))
- (!cdr list))
- (when s (push (nreverse s) r))
- (nreverse r)))
-
-(defmacro --separate (form list)
- "Anaphoric form of `-separate'."
- (declare (debug (form form)))
- (let ((y (make-symbol "yes"))
- (n (make-symbol "no")))
- `(let (,y ,n)
- (--each ,list (if ,form (!cons it ,y) (!cons it ,n)))
- (list (nreverse ,y) (nreverse ,n)))))
-
-(defun -separate (pred list)
- "Return a list of ((-filter PRED LIST) (-remove PRED LIST)), in one pass through the list."
- (--separate (funcall pred it) list))
-
-(defun ---partition-all-in-steps-reversed (n step list)
- "Private: Used by -partition-all-in-steps and -partition-in-steps."
- (when (< step 1)
- (error "Step must be a positive number, or you're looking at some juicy infinite loops."))
- (let ((result nil))
- (while list
- (!cons (-take n list) result)
- (setq list (-drop step list)))
- result))
-
-(defun -partition-all-in-steps (n step list)
- "Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart.
-The last groups may contain less than N items."
- (declare (pure t) (side-effect-free t))
- (nreverse (---partition-all-in-steps-reversed n step list)))
-
-(defun -partition-in-steps (n step list)
- "Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart.
-If there are not enough items to make the last group N-sized,
-those items are discarded."
- (declare (pure t) (side-effect-free t))
- (let ((result (---partition-all-in-steps-reversed n step list)))
- (while (and result (< (length (car result)) n))
- (!cdr result))
- (nreverse result)))
-
-(defun -partition-all (n list)
- "Return a new list with the items in LIST grouped into N-sized sublists.
-The last group may contain less than N items."
- (declare (pure t) (side-effect-free t))
- (-partition-all-in-steps n n list))
-
-(defun -partition (n list)
- "Return a new list with the items in LIST grouped into N-sized sublists.
-If there are not enough items to make the last group N-sized,
-those items are discarded."
- (declare (pure t) (side-effect-free t))
- (-partition-in-steps n n list))
-
-(defmacro --partition-by (form list)
- "Anaphoric form of `-partition-by'."
- (declare (debug (form form)))
- (let ((r (make-symbol "result"))
- (s (make-symbol "sublist"))
- (v (make-symbol "value"))
- (n (make-symbol "new-value"))
- (l (make-symbol "list")))
- `(let ((,l ,list))
- (when ,l
- (let* ((,r nil)
- (it (car ,l))
- (,s (list it))
- (,v ,form)
- (,l (cdr ,l)))
- (while ,l
- (let* ((it (car ,l))
- (,n ,form))
- (unless (equal ,v ,n)
- (!cons (nreverse ,s) ,r)
- (setq ,s nil)
- (setq ,v ,n))
- (!cons it ,s)
- (!cdr ,l)))
- (!cons (nreverse ,s) ,r)
- (nreverse ,r))))))
-
-(defun -partition-by (fn list)
- "Apply FN to each item in LIST, splitting it each time FN returns a new value."
- (--partition-by (funcall fn it) list))
-
-(defmacro --partition-by-header (form list)
- "Anaphoric form of `-partition-by-header'."
- (declare (debug (form form)))
- (let ((r (make-symbol "result"))
- (s (make-symbol "sublist"))
- (h (make-symbol "header-value"))
- (b (make-symbol "seen-body?"))
- (n (make-symbol "new-value"))
- (l (make-symbol "list")))
- `(let ((,l ,list))
- (when ,l
- (let* ((,r nil)
- (it (car ,l))
- (,s (list it))
- (,h ,form)
- (,b nil)
- (,l (cdr ,l)))
- (while ,l
- (let* ((it (car ,l))
- (,n ,form))
- (if (equal ,h ,n)
- (when ,b
- (!cons (nreverse ,s) ,r)
- (setq ,s nil)
- (setq ,b nil))
- (setq ,b t))
- (!cons it ,s)
- (!cdr ,l)))
- (!cons (nreverse ,s) ,r)
- (nreverse ,r))))))
-
-(defun -partition-by-header (fn list)
- "Apply FN to the first item in LIST. That is the header
-value. Apply FN to each item in LIST, splitting it each time FN
-returns the header value, but only after seeing at least one
-other value (the body)."
- (--partition-by-header (funcall fn it) list))
-
-(defmacro --group-by (form list)
- "Anaphoric form of `-group-by'."
- (declare (debug t))
- (let ((n (make-symbol "n"))
- (k (make-symbol "k"))
- (grp (make-symbol "grp")))
- `(nreverse
- (-map
- (lambda (,n)
- (cons (car ,n)
- (nreverse (cdr ,n))))
- (--reduce-from
- (let* ((,k (,@form))
- (,grp (assoc ,k acc)))
- (if ,grp
- (setcdr ,grp (cons it (cdr ,grp)))
- (push
- (list ,k it)
- acc))
- acc)
- nil ,list)))))
-
-(defun -group-by (fn list)
- "Separate LIST into an alist whose keys are FN applied to the
-elements of LIST. Keys are compared by `equal'."
- (--group-by (funcall fn it) list))
-
-(defun -interpose (sep list)
- "Return a new list of all elements in LIST separated by SEP."
- (declare (pure t) (side-effect-free t))
- (let (result)
- (when list
- (!cons (car list) result)
- (!cdr list))
- (while list
- (setq result (cons (car list) (cons sep result)))
- (!cdr list))
- (nreverse result)))
-
-(defun -interleave (&rest lists)
- "Return a new list of the first item in each list, then the second etc."
- (declare (pure t) (side-effect-free t))
- (let (result)
- (while (-none? 'null lists)
- (--each lists (!cons (car it) result))
- (setq lists (-map 'cdr lists)))
- (nreverse result)))
-
-(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`."
- (declare (debug (form form form)))
- (let ((r (make-symbol "result"))
- (l1 (make-symbol "list1"))
- (l2 (make-symbol "list2")))
- `(let ((,r nil)
- (,l1 ,list1)
- (,l2 ,list2))
- (while (and ,l1 ,l2)
- (let ((it (car ,l1))
- (other (car ,l2)))
- (!cons ,form ,r)
- (!cdr ,l1)
- (!cdr ,l2)))
- (nreverse ,r))))
-
-(defun -zip-with (fn list1 list2)
- "Zip the two lists LIST1 and LIST2 using a function FN. This
-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`."
- (--zip-with (funcall fn it other) list1 list2))
-
-(defun -zip (&rest lists)
- "Zip LISTS together. Group the head of each list, followed by the
-second elements of each list, and so on. The lengths of the returned
-groupings are equal to the length of the shortest input list.
-
-If two lists are provided as arguments, return the groupings as a list
-of cons cells. Otherwise, return the groupings as a list of lists.
-
-Please note! This distinction is being removed in an upcoming 3.0
-release of Dash. If you rely on this behavior, use -zip-pair instead."
- (declare (pure t) (side-effect-free t))
- (let (results)
- (while (-none? 'null lists)
- (setq results (cons (mapcar 'car lists) results))
- (setq lists (mapcar 'cdr lists)))
- (setq results (nreverse results))
- (if (= (length lists) 2)
- ;; to support backward compatability, return
- ;; a cons cell if two lists were provided
- (--map (cons (car it) (cadr it)) results)
- results)))
-
-(defalias '-zip-pair '-zip)
-
-(defun -zip-fill (fill-value &rest lists)
- "Zip LISTS, with FILL-VALUE padded onto the shorter lists. The
-lengths of the returned groupings are equal to the length of the
-longest input list."
- (declare (pure t) (side-effect-free t))
- (apply '-zip (apply '-pad (cons fill-value lists))))
-
-(defun -unzip (lists)
- "Unzip LISTS.
-
-This works just like `-zip' but takes a list of lists instead of
-a variable number of arguments, such that
-
- (-unzip (-zip L1 L2 L3 ...))
-
-is identity (given that the lists are the same length).
-
-See also: `-zip'"
- (apply '-zip lists))
-
-(defun -cycle (list)
- "Return an infinite copy of LIST that will cycle through the
-elements and repeat from the beginning."
- (declare (pure t) (side-effect-free t))
- (let ((newlist (-map 'identity list)))
- (nconc newlist newlist)))
-
-(defun -pad (fill-value &rest lists)
- "Appends FILL-VALUE to the end of each list in LISTS such that they
-will all have the same length."
- (let* ((annotations (-annotate 'length lists))
- (n (-max (-map 'car annotations))))
- (--map (append (cdr it) (-repeat (- n (car it)) fill-value)) annotations)))
-
-(defun -annotate (fn list)
- "Return a list of cons cells where each cell is FN applied to each
-element of LIST paired with the unmodified element of LIST."
- (-zip (-map fn list) list))
-
-(defmacro --annotate (form list)
- "Anaphoric version of `-annotate'."
- (declare (debug (form form)))
- `(-annotate (lambda (it) ,form) ,list))
-
-(defun dash--table-carry (lists restore-lists &optional re)
- "Helper for `-table' and `-table-flat'.
-
-If a list overflows, carry to the right and reset the list."
- (while (not (or (car lists)
- (equal lists '(nil))))
- (setcar lists (car restore-lists))
- (pop (cadr lists))
- (!cdr lists)
- (!cdr restore-lists)
- (when re
- (push (nreverse (car re)) (cadr re))
- (setcar re nil)
- (!cdr re))))
-
-(defun -table (fn &rest lists)
- "Compute outer product of LISTS using function FN.
-
-The function FN should have the same arity as the number of
-supplied lists.
-
-The outer product is computed by applying fn to all possible
-combinations created by taking one element from each list in
-order. The dimension of the result is (length lists).
-
-See also: `-table-flat'"
- (let ((restore-lists (copy-sequence lists))
- (last-list (last lists))
- (re (make-list (length lists) nil)))
- (while (car last-list)
- (let ((item (apply fn (-map 'car lists))))
- (push item (car re))
- (setcar lists (cdar lists)) ;; silence byte compiler
- (dash--table-carry lists restore-lists re)))
- (nreverse (car (last re)))))
-
-(defun -table-flat (fn &rest lists)
- "Compute flat outer product of LISTS using function FN.
-
-The function FN should have the same arity as the number of
-supplied lists.
-
-The outer product is computed by applying fn to all possible
-combinations created by taking one element from each list in
-order. The results are flattened, ignoring the tensor structure
-of the result. This is equivalent to calling:
-
- (-flatten-n (1- (length lists)) (apply '-table fn lists))
-
-but the implementation here is much more efficient.
-
-See also: `-flatten-n', `-table'"
- (let ((restore-lists (copy-sequence lists))
- (last-list (last lists))
- re)
- (while (car last-list)
- (let ((item (apply fn (-map 'car lists))))
- (push item re)
- (setcar lists (cdar lists)) ;; silence byte compiler
- (dash--table-carry lists restore-lists)))
- (nreverse re)))
-
-(defun -partial (fn &rest args)
- "Take a function FN and fewer than the normal arguments to FN,
-and return a fn that takes a variable number of additional ARGS.
-When called, the returned function calls FN with ARGS first and
-then additional args."
- (apply 'apply-partially fn args))
-
-(defun -elem-index (elem list)
- "Return the index of the first element in the given LIST which
-is equal to the query element ELEM, or nil if there is no
-such element."
- (declare (pure t) (side-effect-free t))
- (car (-elem-indices elem list)))
-
-(defun -elem-indices (elem list)
- "Return the indices of all elements in LIST equal to the query
-element ELEM, in ascending order."
- (declare (pure t) (side-effect-free t))
- (-find-indices (-partial 'equal elem) list))
-
-(defun -find-indices (pred list)
- "Return the indices of all elements in LIST satisfying the
-predicate PRED, in ascending order."
- (apply 'append (--map-indexed (when (funcall pred it) (list it-index)) list)))
-
-(defmacro --find-indices (form list)
- "Anaphoric version of `-find-indices'."
- (declare (debug (form form)))
- `(-find-indices (lambda (it) ,form) ,list))
-
-(defun -find-index (pred list)
- "Take a predicate PRED and a LIST and return the index of the
-first element in the list satisfying the predicate, or nil if
-there is no such element.
-
-See also `-first'."
- (car (-find-indices pred list)))
-
-(defmacro --find-index (form list)
- "Anaphoric version of `-find-index'."
- (declare (debug (form form)))
- `(-find-index (lambda (it) ,form) ,list))
-
-(defun -find-last-index (pred list)
- "Take a predicate PRED and a LIST and return the index of the
-last element in the list satisfying the predicate, or nil if
-there is no such element.
-
-See also `-last'."
- (-last-item (-find-indices pred list)))
-
-(defmacro --find-last-index (form list)
- "Anaphoric version of `-find-last-index'."
- `(-find-last-index (lambda (it) ,form) ,list))
-
-(defun -select-by-indices (indices list)
- "Return a list whose elements are elements from LIST selected
-as `(nth i list)` for all i from INDICES."
- (declare (pure t) (side-effect-free t))
- (let (r)
- (--each indices
- (!cons (nth it list) r))
- (nreverse r)))
-
-(defun -select-columns (columns table)
- "Select COLUMNS from TABLE.
-
-TABLE is a list of lists where each element represents one row.
-It is assumed each row has the same length.
-
-Each row is transformed such that only the specified COLUMNS are
-selected.
-
-See also: `-select-column', `-select-by-indices'"
- (declare (pure t) (side-effect-free t))
- (--map (-select-by-indices columns it) table))
-
-(defun -select-column (column table)
- "Select COLUMN from TABLE.
-
-TABLE is a list of lists where each element represents one row.
-It is assumed each row has the same length.
-
-The single selected column is returned as a list.
-
-See also: `-select-columns', `-select-by-indices'"
- (declare (pure t) (side-effect-free t))
- (--mapcat (-select-by-indices (list column) it) table))
-
-(defmacro -> (x &optional form &rest more)
- "Thread the expr through the forms. Insert X as the second item
-in the first form, making a list of it if it is not a list
-already. If there are more forms, insert the first form as the
-second item in second form, etc."
- (declare (debug (form &rest [&or symbolp (sexp &rest form)])))
- (cond
- ((null form) x)
- ((null more) (if (listp form)
- `(,(car form) ,x ,@(cdr form))
- (list form x)))
- (:else `(-> (-> ,x ,form) ,@more))))
-
-(defmacro ->> (x &optional form &rest more)
- "Thread the expr through the forms. Insert X as the last item
-in the first form, making a list of it if it is not a list
-already. If there are more forms, insert the first form as the
-last item in second form, etc."
- (declare (debug ->))
- (cond
- ((null form) x)
- ((null more) (if (listp form)
- `(,@form ,x)
- (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 -some-> (x &optional form &rest more)
- "When expr is non-nil, thread it through the first form (via `->'),
-and when that result is non-nil, through the next form, etc."
- (declare (debug ->))
- (if (null form) x
- (let ((result (make-symbol "result")))
- `(-some-> (-when-let (,result ,x)
- (-> ,result ,form))
- ,@more))))
-
-(defmacro -some->> (x &optional form &rest more)
- "When expr is non-nil, thread it through the first form (via `->>'),
-and when that result is non-nil, through the next form, etc."
- (declare (debug ->))
- (if (null form) x
- (let ((result (make-symbol "result")))
- `(-some->> (-when-let (,result ,x)
- (->> ,result ,form))
- ,@more))))
-
-(defmacro -some--> (x &optional form &rest more)
- "When expr in non-nil, thread it through the first form (via `-->'),
-and when that result is non-nil, through the next form, etc."
- (declare (debug ->))
- (if (null form) x
- (let ((result (make-symbol "result")))
- `(-some--> (-when-let (,result ,x)
- (--> ,result ,form))
- ,@more))))
-
-(defun -grade-up (comparator list)
- "Grade elements of LIST using COMPARATOR relation, yielding a
-permutation vector such that applying this permutation to LIST
-sorts it in ascending order."
- ;; ugly hack to "fix" lack of lexical scope
- (let ((comp `(lambda (it other) (funcall ',comparator (car it) (car other)))))
- (->> (--map-indexed (cons it it-index) list)
- (-sort comp)
- (-map 'cdr))))
-
-(defun -grade-down (comparator list)
- "Grade elements of LIST using COMPARATOR relation, yielding a
-permutation vector such that applying this permutation to LIST
-sorts it in descending order."
- ;; ugly hack to "fix" lack of lexical scope
- (let ((comp `(lambda (it other) (funcall ',comparator (car other) (car it)))))
- (->> (--map-indexed (cons it it-index) list)
- (-sort comp)
- (-map 'cdr))))
-
-(defvar dash--source-counter 0
- "Monotonic counter for generated symbols.")
-
-(defun dash--match-make-source-symbol ()
- "Generate a new dash-source symbol.
-
-All returned symbols are guaranteed to be unique."
- (prog1 (make-symbol (format "--dash-source-%d--" dash--source-counter))
- (setq dash--source-counter (1+ dash--source-counter))))
-
-(defun dash--match-ignore-place-p (symbol)
- "Return non-nil if SYMBOL is a symbol and starts with _."
- (and (symbolp symbol)
- (eq (aref (symbol-name symbol) 0) ?_)))
-
-(defun dash--match-cons-skip-cdr (skip-cdr source)
- "Helper function generating idiomatic shifting code."
- (cond
- ((= skip-cdr 0)
- `(pop ,source))
- (t
- `(prog1 ,(dash--match-cons-get-car skip-cdr source)
- (setq ,source ,(dash--match-cons-get-cdr (1+ skip-cdr) source))))))
-
-(defun dash--match-cons-get-car (skip-cdr source)
- "Helper function generating idiomatic code to get nth car."
- (cond
- ((= skip-cdr 0)
- `(car ,source))
- ((= skip-cdr 1)
- `(cadr ,source))
- (t
- `(nth ,skip-cdr ,source))))
-
-(defun dash--match-cons-get-cdr (skip-cdr source)
- "Helper function generating idiomatic code to get nth cdr."
- (cond
- ((= skip-cdr 0)
- source)
- ((= skip-cdr 1)
- `(cdr ,source))
- (t
- `(nthcdr ,skip-cdr ,source))))
-
-(defun dash--match-cons (match-form source)
- "Setup a cons matching environment and call the real matcher."
- (let ((s (dash--match-make-source-symbol))
- (n 0)
- (m match-form))
- (while (and (consp m)
- (dash--match-ignore-place-p (car m)))
- (setq n (1+ n)) (!cdr m))
- (cond
- ;; when we only have one pattern in the list, we don't have to
- ;; create a temporary binding (--dash-source--) for the source
- ;; and just use the input directly
- ((and (consp m)
- (not (cdr m)))
- (dash--match (car m) (dash--match-cons-get-car n source)))
- ;; handle other special types
- ((> n 0)
- (dash--match m (dash--match-cons-get-cdr n source)))
- ;; this is the only entry-point for dash--match-cons-1, that's
- ;; why we can't simply use the above branch, it would produce
- ;; infinite recursion
- (t
- (cons (list s source) (dash--match-cons-1 match-form s))))))
-
-(defun dash--match-cons-1 (match-form source &optional props)
- "Match MATCH-FORM against SOURCE.
-
-MATCH-FORM is a proper or improper list. Each element of
-MATCH-FORM is either a symbol, which gets bound to the respective
-value in source or another match form which gets destructured
-recursively.
-
-If the cdr of last cons cell in the list is `nil', matching stops
-there.
-
-SOURCE is a proper or improper list."
- (let ((skip-cdr (or (plist-get props :skip-cdr) 0)))
- (cond
- ((consp match-form)
- (cond
- ((cdr match-form)
- (cond
- ((and (symbolp (car match-form))
- (memq (car match-form) '(&keys &plist &alist &hash)))
- (dash--match-kv match-form (dash--match-cons-get-cdr skip-cdr source)))
- ((dash--match-ignore-place-p (car match-form))
- (dash--match-cons-1 (cdr match-form) source
- (plist-put props :skip-cdr (1+ skip-cdr))))
- (t
- (-concat (dash--match (car match-form) (dash--match-cons-skip-cdr skip-cdr source))
- (dash--match-cons-1 (cdr match-form) source)))))
- (t ;; Last matching place, no need for shift
- (dash--match (car match-form) (dash--match-cons-get-car skip-cdr source)))))
- ((eq match-form nil)
- nil)
- (t ;; Handle improper lists. Last matching place, no need for shift
- (dash--match match-form (dash--match-cons-get-cdr skip-cdr source))))))
-
-(defun dash--vector-tail (seq start)
- "Return the tail of SEQ starting at START."
- (cond
- ((vectorp seq)
- (let* ((re-length (- (length seq) start))
- (re (make-vector re-length 0)))
- (--dotimes re-length (aset re it (aref seq (+ it start))))
- re))
- ((stringp seq)
- (substring seq start))))
-
-(defun dash--match-vector (match-form source)
- "Setup a vector matching environment and call the real matcher."
- (let ((s (dash--match-make-source-symbol)))
- (cond
- ;; don't bind `s' if we only have one sub-pattern
- ((= (length match-form) 1)
- (dash--match (aref match-form 0) `(aref ,source 0)))
- ;; if the source is a symbol, we don't need to re-bind it
- ((symbolp source)
- (dash--match-vector-1 match-form source))
- ;; don't bind `s' if we only have one sub-pattern which is not ignored
- ((let* ((ignored-places (mapcar 'dash--match-ignore-place-p match-form))
- (ignored-places-n (length (-remove 'null ignored-places))))
- (when (= ignored-places-n (1- (length match-form)))
- (let ((n (-find-index 'null ignored-places)))
- (dash--match (aref match-form n) `(aref ,source ,n))))))
- (t
- (cons (list s source) (dash--match-vector-1 match-form s))))))
-
-(defun dash--match-vector-1 (match-form source)
- "Match MATCH-FORM against SOURCE.
-
-MATCH-FORM is a vector. Each element of MATCH-FORM is either a
-symbol, which gets bound to the respective value in source or
-another match form which gets destructured recursively.
-
-If second-from-last place in MATCH-FORM is the symbol &rest, the
-next element of the MATCH-FORM is matched against the tail of
-SOURCE, starting at index of the &rest symbol. This is
-conceptually the same as the (head . tail) match for improper
-lists, where dot plays the role of &rest.
-
-SOURCE is a vector.
-
-If the MATCH-FORM vector is shorter than SOURCE vector, only
-the (length MATCH-FORM) places are bound, the rest of the SOURCE
-is discarded."
- (let ((i 0)
- (l (length match-form))
- (re))
- (while (< i l)
- (let ((m (aref match-form i)))
- (push (cond
- ((and (symbolp m)
- (eq m '&rest))
- (prog1 (dash--match
- (aref match-form (1+ i))
- `(dash--vector-tail ,source ,i))
- (setq i l)))
- ((and (symbolp m)
- ;; do not match symbols starting with _
- (not (eq (aref (symbol-name m) 0) ?_)))
- (list (list m `(aref ,source ,i))))
- ((not (symbolp m))
- (dash--match m `(aref ,source ,i))))
- re)
- (setq i (1+ i))))
- (-flatten-n 1 (nreverse re))))
-
-(defun dash--match-kv (match-form source)
- "Setup a kv matching environment and call the real matcher.
-
-kv can be any key-value store, such as plist, alist or hash-table."
- (let ((s (dash--match-make-source-symbol)))
- (cond
- ;; don't bind `s' if we only have one sub-pattern (&type key val)
- ((= (length match-form) 3)
- (dash--match-kv-1 (cdr match-form) source (car match-form)))
- ;; if the source is a symbol, we don't need to re-bind it
- ((symbolp source)
- (dash--match-kv-1 (cdr match-form) source (car match-form)))
- (t
- (cons (list s source) (dash--match-kv-1 (cdr match-form) s (car match-form)))))))
-
-(defun dash--match-kv-1 (match-form source type)
- "Match MATCH-FORM against SOURCE of type TYPE.
-
-MATCH-FORM is a proper list of the form (key1 place1 ... keyN
-placeN). Each placeK is either a symbol, which gets bound to the
-value of keyK retrieved from the key-value store, or another
-match form which gets destructured recursively.
-
-SOURCE is a key-value store of type TYPE, which can be a plist,
-an alist or a hash table.
-
-TYPE is a token specifying the type of the key-value store.
-Valid values are &plist, &alist and &hash."
- (-flatten-n 1 (-map
- (lambda (kv)
- (let* ((k (car kv))
- (v (cadr kv))
- (getter (cond
- ((or (eq type '&plist) (eq type '&keys))
- `(plist-get ,source ,k))
- ((eq type '&alist)
- `(cdr (assoc ,k ,source)))
- ((eq type '&hash)
- `(gethash ,k ,source)))))
- (cond
- ((symbolp v)
- (list (list v getter)))
- (t (dash--match v getter)))))
- (-partition 2 match-form))))
-
-(defun dash--match-symbol (match-form source)
- "Bind a symbol.
-
-This works just like `let', there is no destructuring."
- (list (list match-form source)))
-
-(defun dash--match (match-form source)
- "Match MATCH-FORM against SOURCE.
-
-This function tests the MATCH-FORM and dispatches to specific
-matchers based on the type of the expression.
-
-Key-value stores are disambiguated by placing a token &plist,
-&alist or &hash as a first item in the MATCH-FORM."
- (cond
- ((symbolp match-form)
- (dash--match-symbol match-form source))
- ((consp match-form)
- (cond
- ;; Handle the "x &as" bindings first.
- ((and (consp (cdr match-form))
- (symbolp (car match-form))
- (eq '&as (cadr match-form)))
- (let ((s (car match-form)))
- (cons (list s source)
- (dash--match (cddr match-form) s))))
- ((memq (car match-form) '(&keys &plist &alist &hash))
- (dash--match-kv match-form source))
- (t (dash--match-cons match-form source))))
- ((vectorp match-form)
- ;; We support the &as binding in vectors too
- (cond
- ((and (> (length match-form) 2)
- (symbolp (aref match-form 0))
- (eq '&as (aref match-form 1)))
- (let ((s (aref match-form 0)))
- (cons (list s source)
- (dash--match (dash--vector-tail match-form 2) s))))
- (t (dash--match-vector match-form source))))))
-
-(defmacro -let* (varlist &rest body)
- "Bind variables according to VARLIST then eval BODY.
-
-VARLIST is a list of lists of the form (PATTERN SOURCE). Each
-PATTERN is matched against the SOURCE structurally. SOURCE is
-only evaluated once for each PATTERN.
-
-Each SOURCE can refer to the symbols already bound by this
-VARLIST. This is useful if you want to destructure SOURCE
-recursively but also want to name the intermediate structures.
-
-See `-let' for the list of all possible patterns."
- (declare (debug ((&rest (sexp form)) body))
- (indent 1))
- (let ((bindings (--mapcat (dash--match (car it) (cadr it)) varlist)))
- `(let* ,bindings
- ,@body)))
-
-(defmacro -let (varlist &rest body)
- "Bind variables according to VARLIST then eval BODY.
-
-VARLIST is a list of lists of the form (PATTERN SOURCE). Each
-PATTERN is matched against the SOURCE \"structurally\". SOURCE
-is only evaluated once for each PATTERN. Each PATTERN is matched
-recursively, and can therefore contain sub-patterns which are
-matched against corresponding sub-expressions of SOURCE.
-
-All the SOURCEs are evalled before any symbols are
-bound (i.e. \"in parallel\").
-
-If VARLIST only contains one (PATTERN SOURCE) element, you can
-optionally specify it using a vector and discarding the
-outer-most parens. Thus
-
- (-let ((PATTERN SOURCE)) ..)
-
-becomes
-
- (-let [PATTERN SOURCE] ..).
-
-`-let' uses a convention of not binding places (symbols) starting
-with _ whenever it's possible. You can use this to skip over
-entries you don't care about. However, this is not *always*
-possible (as a result of implementation) and these symbols might
-get bound to undefined values.
-
-Following is the overview of supported patterns. Remember that
-patterns can be matched recursively, so every a, b, aK in the
-following can be a matching construct and not necessarily a
-symbol/variable.
-
-Symbol:
-
- a - bind the SOURCE to A. This is just like regular `let'.
-
-Conses and lists:
-
- (a) - bind `car' of cons/list to A
-
- (a . b) - bind car of cons to A and `cdr' to B
-
- (a b) - bind car of list to A and `cadr' to B
-
- (a1 a2 a3 ...) - bind 0th car of list to A1, 1st to A2, 2nd to A3 ...
-
- (a1 a2 a3 ... aN . rest) - as above, but bind the Nth cdr to REST.
-
-Vectors:
-
- [a] - bind 0th element of a non-list sequence to A (works with
- vectors, strings, bit arrays...)
-
- [a1 a2 a3 ...] - bind 0th element of non-list sequence to A0, 1st to
- A1, 2nd to A2, ...
- If the PATTERN is shorter than SOURCE, the values at
- places not in PATTERN are ignored.
- If the PATTERN is longer than SOURCE, an `error' is
- thrown.
-
- [a1 a2 a3 ... &rest rest] - as above, but bind the rest of
- the sequence to REST. This is
- conceptually the same as improper list
- matching (a1 a2 ... aN . rest)
-
-Key/value stores:
-
- (&plist key0 a0 ... keyN aN) - bind value mapped by keyK in the
- SOURCE plist to aK. If the
- value is not found, aK is nil.
-
- (&alist key0 a0 ... keyN aN) - bind value mapped by keyK in the
- SOURCE alist to aK. If the
- value is not found, aK is nil.
-
- (&hash key0 a0 ... keyN aN) - bind value mapped by keyK in the
- SOURCE hash table to aK. If the
- value is not found, aK is nil.
-
-Further, special keyword &keys supports \"inline\" matching of
-plist-like key-value pairs, similarly to &keys keyword of
-`cl-defun'.
-
- (a1 a2 ... aN &keys key1 b1 ... keyN bK)
-
-This binds N values from the list to a1 ... aN, then interprets
-the cdr as a plist (see key/value matching above).
-
-You can name the source using the syntax SYMBOL &as PATTERN.
-This syntax works with lists (proper or improper), vectors and
-all types of maps.
-
- (list &as a b c) (list 1 2 3)
-
-binds A to 1, B to 2, C to 3 and LIST to (1 2 3).
-
-Similarly:
-
- (bounds &as beg . end) (cons 1 2)
-
-binds BEG to 1, END to 2 and BOUNDS to (1 . 2).
-
- (items &as first . rest) (list 1 2 3)
-
-binds FIRST to 1, REST to (2 3) and ITEMS to (1 2 3)
-
- [vect &as _ b c] [1 2 3]
-
-binds B to 2, C to 3 and VECT to [1 2 3] (_ avoids binding as usual).
-
- (plist &as &plist :b b) (list :a 1 :b 2 :c 3)
-
-binds B to 2 and PLIST to (:a 1 :b 2 :c 3). Same for &alist and &hash.
-
-This is especially useful when we want to capture the result of a
-computation and destructure at the same time. Consider the
-form (function-returning-complex-structure) returning a list of
-two vectors with two items each. We want to capture this entire
-result and pass it to another computation, but at the same time
-we want to get the second item from each vector. We can achieve
-it with pattern
-
- (result &as [_ a] [_ b]) (function-returning-complex-structure)
-
-Note: Clojure programmers may know this feature as the \":as
-binding\". The difference is that we put the &as at the front
-because we need to support improper list binding."
- (declare (debug ([&or (&rest (sexp form))
- (vector [&rest [sexp form]])]
- body))
- (indent 1))
- (if (vectorp varlist)
- `(let* ,(dash--match (aref varlist 0) (aref varlist 1))
- ,@body)
- (let* ((inputs (--map-indexed (list (make-symbol (format "input%d" it-index)) (cadr it)) varlist))
- (new-varlist (--map (list (caar it) (cadr it)) (-zip varlist inputs))))
- `(let ,inputs
- (-let* ,new-varlist ,@body)))))
-
-(defmacro -lambda (match-form &rest body)
- "Return a lambda which destructures its input as MATCH-FORM and executes BODY.
-
-Note that you have to enclose the MATCH-FORM in a pair of parens,
-such that:
-
- (-lambda (x) body)
- (-lambda (x y ...) body)
-
-has the usual semantics of `lambda'. Furthermore, these get
-translated into normal lambda, so there is no performance
-penalty.
-
-See `-let' for the description of destructuring mechanism."
- (declare (doc-string 2) (indent defun)
- (debug (&define sexp
- [&optional stringp]
- [&optional ("interactive" interactive)]
- def-body)))
- (cond
- ((not (consp match-form))
- (signal 'wrong-type-argument "match-form must be a list"))
- ;; no destructuring, so just return regular lambda to make things faster
- ((-all? 'symbolp match-form)
- `(lambda ,match-form ,@body))
- (t
- (let* ((inputs (--map-indexed (list it (make-symbol (format "input%d" it-index))) match-form)))
- ;; TODO: because inputs to the lambda are evaluated only once,
- ;; -let* need not to create the extra bindings to ensure that.
- ;; We should find a way to optimize that. Not critical however.
- `(lambda ,(--map (cadr it) inputs)
- (-let* ,inputs ,@body))))))
-
-(defmacro -if-let* (vars-vals then &rest else)
- "If all VALS evaluate to true, bind them to their corresponding
-VARS and do THEN, otherwise do ELSE. VARS-VALS should be a list
-of (VAR VAL) pairs.
-
-Note: binding is done according to `-let*'. VALS are evaluated
-sequentially, and evaluation stops after the first nil VAL is
-encountered."
- (declare (debug ((&rest (sexp form)) form body))
- (indent 2))
- (->> vars-vals
- (--mapcat (dash--match (car it) (cadr it)))
- (--reduce-r-from
- (let ((var (car it))
- (val (cadr it)))
- `(let ((,var ,val))
- (if ,var ,acc ,@else)))
- then)))
-
-(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.
-
-Note: binding is done according to `-let'."
- (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,
-otherwise do ELSE."
- (declare (debug (form form body))
- (indent 2))
- `(-if-let (it ,val) ,then ,@else))
-
-(defmacro -when-let* (vars-vals &rest body)
- "If all VALS evaluate to true, bind them to their corresponding
-VARS and execute body. VARS-VALS should be a list of (VAR VAL)
-pairs.
-
-Note: binding is done according to `-let*'. VALS are evaluated
-sequentially, and evaluation stops after the first nil VAL is
-encountered."
- (declare (debug ((&rest (sexp form)) body))
- (indent 1))
- `(-if-let* ,vars-vals (progn ,@body)))
-
-(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'."
- (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."
- (declare (debug (form body))
- (indent 1))
- `(--if-let ,val (progn ,@body)))
-
-(defvar -compare-fn nil
- "Tests for equality use this function or `equal' if this is nil.
-It should only be set using dynamic scope with a let, like:
-
- (let ((-compare-fn #'=)) (-union numbers1 numbers2 numbers3)")
-
-(defun -distinct (list)
- "Return a new list with all duplicates removed.
-The test for equality is done with `equal',
-or with `-compare-fn' if that's non-nil.
-
-Alias: `-uniq'"
- (let (result)
- (--each list (unless (-contains? result it) (!cons it result)))
- (nreverse result)))
-
-(defalias '-uniq '-distinct)
-
-(defun -union (list list2)
- "Return a new list containing the elements of LIST and elements of LIST2 that are not in LIST.
-The test for equality is done with `equal',
-or with `-compare-fn' if that's non-nil."
- ;; We fall back to iteration implementation if the comparison
- ;; function isn't one of `eq', `eql' or `equal'.
- (let* ((result (reverse list))
- ;; TODO: get rid of this dynamic variable, pass it as an
- ;; argument instead.
- (-compare-fn (if (bound-and-true-p -compare-fn)
- -compare-fn
- 'equal)))
- (if (memq -compare-fn '(eq eql equal))
- (let ((ht (make-hash-table :test -compare-fn)))
- (--each list (puthash it t ht))
- (--each list2 (unless (gethash it ht) (!cons it result))))
- (--each list2 (unless (-contains? result it) (!cons it result))))
- (nreverse result)))
-
-(defun -intersection (list list2)
- "Return a new list containing only the elements that are members of both LIST and LIST2.
-The test for equality is done with `equal',
-or with `-compare-fn' if that's non-nil."
- (--filter (-contains? list2 it) list))
-
-(defun -difference (list list2)
- "Return a new list with only the members of LIST that are not in LIST2.
-The test for equality is done with `equal',
-or with `-compare-fn' if that's non-nil."
- (--filter (not (-contains? list2 it)) list))
-
-(defun -powerset (list)
- "Return the power set of LIST."
- (if (null list) '(())
- (let ((last (-powerset (cdr list))))
- (append (mapcar (lambda (x) (cons (car list) x)) last)
- last))))
-
-(defun -permutations (list)
- "Return the permutations of LIST."
- (if (null list) '(())
- (apply #'append
- (mapcar (lambda (x)
- (mapcar (lambda (perm) (cons x perm))
- (-permutations (remove x list))))
- list))))
-
-(defun -contains? (list element)
- "Return non-nil if LIST contains ELEMENT.
-
-The test for equality is done with `equal', or with `-compare-fn'
-if that's non-nil.
-
-Alias: `-contains-p'"
- (not
- (null
- (cond
- ((null -compare-fn) (member element list))
- ((eq -compare-fn 'eq) (memq element list))
- ((eq -compare-fn 'eql) (memql element list))
- (t
- (let ((lst list))
- (while (and lst
- (not (funcall -compare-fn element (car lst))))
- (setq lst (cdr lst)))
- lst))))))
-
-(defalias '-contains-p '-contains?)
-
-(defun -same-items? (list list2)
- "Return true if LIST and LIST2 has the same items.
-
-The order of the elements in the lists does not matter.
-
-Alias: `-same-items-p'"
- (let ((length-a (length list))
- (length-b (length list2)))
- (and
- (= length-a length-b)
- (= length-a (length (-intersection list list2))))))
-
-(defalias '-same-items-p '-same-items?)
-
-(defun -is-prefix? (prefix list)
- "Return non-nil if PREFIX is prefix of LIST.
-
-Alias: `-is-prefix-p'"
- (declare (pure t) (side-effect-free t))
- (--each-while list (equal (car prefix) it)
- (!cdr prefix))
- (not prefix))
-
-(defun -is-suffix? (suffix list)
- "Return non-nil if SUFFIX is suffix of LIST.
-
-Alias: `-is-suffix-p'"
- (declare (pure t) (side-effect-free t))
- (-is-prefix? (reverse suffix) (reverse list)))
-
-(defun -is-infix? (infix list)
- "Return non-nil if INFIX is infix of LIST.
-
-This operation runs in O(n^2) time
-
-Alias: `-is-infix-p'"
- (declare (pure t) (side-effect-free t))
- (let (done)
- (while (and (not done) list)
- (setq done (-is-prefix? infix list))
- (!cdr list))
- done))
-
-(defalias '-is-prefix-p '-is-prefix?)
-(defalias '-is-suffix-p '-is-suffix?)
-(defalias '-is-infix-p '-is-infix?)
-
-(defun -sort (comparator list)
- "Sort LIST, stably, comparing elements using COMPARATOR.
-Return the sorted list. LIST is NOT modified by side effects.
-COMPARATOR is called with two elements of LIST, and should return non-nil
-if the first element should sort before the second."
- (sort (copy-sequence list) comparator))
-
-(defmacro --sort (form list)
- "Anaphoric form of `-sort'."
- (declare (debug (form form)))
- `(-sort (lambda (it other) ,form) ,list))
-
-(defun -list (&rest args)
- "Return a list with ARGS.
-
-If first item of ARGS is already a list, simply return ARGS. If
-not, return a list with ARGS as elements."
- (declare (pure t) (side-effect-free t))
- (let ((arg (car args)))
- (if (listp arg) arg args)))
-
-(defun -repeat (n x)
- "Return a list with X repeated N times.
-Return nil if N is less than 1."
- (declare (pure t) (side-effect-free t))
- (let (ret)
- (--dotimes n (!cons x ret))
- ret))
-
-(defun -sum (list)
- "Return the sum of LIST."
- (declare (pure t) (side-effect-free t))
- (apply '+ list))
-
-(defun -product (list)
- "Return the product of LIST."
- (declare (pure t) (side-effect-free t))
- (apply '* list))
-
-(defun -max (list)
- "Return the largest value from LIST of numbers or markers."
- (declare (pure t) (side-effect-free t))
- (apply 'max list))
-
-(defun -min (list)
- "Return the smallest value from LIST of numbers or markers."
- (declare (pure t) (side-effect-free t))
- (apply 'min list))
-
-(defun -max-by (comparator list)
- "Take a comparison function COMPARATOR and a LIST and return
-the greatest element of the list by the comparison function.
-
-See also combinator `-on' which can transform the values before
-comparing them."
- (--reduce (if (funcall comparator it acc) it acc) list))
-
-(defun -min-by (comparator list)
- "Take a comparison function COMPARATOR and a LIST and return
-the least element of the list by the comparison function.
-
-See also combinator `-on' which can transform the values before
-comparing them."
- (--reduce (if (funcall comparator it acc) acc it) list))
-
-(defmacro --max-by (form list)
- "Anaphoric version of `-max-by'.
-
-The items for the comparator form are exposed as \"it\" and \"other\"."
- (declare (debug (form form)))
- `(-max-by (lambda (it other) ,form) ,list))
-
-(defmacro --min-by (form list)
- "Anaphoric version of `-min-by'.
-
-The items for the comparator form are exposed as \"it\" and \"other\"."
- (declare (debug (form form)))
- `(-min-by (lambda (it other) ,form) ,list))
-
-(defun -iterate (fun init n)
- "Return a list of iterated applications of FUN to INIT.
-
-This means a list of form:
-
- (init (fun init) (fun (fun init)) ...)
-
-N is the length of the returned list."
- (if (= n 0) nil
- (let ((r (list init)))
- (--dotimes (1- n)
- (push (funcall fun (car r)) r))
- (nreverse r))))
-
-(defun -fix (fn list)
- "Compute the (least) fixpoint of FN with initial input LIST.
-
-FN is called at least once, results are compared with `equal'."
- (let ((re (funcall fn list)))
- (while (not (equal list re))
- (setq list re)
- (setq re (funcall fn re)))
- re))
-
-(defmacro --fix (form list)
- "Anaphoric form of `-fix'."
- `(-fix (lambda (it) ,form) ,list))
-
-(defun -unfold (fun seed)
- "Build a list from SEED using FUN.
-
-This is \"dual\" operation to `-reduce-r': while -reduce-r
-consumes a list to produce a single value, `-unfold' takes a
-seed value and builds a (potentially infinite!) list.
-
-FUN should return `nil' to stop the generating process, or a
-cons (A . B), where A will be prepended to the result and B is
-the new seed."
- (let ((last (funcall fun seed)) r)
- (while last
- (push (car last) r)
- (setq last (funcall fun (cdr last))))
- (nreverse r)))
-
-(defmacro --unfold (form seed)
- "Anaphoric version of `-unfold'."
- (declare (debug (form form)))
- `(-unfold (lambda (it) ,form) ,seed))
-
-(defun -cons-pair? (con)
- "Return non-nil if CON is true cons pair.
-That is (A . B) where B is not a list."
- (declare (pure t) (side-effect-free t))
- (and (listp con)
- (not (listp (cdr con)))))
-
-(defun -cons-to-list (con)
- "Convert a cons pair to a list with `car' and `cdr' of the pair respectively."
- (declare (pure t) (side-effect-free t))
- (list (car con) (cdr con)))
-
-(defun -value-to-list (val)
- "Convert a value to a list.
-
-If the value is a cons pair, make a list with two elements, `car'
-and `cdr' of the pair respectively.
-
-If the value is anything else, wrap it in a list."
- (declare (pure t) (side-effect-free t))
- (cond
- ((-cons-pair? val) (-cons-to-list val))
- (t (list val))))
-
-(defun -tree-mapreduce-from (fn folder init-value tree)
- "Apply FN to each element of TREE, and make a list of the results.
-If elements of TREE are lists themselves, apply FN recursively to
-elements of these nested lists.
-
-Then reduce the resulting lists using FOLDER and initial value
-INIT-VALUE. See `-reduce-r-from'.
-
-This is the same as calling `-tree-reduce-from' after `-tree-map'
-but is twice as fast as it only traverse the structure once."
- (cond
- ((not tree) nil)
- ((-cons-pair? tree) (funcall fn tree))
- ((listp tree)
- (-reduce-r-from folder init-value (mapcar (lambda (x) (-tree-mapreduce-from fn folder init-value x)) tree)))
- (t (funcall fn tree))))
-
-(defmacro --tree-mapreduce-from (form folder init-value tree)
- "Anaphoric form of `-tree-mapreduce-from'."
- (declare (debug (form form form form)))
- `(-tree-mapreduce-from (lambda (it) ,form) (lambda (it acc) ,folder) ,init-value ,tree))
-
-(defun -tree-mapreduce (fn folder tree)
- "Apply FN to each element of TREE, and make a list of the results.
-If elements of TREE are lists themselves, apply FN recursively to
-elements of these nested lists.
-
-Then reduce the resulting lists using FOLDER and initial value
-INIT-VALUE. See `-reduce-r-from'.
-
-This is the same as calling `-tree-reduce' after `-tree-map'
-but is twice as fast as it only traverse the structure once."
- (cond
- ((not tree) nil)
- ((-cons-pair? tree) (funcall fn tree))
- ((listp tree)
- (-reduce-r folder (mapcar (lambda (x) (-tree-mapreduce fn folder x)) tree)))
- (t (funcall fn tree))))
-
-(defmacro --tree-mapreduce (form folder tree)
- "Anaphoric form of `-tree-mapreduce'."
- (declare (debug (form form form)))
- `(-tree-mapreduce (lambda (it) ,form) (lambda (it acc) ,folder) ,tree))
-
-(defun -tree-map (fn tree)
- "Apply FN to each element of TREE while preserving the tree structure."
- (cond
- ((not tree) nil)
- ((-cons-pair? tree) (funcall fn tree))
- ((listp tree)
- (mapcar (lambda (x) (-tree-map fn x)) tree))
- (t (funcall fn tree))))
-
-(defmacro --tree-map (form tree)
- "Anaphoric form of `-tree-map'."
- (declare (debug (form form)))
- `(-tree-map (lambda (it) ,form) ,tree))
-
-(defun -tree-reduce-from (fn init-value tree)
- "Use FN to reduce elements of list TREE.
-If elements of TREE are lists themselves, apply the reduction recursively.
-
-FN is first applied to INIT-VALUE and first element of the list,
-then on this result and second element from the list etc.
-
-The initial value is ignored on cons pairs as they always contain
-two elements."
- (cond
- ((not tree) nil)
- ((-cons-pair? tree) tree)
- ((listp tree)
- (-reduce-r-from fn init-value (mapcar (lambda (x) (-tree-reduce-from fn init-value x)) tree)))
- (t tree)))
-
-(defmacro --tree-reduce-from (form init-value tree)
- "Anaphoric form of `-tree-reduce-from'."
- (declare (debug (form form form)))
- `(-tree-reduce-from (lambda (it acc) ,form) ,init-value ,tree))
-
-(defun -tree-reduce (fn tree)
- "Use FN to reduce elements of list TREE.
-If elements of TREE are lists themselves, apply the reduction recursively.
-
-FN is first applied to first element of the list and second
-element, then on this result and third element from the list etc.
-
-See `-reduce-r' for how exactly are lists of zero or one element handled."
- (cond
- ((not tree) nil)
- ((-cons-pair? tree) tree)
- ((listp tree)
- (-reduce-r fn (mapcar (lambda (x) (-tree-reduce fn x)) tree)))
- (t tree)))
-
-(defmacro --tree-reduce (form tree)
- "Anaphoric form of `-tree-reduce'."
- (declare (debug (form form)))
- `(-tree-reduce (lambda (it acc) ,form) ,tree))
-
-(defun -tree-map-nodes (pred fun tree)
- "Call FUN on each node of TREE that satisfies PRED.
-
-If PRED returns nil, continue descending down this node. If PRED
-returns non-nil, apply FUN to this node and do not descend
-further."
- (if (funcall pred tree)
- (funcall fun tree)
- (if (and (listp tree)
- (not (-cons-pair? tree)))
- (-map (lambda (x) (-tree-map-nodes pred fun x)) tree)
- tree)))
-
-(defmacro --tree-map-nodes (pred form tree)
- "Anaphoric form of `-tree-map-nodes'."
- `(-tree-map-nodes (lambda (it) ,pred) (lambda (it) ,form) ,tree))
-
-(defun -tree-seq (branch children tree)
- "Return a sequence of the nodes in TREE, in depth-first search order.
-
-BRANCH is a predicate of one argument that returns non-nil if the
-passed argument is a branch, that is, a node that can have children.
-
-CHILDREN is a function of one argument that returns the children
-of the passed branch node.
-
-Non-branch nodes are simply copied."
- (cons tree
- (when (funcall branch tree)
- (-mapcat (lambda (x) (-tree-seq branch children x))
- (funcall children tree)))))
-
-(defmacro --tree-seq (branch children tree)
- "Anaphoric form of `-tree-seq'."
- `(-tree-seq (lambda (it) ,branch) (lambda (it) ,children) ,tree))
-
-(defun -clone (list)
- "Create a deep copy of LIST.
-The new list has the same elements and structure but all cons are
-replaced with new ones. This is useful when you need to clone a
-structure such as plist or alist."
- (declare (pure t) (side-effect-free t))
- (-tree-map 'identity list))
-
-(defun dash-enable-font-lock ()
- "Add syntax highlighting to dash functions, macros and magic values."
- (eval-after-load "lisp-mode"
- '(progn
- (let ((new-keywords '(
- "-each"
- "--each"
- "-each-indexed"
- "--each-indexed"
- "-each-while"
- "--each-while"
- "-dotimes"
- "--dotimes"
- "-map"
- "--map"
- "-reduce-from"
- "--reduce-from"
- "-reduce"
- "--reduce"
- "-reduce-r-from"
- "--reduce-r-from"
- "-reduce-r"
- "--reduce-r"
- "-filter"
- "--filter"
- "-select"
- "--select"
- "-remove"
- "--remove"
- "-reject"
- "--reject"
- "-remove-first"
- "--remove-first"
- "-reject-first"
- "--reject-first"
- "-remove-last"
- "--remove-last"
- "-reject-last"
- "--reject-last"
- "-remove-item"
- "-non-nil"
- "-keep"
- "--keep"
- "-map-indexed"
- "--map-indexed"
- "-splice"
- "--splice"
- "-splice-list"
- "--splice-list"
- "-map-when"
- "--map-when"
- "-replace-where"
- "--replace-where"
- "-map-first"
- "--map-first"
- "-map-last"
- "--map-last"
- "-replace"
- "-replace-first"
- "-replace-last"
- "-flatten"
- "-flatten-n"
- "-concat"
- "-mapcat"
- "--mapcat"
- "-copy"
- "-cons*"
- "-snoc"
- "-first"
- "--first"
- "-find"
- "--find"
- "-some"
- "--some"
- "-any"
- "--any"
- "-last"
- "--last"
- "-first-item"
- "-last-item"
- "-butlast"
- "-count"
- "--count"
- "-any?"
- "--any?"
- "-some?"
- "--some?"
- "-any-p"
- "--any-p"
- "-some-p"
- "--some-p"
- "-all?"
- "--all?"
- "-every?"
- "--every?"
- "-all-p"
- "--all-p"
- "-every-p"
- "--every-p"
- "-none?"
- "--none?"
- "-none-p"
- "--none-p"
- "-only-some?"
- "--only-some?"
- "-only-some-p"
- "--only-some-p"
- "-slice"
- "-take"
- "-drop"
- "-take-while"
- "--take-while"
- "-drop-while"
- "--drop-while"
- "-split-at"
- "-rotate"
- "-insert-at"
- "-replace-at"
- "-update-at"
- "--update-at"
- "-remove-at"
- "-remove-at-indices"
- "-split-with"
- "--split-with"
- "-split-on"
- "-split-when"
- "--split-when"
- "-separate"
- "--separate"
- "-partition-all-in-steps"
- "-partition-in-steps"
- "-partition-all"
- "-partition"
- "-partition-by"
- "--partition-by"
- "-partition-by-header"
- "--partition-by-header"
- "-group-by"
- "--group-by"
- "-interpose"
- "-interleave"
- "-zip-with"
- "--zip-with"
- "-zip"
- "-zip-fill"
- "-cycle"
- "-pad"
- "-annotate"
- "--annotate"
- "-table"
- "-table-flat"
- "-partial"
- "-elem-index"
- "-elem-indices"
- "-find-indices"
- "--find-indices"
- "-find-index"
- "--find-index"
- "-find-last-index"
- "--find-last-index"
- "-select-by-indices"
- "-select-columns"
- "-select-column"
- "-grade-up"
- "-grade-down"
- "->"
- "->>"
- "-->"
- "-when-let"
- "-when-let*"
- "--when-let"
- "-if-let"
- "-if-let*"
- "--if-let"
- "-let*"
- "-let"
- "-lambda"
- "-distinct"
- "-uniq"
- "-union"
- "-intersection"
- "-difference"
- "-contains?"
- "-contains-p"
- "-same-items?"
- "-same-items-p"
- "-is-prefix-p"
- "-is-prefix?"
- "-is-suffix-p"
- "-is-suffix?"
- "-is-infix-p"
- "-is-infix?"
- "-sort"
- "--sort"
- "-list"
- "-repeat"
- "-sum"
- "-product"
- "-max"
- "-min"
- "-max-by"
- "--max-by"
- "-min-by"
- "--min-by"
- "-iterate"
- "--iterate"
- "-fix"
- "--fix"
- "-unfold"
- "--unfold"
- "-cons-pair?"
- "-cons-to-list"
- "-value-to-list"
- "-tree-mapreduce-from"
- "--tree-mapreduce-from"
- "-tree-mapreduce"
- "--tree-mapreduce"
- "-tree-map"
- "--tree-map"
- "-tree-reduce-from"
- "--tree-reduce-from"
- "-tree-reduce"
- "--tree-reduce"
- "-tree-seq"
- "--tree-seq"
- "-tree-map-nodes"
- "--tree-map-nodes"
- "-clone"
- "-rpartial"
- "-juxt"
- "-applify"
- "-on"
- "-flip"
- "-const"
- "-cut"
- "-orfn"
- "-andfn"
- "-iteratefn"
- "-fixfn"
- "-prodfn"
- ))
- (special-variables '(
- "it"
- "it-index"
- "acc"
- "other"
- )))
- (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "\\_<" (regexp-opt special-variables 'paren) "\\_>")
- 1 font-lock-variable-name-face)) 'append)
- (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "(\\s-*" (regexp-opt new-keywords 'paren) "\\_>")
- 1 font-lock-keyword-face)) 'append))
- (--each (buffer-list)
- (with-current-buffer it
- (when (and (eq major-mode 'emacs-lisp-mode)
- (boundp 'font-lock-mode)
- font-lock-mode)
- (font-lock-refresh-defaults)))))))
-
-(provide 'dash)
-;;; dash.el ends here
--- /dev/null
+;;; dash-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
+\f
+;;;### (autoloads nil nil ("dash.el") (22975 34387 0 0))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; dash-autoloads.el ends here
--- /dev/null
+;;; -*- no-byte-compile: t -*-
+(define-package "dash" "20170810.137" "A modern list library for Emacs" 'nil :commit "0df0ff1a65d54377381e50c08d88b247db44c3dd" :keywords '("lists"))
--- /dev/null
+;;; dash.el --- A modern list library for Emacs -*- lexical-binding: t -*-
+
+;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
+
+;; Author: Magnar Sveen <magnarsNOSPAMgmail.com>
+;; Version: 2.13.0
+;; Package-Version: 20170810.137
+;; Keywords: lists
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A modern list api for Emacs.
+;;
+;; See documentation on https://github.com/magnars/dash.el#functions
+;;
+;; **Please note** The lexical binding in this file is not utilised at the
+;; moment. We will take full advantage of lexical binding in an upcoming 3.0
+;; release of Dash. In the meantime, we've added the pragma to avoid a bug that
+;; you can read more about in https://github.com/magnars/dash.el/issues/130.
+;;
+
+;;; Code:
+
+(defgroup dash ()
+ "Customize group for dash.el"
+ :group 'lisp
+ :prefix "dash-")
+
+(defun dash--enable-fontlock (symbol value)
+ (when value
+ (dash-enable-font-lock))
+ (set-default symbol value))
+
+(defcustom dash-enable-fontlock nil
+ "If non-nil, enable fontification of dash functions, macros and
+special values."
+ :type 'boolean
+ :set 'dash--enable-fontlock
+ :group 'dash)
+
+(defmacro !cons (car cdr)
+ "Destructive: Set CDR to the cons of CAR and CDR."
+ `(setq ,cdr (cons ,car ,cdr)))
+
+(defmacro !cdr (list)
+ "Destructive: Set LIST to the cdr of LIST."
+ `(setq ,list (cdr ,list)))
+
+(defmacro --each (list &rest body)
+ "Anaphoric form of `-each'."
+ (declare (debug (form body))
+ (indent 1))
+ (let ((l (make-symbol "list")))
+ `(let ((,l ,list)
+ (it-index 0))
+ (while ,l
+ (let ((it (car ,l)))
+ ,@body)
+ (setq it-index (1+ it-index))
+ (!cdr ,l)))))
+
+(defmacro -doto (eval-initial-value &rest forms)
+ "Eval a form, then insert that form as the 2nd argument to other forms.
+The EVAL-INITIAL-VALUE form is evaluated once. Its result is
+passed to FORMS, which are then evaluated sequentially. Returns
+the target form."
+ (declare (indent 1))
+ (let ((retval (make-symbol "value")))
+ `(let ((,retval ,eval-initial-value))
+ ,@(mapcar (lambda (form)
+ (if (sequencep form)
+ `(,(-first-item form) ,retval ,@(cdr form))
+ `(funcall form ,retval)))
+ forms)
+ ,retval)))
+
+(defun -each (list fn)
+ "Call FN with every item in LIST. Return nil, used for side-effects only."
+ (--each list (funcall fn it)))
+
+(put '-each 'lisp-indent-function 1)
+
+(defalias '--each-indexed '--each)
+
+(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 symbol `it-index'.
+
+See also: `-map-indexed'."
+ (--each list (funcall fn it-index it)))
+(put '-each-indexed 'lisp-indent-function 1)
+
+(defmacro --each-while (list pred &rest body)
+ "Anaphoric form of `-each-while'."
+ (declare (debug (form form body))
+ (indent 2))
+ (let ((l (make-symbol "list"))
+ (c (make-symbol "continue")))
+ `(let ((,l ,list)
+ (,c t)
+ (it-index 0))
+ (while (and ,l ,c)
+ (let ((it (car ,l)))
+ (if (not ,pred) (setq ,c nil) ,@body))
+ (setq it-index (1+ it-index))
+ (!cdr ,l)))))
+
+(defun -each-while (list pred fn)
+ "Call FN with every item in LIST while (PRED item) is non-nil.
+Return nil, used for side-effects only."
+ (--each-while list (funcall pred it) (funcall fn it)))
+
+(put '-each-while 'lisp-indent-function 2)
+
+(defmacro --dotimes (num &rest body)
+ "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")))
+ `(let ((,n ,num)
+ (it 0))
+ (while (< it ,n)
+ ,@body
+ (setq it (1+ it))))))
+
+(defun -dotimes (num fn)
+ "Repeatedly calls FN (presumably for side-effects) passing in integers from 0 through NUM-1."
+ (--dotimes num (funcall fn it)))
+
+(put '-dotimes 'lisp-indent-function 1)
+
+(defun -map (fn list)
+ "Return a new list consisting of the result of applying FN to the items in LIST."
+ (mapcar fn list))
+
+(defmacro --map (form list)
+ "Anaphoric form of `-map'."
+ (declare (debug (form form)))
+ `(mapcar (lambda (it) ,form) ,list))
+
+(defmacro --reduce-from (form initial-value list)
+ "Anaphoric form of `-reduce-from'."
+ (declare (debug (form form form)))
+ `(let ((acc ,initial-value))
+ (--each ,list (setq acc ,form))
+ acc))
+
+(defun -reduce-from (fn initial-value list)
+ "Return the result of applying FN to INITIAL-VALUE and the
+first item in LIST, then applying FN to that result and the 2nd
+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 symbol `acc'.
+
+See also: `-reduce', `-reduce-r'"
+ (--reduce-from (funcall fn acc it) initial-value list))
+
+(defmacro --reduce (form list)
+ "Anaphoric form of `-reduce'."
+ (declare (debug (form form)))
+ (let ((lv (make-symbol "list-value")))
+ `(let ((,lv ,list))
+ (if ,lv
+ (--reduce-from ,form (car ,lv) (cdr ,lv))
+ (let (acc it) ,form)))))
+
+(defun -reduce (fn list)
+ "Return the result of applying FN to the first 2 items in LIST,
+then applying FN to that result and the 3rd item, etc. If LIST
+contains no items, FN must accept no arguments as well, and
+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 symbol `acc'.
+
+See also: `-reduce-from', `-reduce-r'"
+ (if list
+ (-reduce-from fn (car list) (cdr list))
+ (funcall fn)))
+
+(defun -reduce-r-from (fn initial-value list)
+ "Replace conses with FN, nil with INITIAL-VALUE and evaluate
+the resulting expression. If LIST is empty, INITIAL-VALUE is
+returned and FN is not called.
+
+Note: this function works the same as `-reduce-from' but the
+operation associates from right instead of from left.
+
+See also: `-reduce-r', `-reduce'"
+ (if (not list) initial-value
+ (funcall fn (car list) (-reduce-r-from fn initial-value (cdr list)))))
+
+(defmacro --reduce-r-from (form initial-value list)
+ "Anaphoric version of `-reduce-r-from'."
+ (declare (debug (form form form)))
+ `(-reduce-r-from (lambda (&optional it acc) ,form) ,initial-value ,list))
+
+(defun -reduce-r (fn list)
+ "Replace conses with FN and evaluate the resulting expression.
+The final nil is ignored. If LIST contains no items, FN must
+accept no arguments as well, and reduce return the result of
+calling FN with no arguments. If LIST has only 1 item, it is
+returned and FN is not called.
+
+The first argument of FN is the new item, the second is the
+accumulated value.
+
+Note: this function works the same as `-reduce' but the operation
+associates from right instead of from left.
+
+See also: `-reduce-r-from', `-reduce'"
+ (cond
+ ((not list) (funcall fn))
+ ((not (cdr list)) (car list))
+ (t (funcall fn (car list) (-reduce-r fn (cdr list))))))
+
+(defmacro --reduce-r (form list)
+ "Anaphoric version of `-reduce-r'."
+ (declare (debug (form form)))
+ `(-reduce-r (lambda (&optional it acc) ,form) ,list))
+
+(defmacro --filter (form list)
+ "Anaphoric form of `-filter'."
+ (declare (debug (form form)))
+ (let ((r (make-symbol "result")))
+ `(let (,r)
+ (--each ,list (when ,form (!cons it ,r)))
+ (nreverse ,r))))
+
+(defun -filter (pred list)
+ "Return a new list of the items in LIST for which PRED returns a non-nil value.
+
+Alias: `-select'
+
+See also: `-keep'"
+ (--filter (funcall pred it) list))
+
+(defalias '-select '-filter)
+(defalias '--select '--filter)
+
+(defmacro --remove (form list)
+ "Anaphoric form of `-remove'."
+ (declare (debug (form form)))
+ `(--filter (not ,form) ,list))
+
+(defun -remove (pred list)
+ "Return a new list of the items in LIST for which PRED returns nil.
+
+Alias: `-reject'"
+ (--remove (funcall pred it) list))
+
+(defalias '-reject '-remove)
+(defalias '--reject '--remove)
+
+(defun -remove-first (pred list)
+ "Return a new list with the first item matching PRED removed.
+
+Alias: `-reject-first'
+
+See also: `-remove', `-map-first'"
+ (let (front)
+ (while (and list (not (funcall pred (car list))))
+ (push (car list) front)
+ (!cdr list))
+ (if list
+ (-concat (nreverse front) (cdr list))
+ (nreverse front))))
+
+(defmacro --remove-first (form list)
+ "Anaphoric form of `-remove-first'."
+ (declare (debug (form form)))
+ `(-remove-first (lambda (it) ,form) ,list))
+
+(defalias '-reject-first '-remove-first)
+(defalias '--reject-first '--remove-first)
+
+(defun -remove-last (pred list)
+ "Return a new list with the last item matching PRED removed.
+
+Alias: `-reject-last'
+
+See also: `-remove', `-map-last'"
+ (nreverse (-remove-first pred (reverse list))))
+
+(defmacro --remove-last (form list)
+ "Anaphoric form of `-remove-last'."
+ (declare (debug (form form)))
+ `(-remove-last (lambda (it) ,form) ,list))
+
+(defalias '-reject-last '-remove-last)
+(defalias '--reject-last '--remove-last)
+
+(defun -remove-item (item list)
+ "Remove all occurences of ITEM from LIST.
+
+Comparison is done with `equal'."
+ (declare (pure t) (side-effect-free t))
+ (--remove (equal it item) list))
+
+(defmacro --keep (form list)
+ "Anaphoric form of `-keep'."
+ (declare (debug (form form)))
+ (let ((r (make-symbol "result"))
+ (m (make-symbol "mapped")))
+ `(let (,r)
+ (--each ,list (let ((,m ,form)) (when ,m (!cons ,m ,r))))
+ (nreverse ,r))))
+
+(defun -keep (fn list)
+ "Return a new list of the non-nil results of applying FN to the items in LIST.
+
+If you want to select the original items satisfying a predicate use `-filter'."
+ (--keep (funcall fn it) list))
+
+(defun -non-nil (list)
+ "Return all non-nil elements of LIST."
+ (declare (pure t) (side-effect-free t))
+ (-remove 'null list))
+
+(defmacro --map-indexed (form list)
+ "Anaphoric form of `-map-indexed'."
+ (declare (debug (form form)))
+ (let ((r (make-symbol "result")))
+ `(let (,r)
+ (--each ,list
+ (!cons ,form ,r))
+ (nreverse ,r))))
+
+(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 symbol `it-index'.
+
+See also: `-each-indexed'."
+ (--map-indexed (funcall fn it-index it) list))
+
+(defmacro --map-when (pred rep list)
+ "Anaphoric form of `-map-when'."
+ (declare (debug (form form form)))
+ (let ((r (make-symbol "result")))
+ `(let (,r)
+ (--each ,list (!cons (if ,pred ,rep it) ,r))
+ (nreverse ,r))))
+
+(defun -map-when (pred rep list)
+ "Return a new list where the elements in LIST that do not match the PRED function
+are unchanged, and where the elements in LIST that do match the PRED function are mapped
+through the REP function.
+
+Alias: `-replace-where'
+
+See also: `-update-at'"
+ (--map-when (funcall pred it) (funcall rep it) list))
+
+(defalias '-replace-where '-map-when)
+(defalias '--replace-where '--map-when)
+
+(defun -map-first (pred rep list)
+ "Replace first item in LIST satisfying PRED with result of REP called on this item.
+
+See also: `-map-when', `-replace-first'"
+ (let (front)
+ (while (and list (not (funcall pred (car list))))
+ (push (car list) front)
+ (!cdr list))
+ (if list
+ (-concat (nreverse front) (cons (funcall rep (car list)) (cdr list)))
+ (nreverse front))))
+
+(defmacro --map-first (pred rep list)
+ "Anaphoric form of `-map-first'."
+ `(-map-first (lambda (it) ,pred) (lambda (it) (ignore it) ,rep) ,list))
+
+(defun -map-last (pred rep list)
+ "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))))
+
+(defmacro --map-last (pred rep list)
+ "Anaphoric form of `-map-last'."
+ `(-map-last (lambda (it) ,pred) (lambda (it) (ignore it) ,rep) ,list))
+
+(defun -replace (old new list)
+ "Replace all OLD items in LIST with NEW.
+
+Elements are compared using `equal'.
+
+See also: `-replace-at'"
+ (declare (pure t) (side-effect-free t))
+ (--map-when (equal it old) new list))
+
+(defun -replace-first (old new list)
+ "Replace the first occurence of OLD with NEW in LIST.
+
+Elements are compared using `equal'.
+
+See also: `-map-first'"
+ (declare (pure t) (side-effect-free t))
+ (--map-first (equal old it) new list))
+
+(defun -replace-last (old new list)
+ "Replace the last occurence of OLD with NEW in LIST.
+
+Elements are compared using `equal'.
+
+See also: `-map-last'"
+ (declare (pure t) (side-effect-free t))
+ (--map-last (equal old it) new list))
+
+(defmacro --mapcat (form list)
+ "Anaphoric form of `-mapcat'."
+ (declare (debug (form form)))
+ `(apply 'append (--map ,form ,list)))
+
+(defun -mapcat (fn list)
+ "Return the concatenation of the result of mapping FN over LIST.
+Thus function FN should return a list."
+ (--mapcat (funcall fn it) list))
+
+(defun -flatten (l)
+ "Take a nested list L and return its contents as a single, flat list.
+
+Note that because `nil' represents a list of zero elements (an
+empty list), any mention of nil in L will disappear after
+flattening. If you need to preserve nils, consider `-flatten-n'
+or map them to some unique symbol and then map them back.
+
+Conses of two atoms are considered \"terminals\", that is, they
+aren't flattened further.
+
+See also: `-flatten-n'"
+ (declare (pure t) (side-effect-free t))
+ (if (and (listp l) (listp (cdr l)))
+ (-mapcat '-flatten l)
+ (list l)))
+
+(defmacro --iterate (form init n)
+ "Anaphoric version of `-iterate'."
+ (declare (debug (form form form)))
+ `(-iterate (lambda (it) ,form) ,init ,n))
+
+(defun -flatten-n (num list)
+ "Flatten NUM levels of a nested LIST.
+
+See also: `-flatten'"
+ (declare (pure t) (side-effect-free t))
+ (-last-item (--iterate (--mapcat (-list it) it) list (1+ num))))
+
+(defun -concat (&rest lists)
+ "Return a new list with the concatenation of the elements in the supplied LISTS."
+ (declare (pure t) (side-effect-free t))
+ (apply 'append lists))
+
+(defalias '-copy 'copy-sequence
+ "Create a shallow copy of LIST.
+
+\(fn LIST)")
+
+(defun -splice (pred fun list)
+ "Splice lists generated by FUN in place of elements matching PRED in LIST.
+
+FUN takes the element matching PRED as input.
+
+This function can be used as replacement for `,@' in case you
+need to splice several lists at marked positions (for example
+with keywords).
+
+See also: `-splice-list', `-insert-at'"
+ (let (r)
+ (--each list
+ (if (funcall pred it)
+ (let ((new (funcall fun it)))
+ (--each new (!cons it r)))
+ (!cons it r)))
+ (nreverse r)))
+
+(defmacro --splice (pred form list)
+ "Anaphoric form of `-splice'."
+ `(-splice (lambda (it) ,pred) (lambda (it) ,form) ,list))
+
+(defun -splice-list (pred new-list list)
+ "Splice NEW-LIST in place of elements matching PRED in LIST.
+
+See also: `-splice', `-insert-at'"
+ (-splice pred (lambda (_) new-list) list))
+
+(defmacro --splice-list (pred new-list list)
+ "Anaphoric form of `-splice-list'."
+ `(-splice-list (lambda (it) ,pred) ,new-list ,list))
+
+(defun -cons* (&rest args)
+ "Make a new list from the elements of ARGS.
+
+The last 2 members of ARGS are used as the final cons of the
+result so if the final member of ARGS is not a list the result is
+a dotted list."
+ (declare (pure t) (side-effect-free t))
+ (-reduce-r 'cons args))
+
+(defun -snoc (list elem &rest elements)
+ "Append ELEM to the end of the list.
+
+This is like `cons', but operates on the end of list.
+
+If ELEMENTS is non nil, append these to the list as well."
+ (-concat list (list elem) elements))
+
+(defmacro --first (form list)
+ "Anaphoric form of `-first'."
+ (declare (debug (form form)))
+ (let ((n (make-symbol "needle")))
+ `(let (,n)
+ (--each-while ,list (not ,n)
+ (when ,form (setq ,n it)))
+ ,n)))
+
+(defun -first (pred list)
+ "Return the first x in LIST where (PRED x) is non-nil, else nil.
+
+To get the first item in the list no questions asked, use `car'.
+
+Alias: `-find'"
+ (--first (funcall pred it) list))
+
+(defalias '-find '-first)
+(defalias '--find '--first)
+
+(defmacro --some (form list)
+ "Anaphoric form of `-some'."
+ (declare (debug (form form)))
+ (let ((n (make-symbol "needle")))
+ `(let (,n)
+ (--each-while ,list (not ,n)
+ (setq ,n ,form))
+ ,n)))
+
+(defun -some (pred list)
+ "Return (PRED x) for the first LIST item where (PRED x) is non-nil, else nil.
+
+Alias: `-any'"
+ (--some (funcall pred it) list))
+
+(defalias '-any '-some)
+(defalias '--any '--some)
+
+(defmacro --last (form list)
+ "Anaphoric form of `-last'."
+ (declare (debug (form form)))
+ (let ((n (make-symbol "needle")))
+ `(let (,n)
+ (--each ,list
+ (when ,form (setq ,n it)))
+ ,n)))
+
+(defun -last (pred list)
+ "Return the last x in LIST where (PRED x) is non-nil, else nil."
+ (--last (funcall pred it) list))
+
+(defalias '-first-item 'car
+ "Return the first item of LIST, or nil on an empty list.
+
+\(fn LIST)")
+
+;; 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)))
+
+;; 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."
+ ;; no alias as we don't want magic optional argument
+ (declare (pure t) (side-effect-free t))
+ (butlast list))
+
+(defmacro --count (pred list)
+ "Anaphoric form of `-count'."
+ (declare (debug (form form)))
+ (let ((r (make-symbol "result")))
+ `(let ((,r 0))
+ (--each ,list (when ,pred (setq ,r (1+ ,r))))
+ ,r)))
+
+(defun -count (pred list)
+ "Counts the number of items in LIST where (PRED item) is non-nil."
+ (--count (funcall pred it) list))
+
+(defun ---truthy? (val)
+ (declare (pure t) (side-effect-free t))
+ (not (null val)))
+
+(defmacro --any? (form list)
+ "Anaphoric form of `-any?'."
+ (declare (debug (form form)))
+ `(---truthy? (--first ,form ,list)))
+
+(defun -any? (pred list)
+ "Return t if (PRED x) is non-nil for any x in LIST, else nil.
+
+Alias: `-any-p', `-some?', `-some-p'"
+ (--any? (funcall pred it) list))
+
+(defalias '-some? '-any?)
+(defalias '--some? '--any?)
+(defalias '-any-p '-any?)
+(defalias '--any-p '--any?)
+(defalias '-some-p '-any?)
+(defalias '--some-p '--any?)
+
+(defmacro --all? (form list)
+ "Anaphoric form of `-all?'."
+ (declare (debug (form form)))
+ (let ((a (make-symbol "all")))
+ `(let ((,a t))
+ (--each-while ,list ,a (setq ,a ,form))
+ (---truthy? ,a))))
+
+(defun -all? (pred list)
+ "Return t if (PRED x) is non-nil for all x in LIST, else nil.
+
+Alias: `-all-p', `-every?', `-every-p'"
+ (--all? (funcall pred it) list))
+
+(defalias '-every? '-all?)
+(defalias '--every? '--all?)
+(defalias '-all-p '-all?)
+(defalias '--all-p '--all?)
+(defalias '-every-p '-all?)
+(defalias '--every-p '--all?)
+
+(defmacro --none? (form list)
+ "Anaphoric form of `-none?'."
+ (declare (debug (form form)))
+ `(--all? (not ,form) ,list))
+
+(defun -none? (pred list)
+ "Return t if (PRED x) is nil for all x in LIST, else nil.
+
+Alias: `-none-p'"
+ (--none? (funcall pred it) list))
+
+(defalias '-none-p '-none?)
+(defalias '--none-p '--none?)
+
+(defmacro --only-some? (form list)
+ "Anaphoric form of `-only-some?'."
+ (declare (debug (form form)))
+ (let ((y (make-symbol "yes"))
+ (n (make-symbol "no")))
+ `(let (,y ,n)
+ (--each-while ,list (not (and ,y ,n))
+ (if ,form (setq ,y t) (setq ,n t)))
+ (---truthy? (and ,y ,n)))))
+
+(defun -only-some? (pred list)
+ "Return `t` if at least one item of LIST matches PRED and at least one item of LIST does not match PRED.
+Return `nil` both if all items match the predicate or if none of the items match the predicate.
+
+Alias: `-only-some-p'"
+ (--only-some? (funcall pred it) list))
+
+(defalias '-only-some-p '-only-some?)
+(defalias '--only-some-p '--only-some?)
+
+(defun -slice (list from &optional to step)
+ "Return copy of LIST, starting from index FROM to index TO.
+
+FROM or TO may be negative. These values are then interpreted
+modulo the length of the list.
+
+If STEP is a number, only each STEPth item in the resulting
+section is returned. Defaults to 1."
+ (declare (pure t) (side-effect-free t))
+ (let ((length (length list))
+ (new-list nil))
+ ;; to defaults to the end of the list
+ (setq to (or to length))
+ (setq step (or step 1))
+ ;; handle negative indices
+ (when (< from 0)
+ (setq from (mod from length)))
+ (when (< to 0)
+ (setq to (mod to length)))
+
+ ;; iterate through the list, keeping the elements we want
+ (--each-while list (< it-index to)
+ (when (and (>= it-index from)
+ (= (mod (- from it-index) step) 0))
+ (push it new-list)))
+ (nreverse new-list)))
+
+(defun -take (n list)
+ "Return a new list of the first N items in LIST, or all items if there are fewer than N.
+
+See also: `-take-last'"
+ (declare (pure t) (side-effect-free t))
+ (let (result)
+ (--dotimes n
+ (when list
+ (!cons (car list) result)
+ (!cdr list)))
+ (nreverse result)))
+
+(defun -take-last (n list)
+ "Return the last N items of LIST in order.
+
+See also: `-take'"
+ (declare (pure t) (side-effect-free t))
+ (copy-sequence (last list n)))
+
+(defalias '-drop 'nthcdr
+ "Return the tail of LIST without the first N items.
+
+See also: `-drop-last'
+
+\(fn N LIST)")
+
+(defun -drop-last (n list)
+ "Remove the last N items of LIST and return a copy.
+
+See also: `-drop'"
+ ;; No alias because we don't want magic optional argument
+ (declare (pure t) (side-effect-free t))
+ (butlast list n))
+
+(defmacro --take-while (form list)
+ "Anaphoric form of `-take-while'."
+ (declare (debug (form form)))
+ (let ((r (make-symbol "result")))
+ `(let (,r)
+ (--each-while ,list ,form (!cons it ,r))
+ (nreverse ,r))))
+
+(defun -take-while (pred list)
+ "Return a new list of successive items from LIST while (PRED item) returns a non-nil value."
+ (--take-while (funcall pred it) list))
+
+(defmacro --drop-while (form list)
+ "Anaphoric form of `-drop-while'."
+ (declare (debug (form form)))
+ (let ((l (make-symbol "list")))
+ `(let ((,l ,list))
+ (while (and ,l (let ((it (car ,l))) ,form))
+ (!cdr ,l))
+ ,l)))
+
+(defun -drop-while (pred list)
+ "Return the tail of LIST starting from the first item for which (PRED item) returns nil."
+ (--drop-while (funcall pred it) list))
+
+(defun -split-at (n list)
+ "Return a list of ((-take N LIST) (-drop N LIST)), in no more than one pass through the list."
+ (declare (pure t) (side-effect-free t))
+ (let (result)
+ (--dotimes n
+ (when list
+ (!cons (car list) result)
+ (!cdr list)))
+ (list (nreverse result) list)))
+
+(defun -rotate (n list)
+ "Rotate LIST N places to the right. With N negative, rotate to the left.
+The time complexity is O(n)."
+ (declare (pure t) (side-effect-free t))
+ (if (> n 0)
+ (append (last list n) (butlast list n))
+ (append (-drop (- n) list) (-take (- n) list))))
+
+(defun -insert-at (n x list)
+ "Return a list with X inserted into LIST at position N.
+
+See also: `-splice', `-splice-list'"
+ (declare (pure t) (side-effect-free t))
+ (let ((split-list (-split-at n list)))
+ (nconc (car split-list) (cons x (cadr split-list)))))
+
+(defun -replace-at (n x list)
+ "Return a list with element at Nth position in LIST replaced with X.
+
+See also: `-replace'"
+ (declare (pure t) (side-effect-free t))
+ (let ((split-list (-split-at n list)))
+ (nconc (car split-list) (cons x (cdr (cadr split-list))))))
+
+(defun -update-at (n func list)
+ "Return a list with element at Nth position in LIST replaced with `(func (nth n list))`.
+
+See also: `-map-when'"
+ (let ((split-list (-split-at n list)))
+ (nconc (car split-list) (cons (funcall func (car (cadr split-list))) (cdr (cadr split-list))))))
+
+(defmacro --update-at (n form list)
+ "Anaphoric version of `-update-at'."
+ (declare (debug (form form form)))
+ `(-update-at ,n (lambda (it) ,form) ,list))
+
+(defun -remove-at (n list)
+ "Return a list with element at Nth position in LIST removed.
+
+See also: `-remove-at-indices', `-remove'"
+ (declare (pure t) (side-effect-free t))
+ (-remove-at-indices (list n) list))
+
+(defun -remove-at-indices (indices list)
+ "Return a list whose elements are elements from LIST without
+elements selected as `(nth i list)` for all i
+from INDICES.
+
+See also: `-remove-at', `-remove'"
+ (declare (pure t) (side-effect-free t))
+ (let* ((indices (-sort '< indices))
+ (diffs (cons (car indices) (-map '1- (-zip-with '- (cdr indices) indices))))
+ r)
+ (--each diffs
+ (let ((split (-split-at it list)))
+ (!cons (car split) r)
+ (setq list (cdr (cadr split)))))
+ (!cons list r)
+ (apply '-concat (nreverse r))))
+
+(defmacro --split-with (pred list)
+ "Anaphoric form of `-split-with'."
+ (declare (debug (form form)))
+ (let ((l (make-symbol "list"))
+ (r (make-symbol "result"))
+ (c (make-symbol "continue")))
+ `(let ((,l ,list)
+ (,r nil)
+ (,c t))
+ (while (and ,l ,c)
+ (let ((it (car ,l)))
+ (if (not ,pred)
+ (setq ,c nil)
+ (!cons it ,r)
+ (!cdr ,l))))
+ (list (nreverse ,r) ,l))))
+
+(defun -split-with (pred list)
+ "Return a list of ((-take-while PRED LIST) (-drop-while PRED LIST)), in no more than one pass through the list."
+ (--split-with (funcall pred it) list))
+
+(defmacro -split-on (item list)
+ "Split the LIST each time ITEM is found.
+
+Unlike `-partition-by', the ITEM is discarded from the results.
+Empty lists are also removed from the result.
+
+Comparison is done by `equal'.
+
+See also `-split-when'"
+ (declare (debug (form form)))
+ `(-split-when (lambda (it) (equal it ,item)) ,list))
+
+(defmacro --split-when (form list)
+ "Anaphoric version of `-split-when'."
+ (declare (debug (form form)))
+ `(-split-when (lambda (it) ,form) ,list))
+
+(defun -split-when (fn list)
+ "Split the LIST on each element where FN returns non-nil.
+
+Unlike `-partition-by', the \"matched\" element is discarded from
+the results. Empty lists are also removed from the result.
+
+This function can be thought of as a generalization of
+`split-string'."
+ (let (r s)
+ (while list
+ (if (not (funcall fn (car list)))
+ (push (car list) s)
+ (when s (push (nreverse s) r))
+ (setq s nil))
+ (!cdr list))
+ (when s (push (nreverse s) r))
+ (nreverse r)))
+
+(defmacro --separate (form list)
+ "Anaphoric form of `-separate'."
+ (declare (debug (form form)))
+ (let ((y (make-symbol "yes"))
+ (n (make-symbol "no")))
+ `(let (,y ,n)
+ (--each ,list (if ,form (!cons it ,y) (!cons it ,n)))
+ (list (nreverse ,y) (nreverse ,n)))))
+
+(defun -separate (pred list)
+ "Return a list of ((-filter PRED LIST) (-remove PRED LIST)), in one pass through the list."
+ (--separate (funcall pred it) list))
+
+(defun ---partition-all-in-steps-reversed (n step list)
+ "Private: Used by -partition-all-in-steps and -partition-in-steps."
+ (when (< step 1)
+ (error "Step must be a positive number, or you're looking at some juicy infinite loops."))
+ (let ((result nil))
+ (while list
+ (!cons (-take n list) result)
+ (setq list (-drop step list)))
+ result))
+
+(defun -partition-all-in-steps (n step list)
+ "Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart.
+The last groups may contain less than N items."
+ (declare (pure t) (side-effect-free t))
+ (nreverse (---partition-all-in-steps-reversed n step list)))
+
+(defun -partition-in-steps (n step list)
+ "Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart.
+If there are not enough items to make the last group N-sized,
+those items are discarded."
+ (declare (pure t) (side-effect-free t))
+ (let ((result (---partition-all-in-steps-reversed n step list)))
+ (while (and result (< (length (car result)) n))
+ (!cdr result))
+ (nreverse result)))
+
+(defun -partition-all (n list)
+ "Return a new list with the items in LIST grouped into N-sized sublists.
+The last group may contain less than N items."
+ (declare (pure t) (side-effect-free t))
+ (-partition-all-in-steps n n list))
+
+(defun -partition (n list)
+ "Return a new list with the items in LIST grouped into N-sized sublists.
+If there are not enough items to make the last group N-sized,
+those items are discarded."
+ (declare (pure t) (side-effect-free t))
+ (-partition-in-steps n n list))
+
+(defmacro --partition-by (form list)
+ "Anaphoric form of `-partition-by'."
+ (declare (debug (form form)))
+ (let ((r (make-symbol "result"))
+ (s (make-symbol "sublist"))
+ (v (make-symbol "value"))
+ (n (make-symbol "new-value"))
+ (l (make-symbol "list")))
+ `(let ((,l ,list))
+ (when ,l
+ (let* ((,r nil)
+ (it (car ,l))
+ (,s (list it))
+ (,v ,form)
+ (,l (cdr ,l)))
+ (while ,l
+ (let* ((it (car ,l))
+ (,n ,form))
+ (unless (equal ,v ,n)
+ (!cons (nreverse ,s) ,r)
+ (setq ,s nil)
+ (setq ,v ,n))
+ (!cons it ,s)
+ (!cdr ,l)))
+ (!cons (nreverse ,s) ,r)
+ (nreverse ,r))))))
+
+(defun -partition-by (fn list)
+ "Apply FN to each item in LIST, splitting it each time FN returns a new value."
+ (--partition-by (funcall fn it) list))
+
+(defmacro --partition-by-header (form list)
+ "Anaphoric form of `-partition-by-header'."
+ (declare (debug (form form)))
+ (let ((r (make-symbol "result"))
+ (s (make-symbol "sublist"))
+ (h (make-symbol "header-value"))
+ (b (make-symbol "seen-body?"))
+ (n (make-symbol "new-value"))
+ (l (make-symbol "list")))
+ `(let ((,l ,list))
+ (when ,l
+ (let* ((,r nil)
+ (it (car ,l))
+ (,s (list it))
+ (,h ,form)
+ (,b nil)
+ (,l (cdr ,l)))
+ (while ,l
+ (let* ((it (car ,l))
+ (,n ,form))
+ (if (equal ,h ,n)
+ (when ,b
+ (!cons (nreverse ,s) ,r)
+ (setq ,s nil)
+ (setq ,b nil))
+ (setq ,b t))
+ (!cons it ,s)
+ (!cdr ,l)))
+ (!cons (nreverse ,s) ,r)
+ (nreverse ,r))))))
+
+(defun -partition-by-header (fn list)
+ "Apply FN to the first item in LIST. That is the header
+value. Apply FN to each item in LIST, splitting it each time FN
+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))
+ (let ((n (make-symbol "n"))
+ (k (make-symbol "k"))
+ (grp (make-symbol "grp")))
+ `(nreverse
+ (-map
+ (lambda (,n)
+ (cons (car ,n)
+ (nreverse (cdr ,n))))
+ (--reduce-from
+ (let* ((,k (,@form))
+ (,grp (assoc ,k acc)))
+ (if ,grp
+ (setcdr ,grp (cons it (cdr ,grp)))
+ (push
+ (list ,k it)
+ acc))
+ acc)
+ nil ,list)))))
+
+(defun -group-by (fn list)
+ "Separate LIST into an alist whose keys are FN applied to the
+elements of LIST. Keys are compared by `equal'."
+ (--group-by (funcall fn it) list))
+
+(defun -interpose (sep list)
+ "Return a new list of all elements in LIST separated by SEP."
+ (declare (pure t) (side-effect-free t))
+ (let (result)
+ (when list
+ (!cons (car list) result)
+ (!cdr list))
+ (while list
+ (setq result (cons (car list) (cons sep result)))
+ (!cdr list))
+ (nreverse result)))
+
+(defun -interleave (&rest lists)
+ "Return a new list of the first item in each list, then the second etc."
+ (declare (pure t) (side-effect-free t))
+ (let (result)
+ (while (-none? 'null lists)
+ (--each lists (!cons (car it) result))
+ (setq lists (-map 'cdr lists)))
+ (nreverse result)))
+
+(defmacro --zip-with (form list1 list2)
+ "Anaphoric form of `-zip-with'.
+
+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"))
+ (l2 (make-symbol "list2")))
+ `(let ((,r nil)
+ (,l1 ,list1)
+ (,l2 ,list2))
+ (while (and ,l1 ,l2)
+ (let ((it (car ,l1))
+ (other (car ,l2)))
+ (!cons ,form ,r)
+ (!cdr ,l1)
+ (!cdr ,l2)))
+ (nreverse ,r))))
+
+(defun -zip-with (fn list1 list2)
+ "Zip the two lists LIST1 and LIST2 using a function FN. This
+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 symbol `it',
+and the elements from LIST2 as symbol `other'."
+ (--zip-with (funcall fn it other) list1 list2))
+
+(defun -zip (&rest lists)
+ "Zip LISTS together. Group the head of each list, followed by the
+second elements of each list, and so on. The lengths of the returned
+groupings are equal to the length of the shortest input list.
+
+If two lists are provided as arguments, return the groupings as a list
+of cons cells. Otherwise, return the groupings as a list of lists.
+
+Please note! This distinction is being removed in an upcoming 3.0
+release of Dash. If you rely on this behavior, use -zip-pair instead."
+ (declare (pure t) (side-effect-free t))
+ (let (results)
+ (while (-none? 'null lists)
+ (setq results (cons (mapcar 'car lists) results))
+ (setq lists (mapcar 'cdr lists)))
+ (setq results (nreverse results))
+ (if (= (length lists) 2)
+ ;; to support backward compatability, return
+ ;; a cons cell if two lists were provided
+ (--map (cons (car it) (cadr it)) results)
+ results)))
+
+(defalias '-zip-pair '-zip)
+
+(defun -zip-fill (fill-value &rest lists)
+ "Zip LISTS, with FILL-VALUE padded onto the shorter lists. The
+lengths of the returned groupings are equal to the length of the
+longest input list."
+ (declare (pure t) (side-effect-free t))
+ (apply '-zip (apply '-pad (cons fill-value lists))))
+
+(defun -unzip (lists)
+ "Unzip LISTS.
+
+This works just like `-zip' but takes a list of lists instead of
+a variable number of arguments, such that
+
+ (-unzip (-zip L1 L2 L3 ...))
+
+is identity (given that the lists are the same length).
+
+See also: `-zip'"
+ (apply '-zip lists))
+
+(defun -cycle (list)
+ "Return an infinite copy of LIST that will cycle through the
+elements and repeat from the beginning."
+ (declare (pure t) (side-effect-free t))
+ (let ((newlist (-map 'identity list)))
+ (nconc newlist newlist)))
+
+(defun -pad (fill-value &rest lists)
+ "Appends FILL-VALUE to the end of each list in LISTS such that they
+will all have the same length."
+ (let* ((annotations (-annotate 'length lists))
+ (n (-max (-map 'car annotations))))
+ (--map (append (cdr it) (-repeat (- n (car it)) fill-value)) annotations)))
+
+(defun -annotate (fn list)
+ "Return a list of cons cells where each cell is FN applied to each
+element of LIST paired with the unmodified element of LIST."
+ (-zip (-map fn list) list))
+
+(defmacro --annotate (form list)
+ "Anaphoric version of `-annotate'."
+ (declare (debug (form form)))
+ `(-annotate (lambda (it) ,form) ,list))
+
+(defun dash--table-carry (lists restore-lists &optional re)
+ "Helper for `-table' and `-table-flat'.
+
+If a list overflows, carry to the right and reset the list."
+ (while (not (or (car lists)
+ (equal lists '(nil))))
+ (setcar lists (car restore-lists))
+ (pop (cadr lists))
+ (!cdr lists)
+ (!cdr restore-lists)
+ (when re
+ (push (nreverse (car re)) (cadr re))
+ (setcar re nil)
+ (!cdr re))))
+
+(defun -table (fn &rest lists)
+ "Compute outer product of LISTS using function FN.
+
+The function FN should have the same arity as the number of
+supplied lists.
+
+The outer product is computed by applying fn to all possible
+combinations created by taking one element from each list in
+order. The dimension of the result is (length lists).
+
+See also: `-table-flat'"
+ (let ((restore-lists (copy-sequence lists))
+ (last-list (last lists))
+ (re (make-list (length lists) nil)))
+ (while (car last-list)
+ (let ((item (apply fn (-map 'car lists))))
+ (push item (car re))
+ (setcar lists (cdar lists)) ;; silence byte compiler
+ (dash--table-carry lists restore-lists re)))
+ (nreverse (car (last re)))))
+
+(defun -table-flat (fn &rest lists)
+ "Compute flat outer product of LISTS using function FN.
+
+The function FN should have the same arity as the number of
+supplied lists.
+
+The outer product is computed by applying fn to all possible
+combinations created by taking one element from each list in
+order. The results are flattened, ignoring the tensor structure
+of the result. This is equivalent to calling:
+
+ (-flatten-n (1- (length lists)) (apply '-table fn lists))
+
+but the implementation here is much more efficient.
+
+See also: `-flatten-n', `-table'"
+ (let ((restore-lists (copy-sequence lists))
+ (last-list (last lists))
+ re)
+ (while (car last-list)
+ (let ((item (apply fn (-map 'car lists))))
+ (push item re)
+ (setcar lists (cdar lists)) ;; silence byte compiler
+ (dash--table-carry lists restore-lists)))
+ (nreverse re)))
+
+(defun -partial (fn &rest args)
+ "Take a function FN and fewer than the normal arguments to FN,
+and return a fn that takes a variable number of additional ARGS.
+When called, the returned function calls FN with ARGS first and
+then additional args."
+ (apply 'apply-partially fn args))
+
+(defun -elem-index (elem list)
+ "Return the index of the first element in the given LIST which
+is equal to the query element ELEM, or nil if there is no
+such element."
+ (declare (pure t) (side-effect-free t))
+ (car (-elem-indices elem list)))
+
+(defun -elem-indices (elem list)
+ "Return the indices of all elements in LIST equal to the query
+element ELEM, in ascending order."
+ (declare (pure t) (side-effect-free t))
+ (-find-indices (-partial 'equal elem) list))
+
+(defun -find-indices (pred list)
+ "Return the indices of all elements in LIST satisfying the
+predicate PRED, in ascending order."
+ (apply 'append (--map-indexed (when (funcall pred it) (list it-index)) list)))
+
+(defmacro --find-indices (form list)
+ "Anaphoric version of `-find-indices'."
+ (declare (debug (form form)))
+ `(-find-indices (lambda (it) ,form) ,list))
+
+(defun -find-index (pred list)
+ "Take a predicate PRED and a LIST and return the index of the
+first element in the list satisfying the predicate, or nil if
+there is no such element.
+
+See also `-first'."
+ (car (-find-indices pred list)))
+
+(defmacro --find-index (form list)
+ "Anaphoric version of `-find-index'."
+ (declare (debug (form form)))
+ `(-find-index (lambda (it) ,form) ,list))
+
+(defun -find-last-index (pred list)
+ "Take a predicate PRED and a LIST and return the index of the
+last element in the list satisfying the predicate, or nil if
+there is no such element.
+
+See also `-last'."
+ (-last-item (-find-indices pred list)))
+
+(defmacro --find-last-index (form list)
+ "Anaphoric version of `-find-last-index'."
+ `(-find-last-index (lambda (it) ,form) ,list))
+
+(defun -select-by-indices (indices list)
+ "Return a list whose elements are elements from LIST selected
+as `(nth i list)` for all i from INDICES."
+ (declare (pure t) (side-effect-free t))
+ (let (r)
+ (--each indices
+ (!cons (nth it list) r))
+ (nreverse r)))
+
+(defun -select-columns (columns table)
+ "Select COLUMNS from TABLE.
+
+TABLE is a list of lists where each element represents one row.
+It is assumed each row has the same length.
+
+Each row is transformed such that only the specified COLUMNS are
+selected.
+
+See also: `-select-column', `-select-by-indices'"
+ (declare (pure t) (side-effect-free t))
+ (--map (-select-by-indices columns it) table))
+
+(defun -select-column (column table)
+ "Select COLUMN from TABLE.
+
+TABLE is a list of lists where each element represents one row.
+It is assumed each row has the same length.
+
+The single selected column is returned as a list.
+
+See also: `-select-columns', `-select-by-indices'"
+ (declare (pure t) (side-effect-free t))
+ (--mapcat (-select-by-indices (list column) it) table))
+
+(defmacro -> (x &optional form &rest more)
+ "Thread the expr through the forms. Insert X as the second item
+in the first form, making a list of it if it is not a list
+already. If there are more forms, insert the first form as the
+second item in second form, etc."
+ (declare (debug (form &rest [&or symbolp (sexp &rest form)])))
+ (cond
+ ((null form) x)
+ ((null more) (if (listp form)
+ `(,(car form) ,x ,@(cdr form))
+ (list form x)))
+ (:else `(-> (-> ,x ,form) ,@more))))
+
+(defmacro ->> (x &optional form &rest more)
+ "Thread the expr through the forms. Insert X as the last item
+in the first form, making a list of it if it is not a list
+already. If there are more forms, insert the first form as the
+last item in second form, etc."
+ (declare (debug ->))
+ (cond
+ ((null form) x)
+ ((null more) (if (listp form)
+ `(,@form ,x)
+ (list form x)))
+ (:else `(->> (->> ,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 `->'),
+and when that result is non-nil, through the next form, etc."
+ (declare (debug ->))
+ (if (null form) x
+ (let ((result (make-symbol "result")))
+ `(-some-> (-when-let (,result ,x)
+ (-> ,result ,form))
+ ,@more))))
+
+(defmacro -some->> (x &optional form &rest more)
+ "When expr is non-nil, thread it through the first form (via `->>'),
+and when that result is non-nil, through the next form, etc."
+ (declare (debug ->))
+ (if (null form) x
+ (let ((result (make-symbol "result")))
+ `(-some->> (-when-let (,result ,x)
+ (->> ,result ,form))
+ ,@more))))
+
+(defmacro -some--> (x &optional form &rest more)
+ "When expr in non-nil, thread it through the first form (via `-->'),
+and when that result is non-nil, through the next form, etc."
+ (declare (debug ->))
+ (if (null form) x
+ (let ((result (make-symbol "result")))
+ `(-some--> (-when-let (,result ,x)
+ (--> ,result ,form))
+ ,@more))))
+
+(defun -grade-up (comparator list)
+ "Grade elements of LIST using COMPARATOR relation, yielding a
+permutation vector such that applying this permutation to LIST
+sorts it in ascending order."
+ ;; ugly hack to "fix" lack of lexical scope
+ (let ((comp `(lambda (it other) (funcall ',comparator (car it) (car other)))))
+ (->> (--map-indexed (cons it it-index) list)
+ (-sort comp)
+ (-map 'cdr))))
+
+(defun -grade-down (comparator list)
+ "Grade elements of LIST using COMPARATOR relation, yielding a
+permutation vector such that applying this permutation to LIST
+sorts it in descending order."
+ ;; ugly hack to "fix" lack of lexical scope
+ (let ((comp `(lambda (it other) (funcall ',comparator (car other) (car it)))))
+ (->> (--map-indexed (cons it it-index) list)
+ (-sort comp)
+ (-map 'cdr))))
+
+(defvar dash--source-counter 0
+ "Monotonic counter for generated symbols.")
+
+(defun dash--match-make-source-symbol ()
+ "Generate a new dash-source symbol.
+
+All returned symbols are guaranteed to be unique."
+ (prog1 (make-symbol (format "--dash-source-%d--" dash--source-counter))
+ (setq dash--source-counter (1+ dash--source-counter))))
+
+(defun dash--match-ignore-place-p (symbol)
+ "Return non-nil if SYMBOL is a symbol and starts with _."
+ (and (symbolp symbol)
+ (eq (aref (symbol-name symbol) 0) ?_)))
+
+(defun dash--match-cons-skip-cdr (skip-cdr source)
+ "Helper function generating idiomatic shifting code."
+ (cond
+ ((= skip-cdr 0)
+ `(pop ,source))
+ (t
+ `(prog1 ,(dash--match-cons-get-car skip-cdr source)
+ (setq ,source ,(dash--match-cons-get-cdr (1+ skip-cdr) source))))))
+
+(defun dash--match-cons-get-car (skip-cdr source)
+ "Helper function generating idiomatic code to get nth car."
+ (cond
+ ((= skip-cdr 0)
+ `(car ,source))
+ ((= skip-cdr 1)
+ `(cadr ,source))
+ (t
+ `(nth ,skip-cdr ,source))))
+
+(defun dash--match-cons-get-cdr (skip-cdr source)
+ "Helper function generating idiomatic code to get nth cdr."
+ (cond
+ ((= skip-cdr 0)
+ source)
+ ((= skip-cdr 1)
+ `(cdr ,source))
+ (t
+ `(nthcdr ,skip-cdr ,source))))
+
+(defun dash--match-cons (match-form source)
+ "Setup a cons matching environment and call the real matcher."
+ (let ((s (dash--match-make-source-symbol))
+ (n 0)
+ (m match-form))
+ (while (and (consp m)
+ (dash--match-ignore-place-p (car m)))
+ (setq n (1+ n)) (!cdr m))
+ (cond
+ ;; when we only have one pattern in the list, we don't have to
+ ;; create a temporary binding (--dash-source--) for the source
+ ;; and just use the input directly
+ ((and (consp m)
+ (not (cdr m)))
+ (dash--match (car m) (dash--match-cons-get-car n source)))
+ ;; handle other special types
+ ((> n 0)
+ (dash--match m (dash--match-cons-get-cdr n source)))
+ ;; this is the only entry-point for dash--match-cons-1, that's
+ ;; why we can't simply use the above branch, it would produce
+ ;; infinite recursion
+ (t
+ (cons (list s source) (dash--match-cons-1 match-form s))))))
+
+(defun dash--match-cons-1 (match-form source &optional props)
+ "Match MATCH-FORM against SOURCE.
+
+MATCH-FORM is a proper or improper list. Each element of
+MATCH-FORM is either a symbol, which gets bound to the respective
+value in source or another match form which gets destructured
+recursively.
+
+If the cdr of last cons cell in the list is `nil', matching stops
+there.
+
+SOURCE is a proper or improper list."
+ (let ((skip-cdr (or (plist-get props :skip-cdr) 0)))
+ (cond
+ ((consp match-form)
+ (cond
+ ((cdr match-form)
+ (cond
+ ((and (symbolp (car match-form))
+ (memq (car match-form) '(&keys &plist &alist &hash)))
+ (dash--match-kv match-form (dash--match-cons-get-cdr skip-cdr source)))
+ ((dash--match-ignore-place-p (car match-form))
+ (dash--match-cons-1 (cdr match-form) source
+ (plist-put props :skip-cdr (1+ skip-cdr))))
+ (t
+ (-concat (dash--match (car match-form) (dash--match-cons-skip-cdr skip-cdr source))
+ (dash--match-cons-1 (cdr match-form) source)))))
+ (t ;; Last matching place, no need for shift
+ (dash--match (car match-form) (dash--match-cons-get-car skip-cdr source)))))
+ ((eq match-form nil)
+ nil)
+ (t ;; Handle improper lists. Last matching place, no need for shift
+ (dash--match match-form (dash--match-cons-get-cdr skip-cdr source))))))
+
+(defun dash--vector-tail (seq start)
+ "Return the tail of SEQ starting at START."
+ (cond
+ ((vectorp seq)
+ (let* ((re-length (- (length seq) start))
+ (re (make-vector re-length 0)))
+ (--dotimes re-length (aset re it (aref seq (+ it start))))
+ re))
+ ((stringp seq)
+ (substring seq start))))
+
+(defun dash--match-vector (match-form source)
+ "Setup a vector matching environment and call the real matcher."
+ (let ((s (dash--match-make-source-symbol)))
+ (cond
+ ;; don't bind `s' if we only have one sub-pattern
+ ((= (length match-form) 1)
+ (dash--match (aref match-form 0) `(aref ,source 0)))
+ ;; if the source is a symbol, we don't need to re-bind it
+ ((symbolp source)
+ (dash--match-vector-1 match-form source))
+ ;; don't bind `s' if we only have one sub-pattern which is not ignored
+ ((let* ((ignored-places (mapcar 'dash--match-ignore-place-p match-form))
+ (ignored-places-n (length (-remove 'null ignored-places))))
+ (when (= ignored-places-n (1- (length match-form)))
+ (let ((n (-find-index 'null ignored-places)))
+ (dash--match (aref match-form n) `(aref ,source ,n))))))
+ (t
+ (cons (list s source) (dash--match-vector-1 match-form s))))))
+
+(defun dash--match-vector-1 (match-form source)
+ "Match MATCH-FORM against SOURCE.
+
+MATCH-FORM is a vector. Each element of MATCH-FORM is either a
+symbol, which gets bound to the respective value in source or
+another match form which gets destructured recursively.
+
+If second-from-last place in MATCH-FORM is the symbol &rest, the
+next element of the MATCH-FORM is matched against the tail of
+SOURCE, starting at index of the &rest symbol. This is
+conceptually the same as the (head . tail) match for improper
+lists, where dot plays the role of &rest.
+
+SOURCE is a vector.
+
+If the MATCH-FORM vector is shorter than SOURCE vector, only
+the (length MATCH-FORM) places are bound, the rest of the SOURCE
+is discarded."
+ (let ((i 0)
+ (l (length match-form))
+ (re))
+ (while (< i l)
+ (let ((m (aref match-form i)))
+ (push (cond
+ ((and (symbolp m)
+ (eq m '&rest))
+ (prog1 (dash--match
+ (aref match-form (1+ i))
+ `(dash--vector-tail ,source ,i))
+ (setq i l)))
+ ((and (symbolp m)
+ ;; do not match symbols starting with _
+ (not (eq (aref (symbol-name m) 0) ?_)))
+ (list (list m `(aref ,source ,i))))
+ ((not (symbolp m))
+ (dash--match m `(aref ,source ,i))))
+ re)
+ (setq i (1+ i))))
+ (-flatten-n 1 (nreverse re))))
+
+(defun dash--match-kv (match-form source)
+ "Setup a kv matching environment and call the real matcher.
+
+kv can be any key-value store, such as plist, alist or hash-table."
+ (let ((s (dash--match-make-source-symbol)))
+ (cond
+ ;; don't bind `s' if we only have one sub-pattern (&type key val)
+ ((= (length match-form) 3)
+ (dash--match-kv-1 (cdr match-form) source (car match-form)))
+ ;; if the source is a symbol, we don't need to re-bind it
+ ((symbolp source)
+ (dash--match-kv-1 (cdr match-form) source (car match-form)))
+ (t
+ (cons (list s source) (dash--match-kv-1 (cdr match-form) s (car match-form)))))))
+
+(defun dash--match-kv-1 (match-form source type)
+ "Match MATCH-FORM against SOURCE of type TYPE.
+
+MATCH-FORM is a proper list of the form (key1 place1 ... keyN
+placeN). Each placeK is either a symbol, which gets bound to the
+value of keyK retrieved from the key-value store, or another
+match form which gets destructured recursively.
+
+SOURCE is a key-value store of type TYPE, which can be a plist,
+an alist or a hash table.
+
+TYPE is a token specifying the type of the key-value store.
+Valid values are &plist, &alist and &hash."
+ (-flatten-n 1 (-map
+ (lambda (kv)
+ (let* ((k (car kv))
+ (v (cadr kv))
+ (getter (cond
+ ((or (eq type '&plist) (eq type '&keys))
+ `(plist-get ,source ,k))
+ ((eq type '&alist)
+ `(cdr (assoc ,k ,source)))
+ ((eq type '&hash)
+ `(gethash ,k ,source)))))
+ (cond
+ ((symbolp v)
+ (list (list v getter)))
+ (t (dash--match v getter)))))
+ (-partition 2 match-form))))
+
+(defun dash--match-symbol (match-form source)
+ "Bind a symbol.
+
+This works just like `let', there is no destructuring."
+ (list (list match-form source)))
+
+(defun dash--match (match-form source)
+ "Match MATCH-FORM against SOURCE.
+
+This function tests the MATCH-FORM and dispatches to specific
+matchers based on the type of the expression.
+
+Key-value stores are disambiguated by placing a token &plist,
+&alist or &hash as a first item in the MATCH-FORM."
+ (cond
+ ((symbolp match-form)
+ (dash--match-symbol match-form source))
+ ((consp match-form)
+ (cond
+ ;; Handle the "x &as" bindings first.
+ ((and (consp (cdr match-form))
+ (symbolp (car match-form))
+ (eq '&as (cadr match-form)))
+ (let ((s (car match-form)))
+ (cons (list s source)
+ (dash--match (cddr match-form) s))))
+ ((memq (car match-form) '(&keys &plist &alist &hash))
+ (dash--match-kv match-form source))
+ (t (dash--match-cons match-form source))))
+ ((vectorp match-form)
+ ;; We support the &as binding in vectors too
+ (cond
+ ((and (> (length match-form) 2)
+ (symbolp (aref match-form 0))
+ (eq '&as (aref match-form 1)))
+ (let ((s (aref match-form 0)))
+ (cons (list s source)
+ (dash--match (dash--vector-tail match-form 2) s))))
+ (t (dash--match-vector match-form source))))))
+
+(defmacro -let* (varlist &rest body)
+ "Bind variables according to VARLIST then eval BODY.
+
+VARLIST is a list of lists of the form (PATTERN SOURCE). Each
+PATTERN is matched against the SOURCE structurally. SOURCE is
+only evaluated once for each PATTERN.
+
+Each SOURCE can refer to the symbols already bound by this
+VARLIST. This is useful if you want to destructure SOURCE
+recursively but also want to name the intermediate structures.
+
+See `-let' for the list of all possible patterns."
+ (declare (debug ((&rest (sexp form)) body))
+ (indent 1))
+ (let ((bindings (--mapcat (dash--match (car it) (cadr it)) varlist)))
+ `(let* ,bindings
+ ,@body)))
+
+(defmacro -let (varlist &rest body)
+ "Bind variables according to VARLIST then eval BODY.
+
+VARLIST is a list of lists of the form (PATTERN SOURCE). Each
+PATTERN is matched against the SOURCE \"structurally\". SOURCE
+is only evaluated once for each PATTERN. Each PATTERN is matched
+recursively, and can therefore contain sub-patterns which are
+matched against corresponding sub-expressions of SOURCE.
+
+All the SOURCEs are evalled before any symbols are
+bound (i.e. \"in parallel\").
+
+If VARLIST only contains one (PATTERN SOURCE) element, you can
+optionally specify it using a vector and discarding the
+outer-most parens. Thus
+
+ (-let ((PATTERN SOURCE)) ..)
+
+becomes
+
+ (-let [PATTERN SOURCE] ..).
+
+`-let' uses a convention of not binding places (symbols) starting
+with _ whenever it's possible. You can use this to skip over
+entries you don't care about. However, this is not *always*
+possible (as a result of implementation) and these symbols might
+get bound to undefined values.
+
+Following is the overview of supported patterns. Remember that
+patterns can be matched recursively, so every a, b, aK in the
+following can be a matching construct and not necessarily a
+symbol/variable.
+
+Symbol:
+
+ a - bind the SOURCE to A. This is just like regular `let'.
+
+Conses and lists:
+
+ (a) - bind `car' of cons/list to A
+
+ (a . b) - bind car of cons to A and `cdr' to B
+
+ (a b) - bind car of list to A and `cadr' to B
+
+ (a1 a2 a3 ...) - bind 0th car of list to A1, 1st to A2, 2nd to A3 ...
+
+ (a1 a2 a3 ... aN . rest) - as above, but bind the Nth cdr to REST.
+
+Vectors:
+
+ [a] - bind 0th element of a non-list sequence to A (works with
+ vectors, strings, bit arrays...)
+
+ [a1 a2 a3 ...] - bind 0th element of non-list sequence to A0, 1st to
+ A1, 2nd to A2, ...
+ If the PATTERN is shorter than SOURCE, the values at
+ places not in PATTERN are ignored.
+ If the PATTERN is longer than SOURCE, an `error' is
+ thrown.
+
+ [a1 a2 a3 ... &rest rest] - as above, but bind the rest of
+ the sequence to REST. This is
+ conceptually the same as improper list
+ matching (a1 a2 ... aN . rest)
+
+Key/value stores:
+
+ (&plist key0 a0 ... keyN aN) - bind value mapped by keyK in the
+ SOURCE plist to aK. If the
+ value is not found, aK is nil.
+
+ (&alist key0 a0 ... keyN aN) - bind value mapped by keyK in the
+ SOURCE alist to aK. If the
+ value is not found, aK is nil.
+
+ (&hash key0 a0 ... keyN aN) - bind value mapped by keyK in the
+ SOURCE hash table to aK. If the
+ value is not found, aK is nil.
+
+Further, special keyword &keys supports \"inline\" matching of
+plist-like key-value pairs, similarly to &keys keyword of
+`cl-defun'.
+
+ (a1 a2 ... aN &keys key1 b1 ... keyN bK)
+
+This binds N values from the list to a1 ... aN, then interprets
+the cdr as a plist (see key/value matching above).
+
+You can name the source using the syntax SYMBOL &as PATTERN.
+This syntax works with lists (proper or improper), vectors and
+all types of maps.
+
+ (list &as a b c) (list 1 2 3)
+
+binds A to 1, B to 2, C to 3 and LIST to (1 2 3).
+
+Similarly:
+
+ (bounds &as beg . end) (cons 1 2)
+
+binds BEG to 1, END to 2 and BOUNDS to (1 . 2).
+
+ (items &as first . rest) (list 1 2 3)
+
+binds FIRST to 1, REST to (2 3) and ITEMS to (1 2 3)
+
+ [vect &as _ b c] [1 2 3]
+
+binds B to 2, C to 3 and VECT to [1 2 3] (_ avoids binding as usual).
+
+ (plist &as &plist :b b) (list :a 1 :b 2 :c 3)
+
+binds B to 2 and PLIST to (:a 1 :b 2 :c 3). Same for &alist and &hash.
+
+This is especially useful when we want to capture the result of a
+computation and destructure at the same time. Consider the
+form (function-returning-complex-structure) returning a list of
+two vectors with two items each. We want to capture this entire
+result and pass it to another computation, but at the same time
+we want to get the second item from each vector. We can achieve
+it with pattern
+
+ (result &as [_ a] [_ b]) (function-returning-complex-structure)
+
+Note: Clojure programmers may know this feature as the \":as
+binding\". The difference is that we put the &as at the front
+because we need to support improper list binding."
+ (declare (debug ([&or (&rest (sexp form))
+ (vector [&rest [sexp form]])]
+ body))
+ (indent 1))
+ (if (vectorp varlist)
+ `(let* ,(dash--match (aref varlist 0) (aref varlist 1))
+ ,@body)
+ (let* ((inputs (--map-indexed (list (make-symbol (format "input%d" it-index)) (cadr it)) varlist))
+ (new-varlist (--map (list (caar it) (cadr it)) (-zip varlist inputs))))
+ `(let ,inputs
+ (-let* ,new-varlist ,@body)))))
+
+(defmacro -lambda (match-form &rest body)
+ "Return a lambda which destructures its input as MATCH-FORM and executes BODY.
+
+Note that you have to enclose the MATCH-FORM in a pair of parens,
+such that:
+
+ (-lambda (x) body)
+ (-lambda (x y ...) body)
+
+has the usual semantics of `lambda'. Furthermore, these get
+translated into normal lambda, so there is no performance
+penalty.
+
+See `-let' for the description of destructuring mechanism."
+ (declare (doc-string 2) (indent defun)
+ (debug (&define sexp
+ [&optional stringp]
+ [&optional ("interactive" interactive)]
+ def-body)))
+ (cond
+ ((not (consp match-form))
+ (signal 'wrong-type-argument "match-form must be a list"))
+ ;; no destructuring, so just return regular lambda to make things faster
+ ((-all? 'symbolp match-form)
+ `(lambda ,match-form ,@body))
+ (t
+ (let* ((inputs (--map-indexed (list it (make-symbol (format "input%d" it-index))) match-form)))
+ ;; TODO: because inputs to the lambda are evaluated only once,
+ ;; -let* need not to create the extra bindings to ensure that.
+ ;; We should find a way to optimize that. Not critical however.
+ `(lambda ,(--map (cadr it) inputs)
+ (-let* ,inputs ,@body))))))
+
+(defmacro -if-let* (vars-vals then &rest else)
+ "If all VALS evaluate to true, bind them to their corresponding
+VARS and do THEN, otherwise do ELSE. VARS-VALS should be a list
+of (VAR VAL) pairs.
+
+Note: binding is done according to `-let*'. VALS are evaluated
+sequentially, and evaluation stops after the first nil VAL is
+encountered."
+ (declare (debug ((&rest (sexp form)) form body))
+ (indent 2))
+ (->> vars-vals
+ (--mapcat (dash--match (car it) (cadr it)))
+ (--reduce-r-from
+ (let ((var (car it))
+ (val (cadr it)))
+ `(let ((,var ,val))
+ (if ,var ,acc ,@else)))
+ then)))
+
+(defmacro -if-let (var-val then &rest else)
+ "If VAL evaluates to non-nil, bind it to VAR and do THEN,
+otherwise do ELSE.
+
+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 symbol `it' and do THEN,
+otherwise do ELSE."
+ (declare (debug (form form body))
+ (indent 2))
+ `(-if-let (it ,val) ,then ,@else))
+
+(defmacro -when-let* (vars-vals &rest body)
+ "If all VALS evaluate to true, bind them to their corresponding
+VARS and execute body. VARS-VALS should be a list of (VAR VAL)
+pairs.
+
+Note: binding is done according to `-let*'. VALS are evaluated
+sequentially, and evaluation stops after the first nil VAL is
+encountered."
+ (declare (debug ((&rest (sexp form)) body))
+ (indent 1))
+ `(-if-let* ,vars-vals (progn ,@body)))
+
+(defmacro -when-let (var-val &rest body)
+ "If VAL evaluates to non-nil, bind it to VAR and execute body.
+
+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 symbol `it' and
+execute body."
+ (declare (debug (form body))
+ (indent 1))
+ `(--if-let ,val (progn ,@body)))
+
+(defvar -compare-fn nil
+ "Tests for equality use this function or `equal' if this is nil.
+It should only be set using dynamic scope with a let, like:
+
+ (let ((-compare-fn #'=)) (-union numbers1 numbers2 numbers3)")
+
+(defun -distinct (list)
+ "Return a new list with all duplicates removed.
+The test for equality is done with `equal',
+or with `-compare-fn' if that's non-nil.
+
+Alias: `-uniq'"
+ (let (result)
+ (--each list (unless (-contains? result it) (!cons it result)))
+ (nreverse result)))
+
+(defalias '-uniq '-distinct)
+
+(defun -union (list list2)
+ "Return a new list containing the elements of LIST and elements of LIST2 that are not in LIST.
+The test for equality is done with `equal',
+or with `-compare-fn' if that's non-nil."
+ ;; We fall back to iteration implementation if the comparison
+ ;; function isn't one of `eq', `eql' or `equal'.
+ (let* ((result (reverse list))
+ ;; TODO: get rid of this dynamic variable, pass it as an
+ ;; argument instead.
+ (-compare-fn (if (bound-and-true-p -compare-fn)
+ -compare-fn
+ 'equal)))
+ (if (memq -compare-fn '(eq eql equal))
+ (let ((ht (make-hash-table :test -compare-fn)))
+ (--each list (puthash it t ht))
+ (--each list2 (unless (gethash it ht) (!cons it result))))
+ (--each list2 (unless (-contains? result it) (!cons it result))))
+ (nreverse result)))
+
+(defun -intersection (list list2)
+ "Return a new list containing only the elements that are members of both LIST and LIST2.
+The test for equality is done with `equal',
+or with `-compare-fn' if that's non-nil."
+ (--filter (-contains? list2 it) list))
+
+(defun -difference (list list2)
+ "Return a new list with only the members of LIST that are not in LIST2.
+The test for equality is done with `equal',
+or with `-compare-fn' if that's non-nil."
+ (--filter (not (-contains? list2 it)) list))
+
+(defun -powerset (list)
+ "Return the power set of LIST."
+ (if (null list) '(())
+ (let ((last (-powerset (cdr list))))
+ (append (mapcar (lambda (x) (cons (car list) x)) last)
+ last))))
+
+(defun -permutations (list)
+ "Return the permutations of LIST."
+ (if (null list) '(())
+ (apply #'append
+ (mapcar (lambda (x)
+ (mapcar (lambda (perm) (cons x perm))
+ (-permutations (remove x list))))
+ list))))
+
+(defun -contains? (list element)
+ "Return non-nil if LIST contains ELEMENT.
+
+The test for equality is done with `equal', or with `-compare-fn'
+if that's non-nil.
+
+Alias: `-contains-p'"
+ (not
+ (null
+ (cond
+ ((null -compare-fn) (member element list))
+ ((eq -compare-fn 'eq) (memq element list))
+ ((eq -compare-fn 'eql) (memql element list))
+ (t
+ (let ((lst list))
+ (while (and lst
+ (not (funcall -compare-fn element (car lst))))
+ (setq lst (cdr lst)))
+ lst))))))
+
+(defalias '-contains-p '-contains?)
+
+(defun -same-items? (list list2)
+ "Return true if LIST and LIST2 has the same items.
+
+The order of the elements in the lists does not matter.
+
+Alias: `-same-items-p'"
+ (let ((length-a (length list))
+ (length-b (length list2)))
+ (and
+ (= length-a length-b)
+ (= length-a (length (-intersection list list2))))))
+
+(defalias '-same-items-p '-same-items?)
+
+(defun -is-prefix? (prefix list)
+ "Return non-nil if PREFIX is prefix of LIST.
+
+Alias: `-is-prefix-p'"
+ (declare (pure t) (side-effect-free t))
+ (--each-while list (equal (car prefix) it)
+ (!cdr prefix))
+ (not prefix))
+
+(defun -is-suffix? (suffix list)
+ "Return non-nil if SUFFIX is suffix of LIST.
+
+Alias: `-is-suffix-p'"
+ (declare (pure t) (side-effect-free t))
+ (-is-prefix? (reverse suffix) (reverse list)))
+
+(defun -is-infix? (infix list)
+ "Return non-nil if INFIX is infix of LIST.
+
+This operation runs in O(n^2) time
+
+Alias: `-is-infix-p'"
+ (declare (pure t) (side-effect-free t))
+ (let (done)
+ (while (and (not done) list)
+ (setq done (-is-prefix? infix list))
+ (!cdr list))
+ done))
+
+(defalias '-is-prefix-p '-is-prefix?)
+(defalias '-is-suffix-p '-is-suffix?)
+(defalias '-is-infix-p '-is-infix?)
+
+(defun -sort (comparator list)
+ "Sort LIST, stably, comparing elements using COMPARATOR.
+Return the sorted list. LIST is NOT modified by side effects.
+COMPARATOR is called with two elements of LIST, and should return non-nil
+if the first element should sort before the second."
+ (sort (copy-sequence list) comparator))
+
+(defmacro --sort (form list)
+ "Anaphoric form of `-sort'."
+ (declare (debug (form form)))
+ `(-sort (lambda (it other) ,form) ,list))
+
+(defun -list (&rest args)
+ "Return a list with ARGS.
+
+If first item of ARGS is already a list, simply return ARGS. If
+not, return a list with ARGS as elements."
+ (declare (pure t) (side-effect-free t))
+ (let ((arg (car args)))
+ (if (listp arg) arg args)))
+
+(defun -repeat (n x)
+ "Return a list with X repeated N times.
+Return nil if N is less than 1."
+ (declare (pure t) (side-effect-free t))
+ (let (ret)
+ (--dotimes n (!cons x ret))
+ ret))
+
+(defun -sum (list)
+ "Return the sum of LIST."
+ (declare (pure t) (side-effect-free t))
+ (apply '+ list))
+
+(defun -product (list)
+ "Return the product of LIST."
+ (declare (pure t) (side-effect-free t))
+ (apply '* list))
+
+(defun -max (list)
+ "Return the largest value from LIST of numbers or markers."
+ (declare (pure t) (side-effect-free t))
+ (apply 'max list))
+
+(defun -min (list)
+ "Return the smallest value from LIST of numbers or markers."
+ (declare (pure t) (side-effect-free t))
+ (apply 'min list))
+
+(defun -max-by (comparator list)
+ "Take a comparison function COMPARATOR and a LIST and return
+the greatest element of the list by the comparison function.
+
+See also combinator `-on' which can transform the values before
+comparing them."
+ (--reduce (if (funcall comparator it acc) it acc) list))
+
+(defun -min-by (comparator list)
+ "Take a comparison function COMPARATOR and a LIST and return
+the least element of the list by the comparison function.
+
+See also combinator `-on' which can transform the values before
+comparing them."
+ (--reduce (if (funcall comparator it acc) acc it) list))
+
+(defmacro --max-by (form list)
+ "Anaphoric version of `-max-by'.
+
+The items for the comparator form are exposed as \"it\" and \"other\"."
+ (declare (debug (form form)))
+ `(-max-by (lambda (it other) ,form) ,list))
+
+(defmacro --min-by (form list)
+ "Anaphoric version of `-min-by'.
+
+The items for the comparator form are exposed as \"it\" and \"other\"."
+ (declare (debug (form form)))
+ `(-min-by (lambda (it other) ,form) ,list))
+
+(defun -iterate (fun init n)
+ "Return a list of iterated applications of FUN to INIT.
+
+This means a list of form:
+
+ (init (fun init) (fun (fun init)) ...)
+
+N is the length of the returned list."
+ (if (= n 0) nil
+ (let ((r (list init)))
+ (--dotimes (1- n)
+ (push (funcall fun (car r)) r))
+ (nreverse r))))
+
+(defun -fix (fn list)
+ "Compute the (least) fixpoint of FN with initial input LIST.
+
+FN is called at least once, results are compared with `equal'."
+ (let ((re (funcall fn list)))
+ (while (not (equal list re))
+ (setq list re)
+ (setq re (funcall fn re)))
+ re))
+
+(defmacro --fix (form list)
+ "Anaphoric form of `-fix'."
+ `(-fix (lambda (it) ,form) ,list))
+
+(defun -unfold (fun seed)
+ "Build a list from SEED using FUN.
+
+This is \"dual\" operation to `-reduce-r': while -reduce-r
+consumes a list to produce a single value, `-unfold' takes a
+seed value and builds a (potentially infinite!) list.
+
+FUN should return `nil' to stop the generating process, or a
+cons (A . B), where A will be prepended to the result and B is
+the new seed."
+ (let ((last (funcall fun seed)) r)
+ (while last
+ (push (car last) r)
+ (setq last (funcall fun (cdr last))))
+ (nreverse r)))
+
+(defmacro --unfold (form seed)
+ "Anaphoric version of `-unfold'."
+ (declare (debug (form form)))
+ `(-unfold (lambda (it) ,form) ,seed))
+
+(defun -cons-pair? (con)
+ "Return non-nil if CON is true cons pair.
+That is (A . B) where B is not a list."
+ (declare (pure t) (side-effect-free t))
+ (and (listp con)
+ (not (listp (cdr con)))))
+
+(defun -cons-to-list (con)
+ "Convert a cons pair to a list with `car' and `cdr' of the pair respectively."
+ (declare (pure t) (side-effect-free t))
+ (list (car con) (cdr con)))
+
+(defun -value-to-list (val)
+ "Convert a value to a list.
+
+If the value is a cons pair, make a list with two elements, `car'
+and `cdr' of the pair respectively.
+
+If the value is anything else, wrap it in a list."
+ (declare (pure t) (side-effect-free t))
+ (cond
+ ((-cons-pair? val) (-cons-to-list val))
+ (t (list val))))
+
+(defun -tree-mapreduce-from (fn folder init-value tree)
+ "Apply FN to each element of TREE, and make a list of the results.
+If elements of TREE are lists themselves, apply FN recursively to
+elements of these nested lists.
+
+Then reduce the resulting lists using FOLDER and initial value
+INIT-VALUE. See `-reduce-r-from'.
+
+This is the same as calling `-tree-reduce-from' after `-tree-map'
+but is twice as fast as it only traverse the structure once."
+ (cond
+ ((not tree) nil)
+ ((-cons-pair? tree) (funcall fn tree))
+ ((listp tree)
+ (-reduce-r-from folder init-value (mapcar (lambda (x) (-tree-mapreduce-from fn folder init-value x)) tree)))
+ (t (funcall fn tree))))
+
+(defmacro --tree-mapreduce-from (form folder init-value tree)
+ "Anaphoric form of `-tree-mapreduce-from'."
+ (declare (debug (form form form form)))
+ `(-tree-mapreduce-from (lambda (it) ,form) (lambda (it acc) ,folder) ,init-value ,tree))
+
+(defun -tree-mapreduce (fn folder tree)
+ "Apply FN to each element of TREE, and make a list of the results.
+If elements of TREE are lists themselves, apply FN recursively to
+elements of these nested lists.
+
+Then reduce the resulting lists using FOLDER and initial value
+INIT-VALUE. See `-reduce-r-from'.
+
+This is the same as calling `-tree-reduce' after `-tree-map'
+but is twice as fast as it only traverse the structure once."
+ (cond
+ ((not tree) nil)
+ ((-cons-pair? tree) (funcall fn tree))
+ ((listp tree)
+ (-reduce-r folder (mapcar (lambda (x) (-tree-mapreduce fn folder x)) tree)))
+ (t (funcall fn tree))))
+
+(defmacro --tree-mapreduce (form folder tree)
+ "Anaphoric form of `-tree-mapreduce'."
+ (declare (debug (form form form)))
+ `(-tree-mapreduce (lambda (it) ,form) (lambda (it acc) ,folder) ,tree))
+
+(defun -tree-map (fn tree)
+ "Apply FN to each element of TREE while preserving the tree structure."
+ (cond
+ ((not tree) nil)
+ ((-cons-pair? tree) (funcall fn tree))
+ ((listp tree)
+ (mapcar (lambda (x) (-tree-map fn x)) tree))
+ (t (funcall fn tree))))
+
+(defmacro --tree-map (form tree)
+ "Anaphoric form of `-tree-map'."
+ (declare (debug (form form)))
+ `(-tree-map (lambda (it) ,form) ,tree))
+
+(defun -tree-reduce-from (fn init-value tree)
+ "Use FN to reduce elements of list TREE.
+If elements of TREE are lists themselves, apply the reduction recursively.
+
+FN is first applied to INIT-VALUE and first element of the list,
+then on this result and second element from the list etc.
+
+The initial value is ignored on cons pairs as they always contain
+two elements."
+ (cond
+ ((not tree) nil)
+ ((-cons-pair? tree) tree)
+ ((listp tree)
+ (-reduce-r-from fn init-value (mapcar (lambda (x) (-tree-reduce-from fn init-value x)) tree)))
+ (t tree)))
+
+(defmacro --tree-reduce-from (form init-value tree)
+ "Anaphoric form of `-tree-reduce-from'."
+ (declare (debug (form form form)))
+ `(-tree-reduce-from (lambda (it acc) ,form) ,init-value ,tree))
+
+(defun -tree-reduce (fn tree)
+ "Use FN to reduce elements of list TREE.
+If elements of TREE are lists themselves, apply the reduction recursively.
+
+FN is first applied to first element of the list and second
+element, then on this result and third element from the list etc.
+
+See `-reduce-r' for how exactly are lists of zero or one element handled."
+ (cond
+ ((not tree) nil)
+ ((-cons-pair? tree) tree)
+ ((listp tree)
+ (-reduce-r fn (mapcar (lambda (x) (-tree-reduce fn x)) tree)))
+ (t tree)))
+
+(defmacro --tree-reduce (form tree)
+ "Anaphoric form of `-tree-reduce'."
+ (declare (debug (form form)))
+ `(-tree-reduce (lambda (it acc) ,form) ,tree))
+
+(defun -tree-map-nodes (pred fun tree)
+ "Call FUN on each node of TREE that satisfies PRED.
+
+If PRED returns nil, continue descending down this node. If PRED
+returns non-nil, apply FUN to this node and do not descend
+further."
+ (if (funcall pred tree)
+ (funcall fun tree)
+ (if (and (listp tree)
+ (not (-cons-pair? tree)))
+ (-map (lambda (x) (-tree-map-nodes pred fun x)) tree)
+ tree)))
+
+(defmacro --tree-map-nodes (pred form tree)
+ "Anaphoric form of `-tree-map-nodes'."
+ `(-tree-map-nodes (lambda (it) ,pred) (lambda (it) ,form) ,tree))
+
+(defun -tree-seq (branch children tree)
+ "Return a sequence of the nodes in TREE, in depth-first search order.
+
+BRANCH is a predicate of one argument that returns non-nil if the
+passed argument is a branch, that is, a node that can have children.
+
+CHILDREN is a function of one argument that returns the children
+of the passed branch node.
+
+Non-branch nodes are simply copied."
+ (cons tree
+ (when (funcall branch tree)
+ (-mapcat (lambda (x) (-tree-seq branch children x))
+ (funcall children tree)))))
+
+(defmacro --tree-seq (branch children tree)
+ "Anaphoric form of `-tree-seq'."
+ `(-tree-seq (lambda (it) ,branch) (lambda (it) ,children) ,tree))
+
+(defun -clone (list)
+ "Create a deep copy of LIST.
+The new list has the same elements and structure but all cons are
+replaced with new ones. This is useful when you need to clone a
+structure such as plist or alist."
+ (declare (pure t) (side-effect-free t))
+ (-tree-map 'identity list))
+
+(defun dash-enable-font-lock ()
+ "Add syntax highlighting to dash functions, macros and magic values."
+ (eval-after-load 'lisp-mode
+ '(progn
+ (let ((new-keywords '(
+ "-each"
+ "--each"
+ "-each-indexed"
+ "--each-indexed"
+ "-each-while"
+ "--each-while"
+ "-dotimes"
+ "--dotimes"
+ "-map"
+ "--map"
+ "-reduce-from"
+ "--reduce-from"
+ "-reduce"
+ "--reduce"
+ "-reduce-r-from"
+ "--reduce-r-from"
+ "-reduce-r"
+ "--reduce-r"
+ "-filter"
+ "--filter"
+ "-select"
+ "--select"
+ "-remove"
+ "--remove"
+ "-reject"
+ "--reject"
+ "-remove-first"
+ "--remove-first"
+ "-reject-first"
+ "--reject-first"
+ "-remove-last"
+ "--remove-last"
+ "-reject-last"
+ "--reject-last"
+ "-remove-item"
+ "-non-nil"
+ "-keep"
+ "--keep"
+ "-map-indexed"
+ "--map-indexed"
+ "-splice"
+ "--splice"
+ "-splice-list"
+ "--splice-list"
+ "-map-when"
+ "--map-when"
+ "-replace-where"
+ "--replace-where"
+ "-map-first"
+ "--map-first"
+ "-map-last"
+ "--map-last"
+ "-replace"
+ "-replace-first"
+ "-replace-last"
+ "-flatten"
+ "-flatten-n"
+ "-concat"
+ "-mapcat"
+ "--mapcat"
+ "-copy"
+ "-cons*"
+ "-snoc"
+ "-first"
+ "--first"
+ "-find"
+ "--find"
+ "-some"
+ "--some"
+ "-any"
+ "--any"
+ "-last"
+ "--last"
+ "-first-item"
+ "-last-item"
+ "-butlast"
+ "-count"
+ "--count"
+ "-any?"
+ "--any?"
+ "-some?"
+ "--some?"
+ "-any-p"
+ "--any-p"
+ "-some-p"
+ "--some-p"
+ "-all?"
+ "--all?"
+ "-every?"
+ "--every?"
+ "-all-p"
+ "--all-p"
+ "-every-p"
+ "--every-p"
+ "-none?"
+ "--none?"
+ "-none-p"
+ "--none-p"
+ "-only-some?"
+ "--only-some?"
+ "-only-some-p"
+ "--only-some-p"
+ "-slice"
+ "-take"
+ "-drop"
+ "-take-while"
+ "--take-while"
+ "-drop-while"
+ "--drop-while"
+ "-split-at"
+ "-rotate"
+ "-insert-at"
+ "-replace-at"
+ "-update-at"
+ "--update-at"
+ "-remove-at"
+ "-remove-at-indices"
+ "-split-with"
+ "--split-with"
+ "-split-on"
+ "-split-when"
+ "--split-when"
+ "-separate"
+ "--separate"
+ "-partition-all-in-steps"
+ "-partition-in-steps"
+ "-partition-all"
+ "-partition"
+ "-partition-by"
+ "--partition-by"
+ "-partition-by-header"
+ "--partition-by-header"
+ "-group-by"
+ "--group-by"
+ "-interpose"
+ "-interleave"
+ "-zip-with"
+ "--zip-with"
+ "-zip"
+ "-zip-fill"
+ "-cycle"
+ "-pad"
+ "-annotate"
+ "--annotate"
+ "-table"
+ "-table-flat"
+ "-partial"
+ "-elem-index"
+ "-elem-indices"
+ "-find-indices"
+ "--find-indices"
+ "-find-index"
+ "--find-index"
+ "-find-last-index"
+ "--find-last-index"
+ "-select-by-indices"
+ "-select-columns"
+ "-select-column"
+ "-grade-up"
+ "-grade-down"
+ "->"
+ "->>"
+ "-->"
+ "-when-let"
+ "-when-let*"
+ "--when-let"
+ "-if-let"
+ "-if-let*"
+ "--if-let"
+ "-let*"
+ "-let"
+ "-lambda"
+ "-distinct"
+ "-uniq"
+ "-union"
+ "-intersection"
+ "-difference"
+ "-contains?"
+ "-contains-p"
+ "-same-items?"
+ "-same-items-p"
+ "-is-prefix-p"
+ "-is-prefix?"
+ "-is-suffix-p"
+ "-is-suffix?"
+ "-is-infix-p"
+ "-is-infix?"
+ "-sort"
+ "--sort"
+ "-list"
+ "-repeat"
+ "-sum"
+ "-product"
+ "-max"
+ "-min"
+ "-max-by"
+ "--max-by"
+ "-min-by"
+ "--min-by"
+ "-iterate"
+ "--iterate"
+ "-fix"
+ "--fix"
+ "-unfold"
+ "--unfold"
+ "-cons-pair?"
+ "-cons-to-list"
+ "-value-to-list"
+ "-tree-mapreduce-from"
+ "--tree-mapreduce-from"
+ "-tree-mapreduce"
+ "--tree-mapreduce"
+ "-tree-map"
+ "--tree-map"
+ "-tree-reduce-from"
+ "--tree-reduce-from"
+ "-tree-reduce"
+ "--tree-reduce"
+ "-tree-seq"
+ "--tree-seq"
+ "-tree-map-nodes"
+ "--tree-map-nodes"
+ "-clone"
+ "-rpartial"
+ "-juxt"
+ "-applify"
+ "-on"
+ "-flip"
+ "-const"
+ "-cut"
+ "-orfn"
+ "-andfn"
+ "-iteratefn"
+ "-fixfn"
+ "-prodfn"
+ ))
+ (special-variables '(
+ "it"
+ "it-index"
+ "acc"
+ "other"
+ )))
+ (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "\\_<" (regexp-opt special-variables 'paren) "\\_>")
+ 1 font-lock-variable-name-face)) 'append)
+ (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "(\\s-*" (regexp-opt new-keywords 'paren) "\\_>")
+ 1 font-lock-keyword-face)) 'append))
+ (--each (buffer-list)
+ (with-current-buffer it
+ (when (and (eq major-mode 'emacs-lisp-mode)
+ (boundp 'font-lock-mode)
+ font-lock-mode)
+ (font-lock-refresh-defaults)))))))
+
+(provide 'dash)
+;;; dash.el ends here
--- /dev/null
+;;; gnuplot-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (autoloads nil nil ("gnuplot-context.el" "gnuplot-gui.el"
+;;;;;; "gnuplot-pkg.el") (22842 31129 0 0))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; gnuplot-autoloads.el ends here
--- /dev/null
+;;; gnuplot-context.el -- context-sensitive help and completion for gnuplot
+
+;; Copyright (C) 2012-2013 Jon Oddie <jonxfieldNOSPAMgmail.com>
+
+;; Author: Jon Oddie <jonxfieldNOSPAMgmail.com>
+;; Maintainer: Jon Oddie <jonxfieldNOSPAMgmail.com>
+;; 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 (jonxfieldNOSPAMgmail.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:
+
+\f
+;; 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)))))
+
+\f
+;;;; 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)))
+
+
+\f
+;;;; 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: [{<dummy>=}<min>:<max>]") axis-range])
+ (y-axis-range [(:eldoc "Y RANGE: [{<dummy>=}<min>:<max>]") axis-range])
+ (z-axis-range [(:eldoc "Z RANGE: [{<dummy>=}<min>:<max>]") axis-range])
+ (t-axis-range [(:eldoc "T RANGE: [{<dummy>=}<min>:<max>]") axis-range])
+ (u-axis-range [(:eldoc "U RANGE: [{<dummy>=}<min>:<max>]") axis-range])
+ (v-axis-range [(:eldoc "V RANGE: [{<dummy>=}<min>:<max>]") 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))))
+
+\f
+;; 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))))
+
+
+\f
+;;;; 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.")
+
+\f
+;;;; 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 " "))))
+
+\f
+;;; 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))
+
+\f
+;;; 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))
+ "<columns>"))))
+ (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)))
+
+
+\f
+;;; All done!
+(provide 'gnuplot-context)
+
+;;; gnuplot-context.el ends here
--- /dev/null
+;;;; gnuplot-gui.el -- GUI interface to setting options in gnuplot-mode
+
+;; Copyright (C) 1998-2000 Bruce Ravel
+
+;; Author: Bruce Ravel <ravelNOSPAMphys.washington.edu>
+;; Maintainer: Bruce Ravel <ravelNOSPAMphys.washington.edu>
+;; 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 (ravelNOSPAMphys.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)))) ))
+
+
+\f
+;;; 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)
+
+\f
+;;; 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)))))
+
+
+\f
+;;; 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) <MT>
+ '(("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 <MT>
+ (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) )
+
+
+
+\f
+;;; 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))
+
+
+\f
+;;; 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))) )))
+
+\f
+;;; 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))
+
+\f
+;;; 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 ; <HW>
+ (gnuplot-setup-info-look))
+ (gnuplot-info-lookup-symbol (widget-value widget)
+ 'gnuplot-mode))))
+
+\f
+;;; just about done
+
+(provide 'gnuplot-gui)
+;;;============================================================================
+;;;
+;;; gnuplot-gui.el ends here
--- /dev/null
+(define-package "gnuplot" "20141231.1337" "drive gnuplot from within emacs" 'nil :keywords
+ '("gnuplot" "plotting"))
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
--- /dev/null
+;;; gnuplot.el --- drive gnuplot from within emacs
+
+;; Copyright (C) 1998, 2011 Phil Type and Bruce Ravel, 1999-2012 Bruce Ravel
+
+;; Author: Bruce Ravel <bruceravel1NOSPAMgmail.com> and Phil Type
+;; Maintainer: Bruce Ravel <bruceravel1NOSPAMgmail.com>
+;; 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 (bruceravel1NOSPAMgmail.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.oddieNOSPAMgmail.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. <BR>
+;; 0.2a Sep 11 1998 made `indent-line-function' buffer-local (whoops!)
+;; and fixed some stuff in the installation script <BR>
+;; 0.3 Sep 12 1998 include insertions menu <BR>
+;; 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 <BR>
+;; 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 <DB> Some changes to font-lock rules <LB>&<BR>
+;; 0.4 Nov 14 1998 <BR> 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 <BR> 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 <MD>.
+;; 0.4b Nov 21 1998 <BR> 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 <BR> fixed highlighting in comint
+;; buffer. fixed frame behavior. added "[:]" to range
+;; insertions. added :link to defgroup. Dec 1 1998 <BR> fixed
+;; some mismatched defcustoms. added a few lines to suppress
+;; some compile-time warnings. Dec 3 1998 <BR> Fixed behavior
+;; of filename insertion function. Added more :links to
+;; defgroup.
+;; 0.4d Dec 6 1998 <BR> 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 <BR> Split up gnuplot-insertions-menu for ease of
+;; custimization, put menubar initialization in a function.
+;; 0.4f Dec 14 1998 <BR> defcustom the insertions submenus, add
+;; gnuplot-insertion-menu-flag, intelligent Makefile knows
+;; which info-look to compile
+;; 0.5 Dec 27 1998 <BR> 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 <BR>
+;; 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 <BR> 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 <BR> adopt installation materials from <LH>. 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 <BR> at the suggestion of <SE> 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 <BR> 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 <BR> 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 <BR> 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
+;; <KL>
+;; 0.5h Aug 15 1999 <BR> 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 <BR> 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 <BR> Do a more robust check for the gnuplot
+;; process before killing the gnuplot buffer, as suggested by
+;; <SE>.
+;; 0.5k Sep 22 1999 <BR> make `gnuplot-send-line-and-forward' skip
+;; over blank and comment lines as suggested by <SE>. Jan 10
+;; 2000 Bound C-c C-j to `gnuplot-forward-script-line'.
+;; 0.5l Nov 16 2000 <BR> 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 <BR> 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 <BR> corrected a serious problem interacting with
+;; speedbar
+;; 0.5o skipped
+;; 0.5p Mar 14 2001 <BR> fixed problem with toolbar creation and
+;; speedbar clicking
+;; 0.5q May 30 2001 <BR> added font-lock bindings for words associated
+;; with plotting
+;; 0.5r Oct 17 2001 <BR> Incorporate two suggestions by <RF>, 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 <BR> added feature to trim length of gnuplot
+;; process buffer
+;; 0.5s Jun 7 2002 <BR> 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 <BR> Fixed a problem with C-c C-v jumping
+;; forward 2 lines at a time
+;; 0.6.0 Dec 13 2002 <BR> Changed numbering scheme to accommodate
+;; gnuplot packaging requirements
+;; 0.6.1 Sep 13 2011 <BR> Moved to github, updated contact info
+;; 0.7.0 Oct 20 2012 <jjo> Contextual completion & help, inline plots,
+;; some other stuff
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Acknowledgements:
+;; David Batty <DB> (numerous corrections)
+;; Laurent Bonnaud <LB> (suggestions regarding font-lock rules)
+;; Markus Dickebohm <MD> (suggested `gnuplot-send-line-and-forward')
+;; Stephen Eglan <SE> (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 <RF> (suggested respecting continuation lines)
+;; Michael Karbach <MK> (suggested trimming the gnuplot process buffer)
+;; Alex Chan Libchen <AL> (suggested font-lock for plotting words)
+;; Kuang-Yu Liu <KL> (pointed out buggy dependence on font-lock)
+;; Hrvoje Niksic <HN> (help with defcustom arguments for insertions)
+;; Andreas Rechtsteiner <AR> (pointed out problem with C-c C-v)
+;; Michael Sanders <MS> (help with the info-look interface)
+;; Jinwei Shen <JS> (suggested functionality in comint buffer)
+;; Michael M. Tung <MT> (prompted me to add pm3d support)
+;; Holger Wenzel <HW> (suggested using `gnuplot-keywords-when')
+;; Wolfgang Zocher <WZ> (pointed out problem with gnuplot-mode + speedbar)
+;; Jon Oddie <jjo> (indentation, inline images, context mode)
+;;
+;; and especially to Lars Hecking <LH> 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")
+
+\f
+;;; --- variable definitions + eval-and-compile clauses
+
+;; We no longer hack around ancient versions of Customize with macros
+(require 'custom)
+
+(eval-and-compile ;; <DB>
+ (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)))))
+
+\f
+;;;;
+(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 "bruceravel1NOSPAMgmail.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 <DB>
+(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 ;; <HW>
+ "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 <FORMAT>\". 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)
+
+\f
+;;; --- 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) ; <RF>
+ (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'.")
+
+
+\f
+;;; --- 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] ; <MT>
+ ["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 <DB>:
+;;
+;; 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 <DB>
+(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)))
+
+\f
+;;; --- 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)
+
+
+\f
+;;; --- 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) ; <KL>
+ (setq gnuplot-font-lock-keywords
+ (list
+ ;; stuff in brackets, sugg. by <LB>
+ '("\\[\\([^]]+\\)\\]" 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 <AL>
+ (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
+ '("\\<s?plot\\>" . font-lock-keyword-face)
+ ;; '("\\<s?plot\\s-+\\([^'\" ]+\\)[) \n,\\\\]"
+ ;; 1 font-lock-variable-name-face)
+
+ ;; other common commands
+ (cons (gnuplot-make-regexp gnuplot-keywords-misc)
+ font-lock-constant-face)
+ (cons "!.*$" font-lock-constant-face))) ; what is this for? jjo
+
+ (setq gnuplot-font-lock-defaults
+ '(gnuplot-font-lock-keywords
+ nil ; Use syntactic fontification
+ t ; Use case folding
+ nil ; No extra syntax
+ ;; calls `gnuplot-beginning-of-continuation'
+ ;; to find a safe place to begin syntactic highlighting
+ beginning-of-defun))
+
+ ;; Set up font-lock for Xemacs
+ ;; For GNU Emacs, this is done in `gnuplot-mode'
+ (if gnuplot-xemacs-p
+ (put 'gnuplot-mode 'font-lock-defaults
+ gnuplot-font-lock-defaults)))
+
+;; Some corner cases in Gnuplot's comment and string syntax are
+;; difficult to handle accurately using Emacs's built-in syntax tables
+;; and parser:
+;;
+;; - strings can continue over several lines, but only by using a
+;; backslash to escape the newline
+;;
+;; - double-quoted strings can contain escaped quotes, \", and escaped
+;; backslashes, \\; but in single-quoted strings the quote is
+;; escaped by doubling it, '', and backslash is only special at
+;; end-of-line
+;;
+;; - either type of string can end at newline without needing a
+;; - closing delimiter
+;;
+;; - comments continue over continuation lines
+;;
+;; The following syntax-propertize rules should accurately mark string
+;; and comment boundaries using the "generic string fence" and
+;; "generic comment fence" syntax properties. When syntax-propertize
+;; is unavailable (on Emacs versions <24), we fall back to using the
+;; normal syntax-table parser, which is accurate enough for most
+;; normal cases. (See the definition of `gnuplot-mode-syntax-table'.)
+(defalias 'gnuplot-syntax-propertize
+ (when (fboundp 'syntax-propertize-rules)
+ (syntax-propertize-rules
+ ;; Double quoted strings
+ ((rx
+ (group "\"")
+ (* (or (seq "\\" anything)
+ (not (any "\"" "\n"))))
+ (group (or "\"" "\n" buffer-end)))
+ (1 "|") (2 "|"))
+
+ ;; Single quoted strings
+ ((rx
+ (group "'")
+ (* (or (seq "\\" "\n")
+ "''"
+ (not (any "'" "\n"))))
+ (group (or "'" "\n" buffer-end)))
+ (1 "|") (2 "|"))
+
+ ;; Comments
+ ((rx
+ (group "#")
+ (* (or (seq "\\" "\n")
+ any))
+ (or (group "\n") buffer-end))
+ (1 "!") (2 "!")))))
+
+(defun gnuplot-syntax-propertize-extend-region (start end)
+ "Expand the region to syntax-propertize for strings and comments.
+
+Ensures that the region being searched begins and ends outside of
+any lines continued with a backslash.
+
+This function is added to
+`syntax-propertize-extend-region-functions' in gnuplot-mode
+buffers."
+ (let ((continuation-start
+ (min start
+ (gnuplot-point-at-beginning-of-continuation start)))
+ (continuation-end
+ (max end
+ (gnuplot-point-at-end-of-continuation end))))
+ (if (and (= continuation-start start)
+ (= continuation-end end))
+ nil
+ (cons continuation-start continuation-end))))
+
+;; Parsing utilities to tell if we are inside a string or comment
+(defun gnuplot-in-string (&optional where)
+ "Returns non-nil if the text at WHERE is within a string.
+
+If WHERE is omitted, defaults to text at point.
+This is a simple wrapper for `syntax-ppss'."
+ (save-excursion
+ (let ((parse-state (gnuplot-syntax-ppss where)))
+ (nth 3 parse-state))))
+
+(defun gnuplot-in-comment (&optional where)
+ "Returns non-nil if the text at WHERE is within a comment.
+
+If WHERE is omitted, defaults to text at point.
+This is a simple wrapper for `syntax-ppss'."
+ (save-excursion
+ (let ((parse-state (gnuplot-syntax-ppss where)))
+ (nth 4 parse-state))))
+
+(defun gnuplot-in-string-or-comment (&optional where)
+ "Returns non-nil if the text at WHERE is within a string or comment.
+
+If WHERE is omitted, defaults to text at point.
+This is a simple wrapper for `syntax-ppss'."
+
+ (save-excursion
+ (let ((parse-state (gnuplot-syntax-ppss where)))
+ (or (nth 3 parse-state)
+ (nth 4 parse-state)))))
+
+;; these two lines get rid of an annoying compile time error
+;; message. that function gets non-trivially defalias-ed in
+;; gnuplot-toolbar.el
+;; (defun gnuplot-make-toolbar-dummy ())
+;; (defalias 'gnuplot-make-toolbar 'gnuplot-make-toolbar-dummy)
+
+\f
+;;; --- functions for sending commands to gnuplot
+
+(defun gnuplot-split-string (string)
+ "Break STRING at each carriage return, returning a list of lines."
+ (let ((list ()) (line "") (index 0))
+ (while (< index (length string))
+ (if (char-equal (elt string index) ?\n)
+ (setq list (append list (list line))
+ line "")
+ (setq line (concat line (char-to-string (elt string index)))))
+ (setq index (1+ index)) )
+ list))
+
+;; -- the calls to `sleep-for' are to allow enough time for gnuplot
+;; to write to the buffer before the next line is inserted
+;; -- note that the input string is split into lines and each line is
+;; sent to gnuplot individually. this is a bit slow, but it puts
+;; each line on the comint history.
+(defun gnuplot-send-string-to-gnuplot (string text)
+ "Sends STRING to the gnuplot program.
+If no gnuplot process exists, a new one is created. TEXT indicates
+the type of text being sent to gnuplot and is typically one of
+nil, 'line, 'region, 'buffer, or 'file. TEXT may be useful for
+functions in `gnuplot-after-plot-hook'. `gnuplot-after-plot-hook' is
+called by this function after all of STRING is sent to gnuplot."
+ (gnuplot-make-gnuplot-buffer) ; make sure a gnuplot buffer exists
+ (gnuplot-fetch-version-number)
+ (setq gnuplot-comint-recent-buffer (current-buffer))
+
+ ;; Create a gnuplot frame if needed
+ (if (equal gnuplot-display-process 'frame)
+ (or (and gnuplot-process-frame
+ (frame-live-p gnuplot-process-frame))
+ (let ((frame (selected-frame)))
+ (setq gnuplot-process-frame (make-frame))
+ (select-frame gnuplot-process-frame)
+ (switch-to-buffer gnuplot-buffer)
+ (delete-other-windows)
+ (select-frame frame))))
+
+ (let ((list (gnuplot-split-string string)))
+ (with-current-buffer (get-buffer gnuplot-buffer)
+ (goto-char (point-max))
+ ;; bruce asks: what is this next line for?
+ (set-marker (process-mark gnuplot-process) (point-marker))
+ (sleep-for (* 20 gnuplot-delay))
+ (while list
+ (insert (car list))
+ (comint-send-input)
+ (sleep-for gnuplot-delay)
+ (setq list (cdr list))
+ (goto-char (point-max))))
+
+ (cond ((equal gnuplot-display-process 'window)
+ (gnuplot-display-and-recenter-gnuplot-buffer))
+ ((equal gnuplot-display-process 'frame)
+ ;;(raise-frame gnuplot-process-frame)
+ (with-selected-frame gnuplot-process-frame
+ (gnuplot-display-and-recenter-gnuplot-buffer))))
+
+ (setq gnuplot-recently-sent text)
+ (run-hooks 'gnuplot-after-plot-hook)))
+
+(defun gnuplot-display-and-recenter-gnuplot-buffer ()
+ "Make sure the gnuplot comint buffer is displayed, and
+move point to the end if necessary"
+ (save-selected-window
+ (select-window (display-buffer (get-buffer gnuplot-buffer)))
+ (goto-char (point-max))
+ (unless (pos-visible-in-window-p (point) (selected-window)) (recenter 5))))
+
+(defun gnuplot-send-region-to-gnuplot (&optional begin end text)
+ "Sends a selected region to the gnuplot program.
+If BEGIN and END are not specified, point and mark are used. TEXT
+indicates the type of text being sent to gnuplot. This will be
+'region unless explicitly set by a function calling this one. Other
+typical values are of nil, 'line, 'buffer, or 'file. TEXT may be
+useful for function in `gnuplot-after-plot-hook'."
+ (interactive "r")
+ (let (string (txt (or text 'region)))
+ (cond ((equal major-mode 'gnuplot-mode)
+ (setq string (buffer-substring-no-properties begin end))
+ (if (string= (substring string -1) "\n") ()
+ (setq string (concat string "\n")))
+ (gnuplot-send-string-to-gnuplot string txt))
+ (t
+ (message (concat "You can only send regions from "
+ "gnuplot-mode buffers to gnuplot."))))))
+
+(defun gnuplot-send-line-to-gnuplot ()
+ "Sends the current line to the gnuplot program.
+Respects continuation lines.
+This sets `gnuplot-recently-sent' to 'line."
+ (interactive)
+ (cond ((equal major-mode 'gnuplot-mode)
+ (let (start end)
+ (save-excursion
+ ;; go to start of continued command, or beginning of line
+ ;; if this is not a continuation of a previous line <JJO>
+ (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) ; <AR>
+ (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) ; <SE>
+ "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 <JS>
+(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)
+
+\f
+;;; --- 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)) ; <SE>
+ (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)) ;; <SE>
+ (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))))
+
+\f
+;;; 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))))
+ "")
+
+
+\f
+;;; --- 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.")))
+
+
+\f
+;;; --- help from the info file, keyword list + completion, insert function
+
+
+;; set up stuff for info-look (as suggested by <SE>)
+;; modified with suggestion from <MS>
+(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 <jjo>
+ (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 <jjo>
+ (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 ))
+
+\f
+;;;; 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 ; <HW>
+ (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)))
+
+\f
+(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 ; <HW>
+ (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 <jjo>
+ ;; 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 ; <HW>
+ (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.")))
+
+\f
+;;; --- 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)
+ ))))
+
+
+\f
+;;; --- 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) ; <HW>
+ (gnuplot-setup-info-look)) ;; <SE>
+
+ (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! ----------------------------------------------------------------
+
+\f
+;;; --- final chores: provide 'gnuplot and run load-hook
+;; provide before run-hooks suggested by <DB>
+(provide 'gnuplot)
+(run-hooks 'gnuplot-load-hook)
+
+;;;============================================================================
+;;;
+
+;;; gnuplot.el ends here
--- /dev/null
+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.oddieNOSPAMgmail.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.
--- /dev/null
+;;; hcl-mode-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))
+\f
+;;;### (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))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; hcl-mode-autoloads.el ends here
--- /dev/null
+(define-package "hcl-mode" "20160502.1700" "Major mode for Hashicorp" '((emacs "24") (cl-lib "0.5")) :url "https://github.com/syohex/emacs-hcl-mode")
--- /dev/null
+;;; hcl-mode.el --- Major mode for Hashicorp
+
+;; Copyright (C) 2016 by Syohei YOSHIDA
+
+;; Author: Syohei YOSHIDA <syohexNOSPAMgmail.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
projects / emacsconfig.git / commitdiff