From 9a9fbc8a39ac46ad55cc06743fa69b90e26a866a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vegard=20=C3=98ye?= Date: Mon, 8 Aug 2011 21:15:39 +0200 Subject: Move dependencies into subdirectory That way they don't enter the user's `load-path' when following the installation instructions. --- Makefile | 14 +- ert.el | 2549 -------------------------------------------- goto-chg.el | 317 ------ lib/README | 6 + lib/ert.el | 2549 ++++++++++++++++++++++++++++++++++++++++++++ lib/goto-chg.el | 317 ++++++ lib/undo-tree.el | 3075 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ undo-tree.el | 3075 ------------------------------------------------------ 8 files changed, 5954 insertions(+), 5948 deletions(-) delete mode 100644 ert.el delete mode 100644 goto-chg.el create mode 100644 lib/README create mode 100644 lib/ert.el create mode 100644 lib/goto-chg.el create mode 100644 lib/undo-tree.el delete mode 100644 undo-tree.el diff --git a/Makefile b/Makefile index adf817c..f3b943a 100644 --- a/Makefile +++ b/Makefile @@ -9,13 +9,13 @@ TAG = all: compile compile: clean for f in ${FILES}; do \ - $(EMACS) --batch -Q -L . -f batch-byte-compile $$f; \ + $(EMACS) --batch -Q -L . -L lib -f batch-byte-compile $$f; \ done # Byte-compile all files in one batch. This is faster than # compiling each file in isolation, but also less stringent. compile-batch: clean - $(EMACS) --batch -Q -L . -f batch-byte-compile ${FILES} + $(EMACS) --batch -Q -L . -L lib -f batch-byte-compile ${FILES} # Delete byte-compiled files. clean: @@ -28,18 +28,18 @@ clean: # make test TAG=repeat # This will only run tests pertaining to the repeat system. test: clean - $(EMACS) --batch -Q -L . -l evil-tests.el \ + $(EMACS) --batch -Q -L . -L lib -l evil-tests.el \ --eval "(evil-tests-run '(${TAG}))" # Byte-compile Evil and run all tests. tests: compile-batch - $(EMACS) --batch -Q -L . -l evil-tests.el \ + $(EMACS) --batch -Q -L . -L lib -l evil-tests.el \ --eval "(evil-tests-run '(${TAG}))" rm -f *.elc # Load Evil in a fresh instance of Emacs and run all tests. emacs: clean - $(EMACS) -Q -L . -l evil-tests.el --eval "(evil-mode 1)" \ + $(EMACS) -Q -L . -L lib -l evil-tests.el --eval "(evil-mode 1)" \ --eval "(if (y-or-n-p-with-timeout \"Run tests? \" 2 t) \ (evil-tests-run '(${TAG}) t) \ (message \"You can run the tests at any time with \`M-x evil-tests-run\'\"))" & @@ -47,7 +47,7 @@ emacs: clean # Load Evil in a terminal Emacs and run all tests. term: terminal terminal: clean - $(EMACS) -nw -Q -L . -l evil-tests.el --eval "(evil-mode 1)" \ + $(EMACS) -nw -Q -L . -L lib -l evil-tests.el --eval "(evil-mode 1)" \ --eval "(if (y-or-n-p-with-timeout \"Run tests? \" 2 t) \ (evil-tests-run '(${TAG}) t) \ (message \"You can run the tests at any time with \`M-x evil-tests-run\'\"))" @@ -56,7 +56,7 @@ terminal: clean # Loads Evil into memory in order to indent macros properly. # Also removes trailing whitespace, tabs and extraneous blank lines. indent: clean - $(EMACS) --batch ${FILES} -Q -L . -l evil-tests.el \ + $(EMACS) --batch ${FILES} -Q -L . -L lib -l evil-tests.el \ --eval "(dolist (buffer (reverse (buffer-list))) \ (when (buffer-file-name buffer) \ (set-buffer buffer) \ diff --git a/ert.el b/ert.el deleted file mode 100644 index 5bd8fd0..0000000 --- a/ert.el +++ /dev/null @@ -1,2549 +0,0 @@ -;;; ert.el --- Emacs Lisp Regression Testing - -;; Copyright (C) 2007-2008, 2010-2011 Free Software Foundation, Inc. - -;; Author: Christian Ohler -;; Keywords: lisp, tools - -;; This file is part of GNU Emacs. - -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `http://www.gnu.org/licenses/'. - -;;; Commentary: - -;; ERT is a tool for automated testing in Emacs Lisp. Its main -;; features are facilities for defining and running test cases and -;; reporting the results as well as for debugging test failures -;; interactively. -;; -;; The main entry points are `ert-deftest', which is similar to -;; `defun' but defines a test, and `ert-run-tests-interactively', -;; which runs tests and offers an interactive interface for inspecting -;; results and debugging. There is also -;; `ert-run-tests-batch-and-exit' for non-interactive use. -;; -;; The body of `ert-deftest' forms resembles a function body, but the -;; additional operators `should', `should-not' and `should-error' are -;; available. `should' is similar to cl's `assert', but signals a -;; different error when its condition is violated that is caught and -;; processed by ERT. In addition, it analyzes its argument form and -;; records information that helps debugging (`assert' tries to do -;; something similar when its second argument SHOW-ARGS is true, but -;; `should' is more sophisticated). For information on `should-not' -;; and `should-error', see their docstrings. -;; -;; See ERT's info manual as well as the docstrings for more details. -;; To compile the manual, run `makeinfo ert.texinfo' in the ERT -;; directory, then C-u M-x info ert.info in Emacs to view it. -;; -;; To see some examples of tests written in ERT, see its self-tests in -;; ert-tests.el. Some of these are tricky due to the bootstrapping -;; problem of writing tests for a testing tool, others test simple -;; functions and are straightforward. - -;;; Code: - -(eval-when-compile - (require 'cl)) -(require 'button) -(require 'debug) -(require 'easymenu) -(require 'ewoc) -(require 'find-func) -(require 'help) - - -;;; UI customization options. - -(defgroup ert () - "ERT, the Emacs Lisp regression testing tool." - :prefix "ert-" - :group 'lisp) - -(defface ert-test-result-expected '((((class color) (background light)) - :background "green1") - (((class color) (background dark)) - :background "green3")) - "Face used for expected results in the ERT results buffer." - :group 'ert) - -(defface ert-test-result-unexpected '((((class color) (background light)) - :background "red1") - (((class color) (background dark)) - :background "red3")) - "Face used for unexpected results in the ERT results buffer." - :group 'ert) - - -;;; Copies/reimplementations of cl functions. - -(defun ert--cl-do-remf (plist tag) - "Copy of `cl-do-remf'. Modify PLIST by removing TAG." - (let ((p (cdr plist))) - (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) - (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) - -(defun ert--remprop (sym tag) - "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." - (let ((plist (symbol-plist sym))) - (if (and plist (eq tag (car plist))) - (progn (setplist sym (cdr (cdr plist))) t) - (ert--cl-do-remf plist tag)))) - -(defun ert--remove-if-not (ert-pred ert-list) - "A reimplementation of `remove-if-not'. - -ERT-PRED is a predicate, ERT-LIST is the input list." - (loop for ert-x in ert-list - if (funcall ert-pred ert-x) - collect ert-x)) - -(defun ert--intersection (a b) - "A reimplementation of `intersection'. Intersect the sets A and B. - -Elements are compared using `eql'." - (loop for x in a - if (memql x b) - collect x)) - -(defun ert--set-difference (a b) - "A reimplementation of `set-difference'. Subtract the set B from the set A. - -Elements are compared using `eql'." - (loop for x in a - unless (memql x b) - collect x)) - -(defun ert--set-difference-eq (a b) - "A reimplementation of `set-difference'. Subtract the set B from the set A. - -Elements are compared using `eq'." - (loop for x in a - unless (memq x b) - collect x)) - -(defun ert--union (a b) - "A reimplementation of `union'. Compute the union of the sets A and B. - -Elements are compared using `eql'." - (append a (ert--set-difference b a))) - -(eval-and-compile - (defvar ert--gensym-counter 0)) - -(eval-and-compile - (defun ert--gensym (&optional prefix) - "Only allows string PREFIX, not compatible with CL." - (unless prefix (setq prefix "G")) - (make-symbol (format "%s%s" - prefix - (prog1 ert--gensym-counter - (incf ert--gensym-counter)))))) - -(defun ert--coerce-to-vector (x) - "Coerce X to a vector." - (when (char-table-p x) (error "Not supported")) - (if (vectorp x) - x - (vconcat x))) - -(defun* ert--remove* (x list &key key test) - "Does not support all the keywords of remove*." - (unless key (setq key #'identity)) - (unless test (setq test #'eql)) - (loop for y in list - unless (funcall test x (funcall key y)) - collect y)) - -(defun ert--string-position (c s) - "Return the position of the first occurrence of C in S, or nil if none." - (loop for i from 0 - for x across s - when (eql x c) return i)) - -(defun ert--mismatch (a b) - "Return index of first element that differs between A and B. - -Like `mismatch'. Uses `equal' for comparison." - (cond ((or (listp a) (listp b)) - (ert--mismatch (ert--coerce-to-vector a) - (ert--coerce-to-vector b))) - ((> (length a) (length b)) - (ert--mismatch b a)) - (t - (let ((la (length a)) - (lb (length b))) - (assert (arrayp a) t) - (assert (arrayp b) t) - (assert (<= la lb) t) - (loop for i below la - when (not (equal (aref a i) (aref b i))) return i - finally (return (if (/= la lb) - la - (assert (equal a b) t) - nil))))))) - -(defun ert--subseq (seq start &optional end) - "Return a subsequence of SEQ from START to END." - (when (char-table-p seq) (error "Not supported")) - (let ((vector (substring (ert--coerce-to-vector seq) start end))) - (etypecase seq - (vector vector) - (string (concat vector)) - (list (append vector nil)) - (bool-vector (loop with result = (make-bool-vector (length vector) nil) - for i below (length vector) do - (setf (aref result i) (aref vector i)) - finally (return result))) - (char-table (assert nil))))) - -(defun ert-equal-including-properties (a b) - "Return t if A and B have similar structure and contents. - -This is like `equal-including-properties' except that it compares -the property values of text properties structurally (by -recursing) rather than with `eq'. Perhaps this is what -`equal-including-properties' should do in the first place; see -Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." - ;; This implementation is inefficient. Rather than making it - ;; efficient, let's hope bug 6581 gets fixed so that we can delete - ;; it altogether. - (not (ert--explain-equal-including-properties a b))) - - -;;; Defining and locating tests. - -;; The data structure that represents a test case. -(defstruct ert-test - (name nil) - (documentation nil) - (body (assert nil)) - (most-recent-result nil) - (expected-result-type ':passed) - (tags '())) - -(defun ert-test-boundp (symbol) - "Return non-nil if SYMBOL names a test." - (and (get symbol 'ert--test) t)) - -(defun ert-get-test (symbol) - "If SYMBOL names a test, return that. Signal an error otherwise." - (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) - (get symbol 'ert--test)) - -(defun ert-set-test (symbol definition) - "Make SYMBOL name the test DEFINITION, and return DEFINITION." - (when (eq symbol 'nil) - ;; We disallow nil since `ert-test-at-point' and related functions - ;; want to return a test name, but also need an out-of-band value - ;; on failure. Nil is the most natural out-of-band value; using 0 - ;; or "" or signalling an error would be too awkward. - ;; - ;; Note that nil is still a valid value for the `name' slot in - ;; ert-test objects. It designates an anonymous test. - (error "Attempt to define a test named nil")) - (put symbol 'ert--test definition) - definition) - -(defun ert-make-test-unbound (symbol) - "Make SYMBOL name no test. Return SYMBOL." - (ert--remprop symbol 'ert--test) - symbol) - -(defun ert--parse-keys-and-body (keys-and-body) - "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. - -KEYS-AND-BODY should have the form of a property list, with the -exception that only keywords are permitted as keys and that the -tail -- the body -- is a list of forms that does not start with a -keyword. - -Returns a two-element list containing the keys-and-values plist -and the body." - (let ((extracted-key-accu '()) - (remaining keys-and-body)) - (while (and (consp remaining) (keywordp (first remaining))) - (let ((keyword (pop remaining))) - (unless (consp remaining) - (error "Value expected after keyword %S in %S" - keyword keys-and-body)) - (when (assoc keyword extracted-key-accu) - (warn "Keyword %S appears more than once in %S" keyword - keys-and-body)) - (push (cons keyword (pop remaining)) extracted-key-accu))) - (setq extracted-key-accu (nreverse extracted-key-accu)) - (list (loop for (key . value) in extracted-key-accu - collect key - collect value) - remaining))) - -;;;###autoload -(defmacro* ert-deftest (name () &body docstring-keys-and-body) - "Define NAME (a symbol) as a test. - -BODY is evaluated as a `progn' when the test is run. It should -signal a condition on failure or just return if the test passes. - -`should', `should-not' and `should-error' are useful for -assertions in BODY. - -Use `ert' to run tests interactively. - -Tests that are expected to fail can be marked as such -using :expected-result. See `ert-test-result-type-p' for a -description of valid values for RESULT-TYPE. - -\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ -\[:tags '(TAG...)] BODY...)" - (declare (debug (&define :name test - name sexp [&optional stringp] - [&rest keywordp sexp] def-body)) - (doc-string 3) - (indent 2)) - (let ((documentation nil) - (documentation-supplied-p nil)) - (when (stringp (first docstring-keys-and-body)) - (setq documentation (pop docstring-keys-and-body) - documentation-supplied-p t)) - (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) - (tags nil tags-supplied-p)) - body) - (ert--parse-keys-and-body docstring-keys-and-body) - `(progn - (ert-set-test ',name - (make-ert-test - :name ',name - ,@(when documentation-supplied-p - `(:documentation ,documentation)) - ,@(when expected-result-supplied-p - `(:expected-result-type ,expected-result)) - ,@(when tags-supplied-p - `(:tags ,tags)) - :body (lambda () ,@body))) - ;; This hack allows `symbol-file' to associate `ert-deftest' - ;; forms with files, and therefore enables `find-function' to - ;; work with tests. However, it leads to warnings in - ;; `unload-feature', which doesn't know how to undefine tests - ;; and has no mechanism for extension. - (push '(ert-deftest . ,name) current-load-list) - ',name)))) - -;; We use these `put' forms in addition to the (declare (indent)) in -;; the defmacro form since the `declare' alone does not lead to -;; correct indentation before the .el/.elc file is loaded. -;; Autoloading these `put' forms solves this. -;;;###autoload -(progn - ;; TODO(ohler): Figure out what these mean and make sure they are correct. - (put 'ert-deftest 'lisp-indent-function 2) - (put 'ert-info 'lisp-indent-function 1)) - -(defvar ert--find-test-regexp - (concat "^\\s-*(ert-deftest" - find-function-space-re - "%s\\(\\s-\\|$\\)") - "The regexp the `find-function' mechanisms use for finding test definitions.") - - -(put 'ert-test-failed 'error-conditions '(error ert-test-failed)) -(put 'ert-test-failed 'error-message "Test failed") - -(defun ert-pass () - "Terminate the current test and mark it passed. Does not return." - (throw 'ert--pass nil)) - -(defun ert-fail (data) - "Terminate the current test and mark it failed. Does not return. -DATA is displayed to the user and should state the reason of the failure." - (signal 'ert-test-failed (list data))) - - -;;; The `should' macros. - -(defvar ert--should-execution-observer nil) - -(defun ert--signal-should-execution (form-description) - "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." - (when ert--should-execution-observer - (funcall ert--should-execution-observer form-description))) - -(defun ert--special-operator-p (thing) - "Return non-nil if THING is a symbol naming a special operator." - (and (symbolp thing) - (let ((definition (indirect-function thing t))) - (and (subrp definition) - (eql (cdr (subr-arity definition)) 'unevalled))))) - -(defun ert--expand-should-1 (whole form inner-expander) - "Helper function for the `should' macro and its variants." - (let ((form - ;; If `cl-macroexpand' isn't bound, the code that we're - ;; compiling doesn't depend on cl and thus doesn't need an - ;; environment arg for `macroexpand'. - (if (fboundp 'cl-macroexpand) - ;; Suppress warning about run-time call to cl funtion: we - ;; only call it if it's fboundp. - (with-no-warnings - (cl-macroexpand form (and (boundp 'cl-macro-environment) - cl-macro-environment))) - (macroexpand form)))) - (cond - ((or (atom form) (ert--special-operator-p (car form))) - (let ((value (ert--gensym "value-"))) - `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) - ,(funcall inner-expander - `(setq ,value ,form) - `(list ',whole :form ',form :value ,value) - value) - ,value))) - (t - (let ((fn-name (car form)) - (arg-forms (cdr form))) - (assert (or (symbolp fn-name) - (and (consp fn-name) - (eql (car fn-name) 'lambda) - (listp (cdr fn-name))))) - (let ((fn (ert--gensym "fn-")) - (args (ert--gensym "args-")) - (value (ert--gensym "value-")) - (default-value (ert--gensym "ert-form-evaluation-aborted-"))) - `(let ((,fn (function ,fn-name)) - (,args (list ,@arg-forms))) - (let ((,value ',default-value)) - ,(funcall inner-expander - `(setq ,value (apply ,fn ,args)) - `(nconc (list ',whole) - (list :form `(,,fn ,@,args)) - (unless (eql ,value ',default-value) - (list :value ,value)) - (let ((-explainer- - (and (symbolp ',fn-name) - (get ',fn-name 'ert-explainer)))) - (when -explainer- - (list :explanation - (apply -explainer- ,args))))) - value) - ,value)))))))) - -(defun ert--expand-should (whole form inner-expander) - "Helper function for the `should' macro and its variants. - -Analyzes FORM and returns an expression that has the same -semantics under evaluation but records additional debugging -information. - -INNER-EXPANDER should be a function and is called with two -arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM -is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is -an expression that returns a description of FORM. INNER-EXPANDER -should return code that calls INNER-FORM and performs the checks -and error signalling specific to the particular variant of -`should'. The code that INNER-EXPANDER returns must not call -FORM-DESCRIPTION-FORM before it has called INNER-FORM." - (lexical-let ((inner-expander inner-expander)) - (ert--expand-should-1 - whole form - (lambda (inner-form form-description-form value-var) - (let ((form-description (ert--gensym "form-description-"))) - `(let (,form-description) - ,(funcall inner-expander - `(unwind-protect - ,inner-form - (setq ,form-description ,form-description-form) - (ert--signal-should-execution ,form-description)) - `,form-description - value-var))))))) - -(defmacro* should (form) - "Evaluate FORM. If it returns nil, abort the current test as failed. - -Returns the value of FORM." - (ert--expand-should `(should ,form) form - (lambda (inner-form form-description-form value-var) - `(unless ,inner-form - (ert-fail ,form-description-form))))) - -(defmacro* should-not (form) - "Evaluate FORM. If it returns non-nil, abort the current test as failed. - -Returns nil." - (ert--expand-should `(should-not ,form) form - (lambda (inner-form form-description-form value-var) - `(unless (not ,inner-form) - (ert-fail ,form-description-form))))) - -(defun ert--should-error-handle-error (form-description-fn - condition type exclude-subtypes) - "Helper function for `should-error'. - -Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, -and aborts the current test as failed if it doesn't." - (let ((signalled-conditions (get (car condition) 'error-conditions)) - (handled-conditions (etypecase type - (list type) - (symbol (list type))))) - (assert signalled-conditions) - (unless (ert--intersection signalled-conditions handled-conditions) - (ert-fail (append - (funcall form-description-fn) - (list - :condition condition - :fail-reason (concat "the error signalled did not" - " have the expected type"))))) - (when exclude-subtypes - (unless (member (car condition) handled-conditions) - (ert-fail (append - (funcall form-description-fn) - (list - :condition condition - :fail-reason (concat "the error signalled was a subtype" - " of the expected type")))))))) - -;; FIXME: The expansion will evaluate the keyword args (if any) in -;; nonstandard order. -(defmacro* should-error (form &rest keys &key type exclude-subtypes) - "Evaluate FORM and check that it signals an error. - -The error signalled needs to match TYPE. TYPE should be a list -of condition names. (It can also be a non-nil symbol, which is -equivalent to a singleton list containing that symbol.) If -EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its -condition names is an element of TYPE. If EXCLUDE-SUBTYPES is -non-nil, the error matches TYPE if it is an element of TYPE. - -If the error matches, returns (ERROR-SYMBOL . DATA) from the -error. If not, or if no error was signalled, abort the test as -failed." - (unless type (setq type ''error)) - (ert--expand-should - `(should-error ,form ,@keys) - form - (lambda (inner-form form-description-form value-var) - (let ((errorp (ert--gensym "errorp")) - (form-description-fn (ert--gensym "form-description-fn-"))) - `(let ((,errorp nil) - (,form-description-fn (lambda () ,form-description-form))) - (condition-case -condition- - ,inner-form - ;; We can't use ,type here because we want to evaluate it. - (error - (setq ,errorp t) - (ert--should-error-handle-error ,form-description-fn - -condition- - ,type ,exclude-subtypes) - (setq ,value-var -condition-))) - (unless ,errorp - (ert-fail (append - (funcall ,form-description-fn) - (list - :fail-reason "did not signal an error"))))))))) - - -;;; Explanation of `should' failures. - -;; TODO(ohler): Rework explanations so that they are displayed in a -;; similar way to `ert-info' messages; in particular, allow text -;; buttons in explanations that give more detail or open an ediff -;; buffer. Perhaps explanations should be reported through `ert-info' -;; rather than as part of the condition. - -(defun ert--proper-list-p (x) - "Return non-nil if X is a proper list, nil otherwise." - (loop - for firstp = t then nil - for fast = x then (cddr fast) - for slow = x then (cdr slow) do - (when (null fast) (return t)) - (when (not (consp fast)) (return nil)) - (when (null (cdr fast)) (return t)) - (when (not (consp (cdr fast))) (return nil)) - (when (and (not firstp) (eq fast slow)) (return nil)))) - -(defun ert--explain-format-atom (x) - "Format the atom X for `ert--explain-equal'." - (typecase x - (fixnum (list x (format "#x%x" x) (format "?%c" x))) - (t x))) - -(defun ert--explain-equal-rec (a b) - "Returns a programmer-readable explanation of why A and B are not `equal'. - -Returns nil if they are." - (if (not (equal (type-of a) (type-of b))) - `(different-types ,a ,b) - (etypecase a - (cons - (let ((a-proper-p (ert--proper-list-p a)) - (b-proper-p (ert--proper-list-p b))) - (if (not (eql (not a-proper-p) (not b-proper-p))) - `(one-list-proper-one-improper ,a ,b) - (if a-proper-p - (if (not (equal (length a) (length b))) - `(proper-lists-of-different-length ,(length a) ,(length b) - ,a ,b - first-mismatch-at - ,(ert--mismatch a b)) - (loop for i from 0 - for ai in a - for bi in b - for xi = (ert--explain-equal-rec ai bi) - do (when xi (return `(list-elt ,i ,xi))) - finally (assert (equal a b) t))) - (let ((car-x (ert--explain-equal-rec (car a) (car b)))) - (if car-x - `(car ,car-x) - (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) - (if cdr-x - `(cdr ,cdr-x) - (assert (equal a b) t) - nil)))))))) - (array (if (not (equal (length a) (length b))) - `(arrays-of-different-length ,(length a) ,(length b) - ,a ,b - ,@(unless (char-table-p a) - `(first-mismatch-at - ,(ert--mismatch a b)))) - (loop for i from 0 - for ai across a - for bi across b - for xi = (ert--explain-equal-rec ai bi) - do (when xi (return `(array-elt ,i ,xi))) - finally (assert (equal a b) t)))) - (atom (if (not (equal a b)) - (if (and (symbolp a) (symbolp b) (string= a b)) - `(different-symbols-with-the-same-name ,a ,b) - `(different-atoms ,(ert--explain-format-atom a) - ,(ert--explain-format-atom b))) - nil))))) - -(defun ert--explain-equal (a b) - "Explainer function for `equal'." - ;; Do a quick comparison in C to avoid running our expensive - ;; comparison when possible. - (if (equal a b) - nil - (ert--explain-equal-rec a b))) -(put 'equal 'ert-explainer 'ert--explain-equal) - -(defun ert--significant-plist-keys (plist) - "Return the keys of PLIST that have non-null values, in order." - (assert (zerop (mod (length plist) 2)) t) - (loop for (key value . rest) on plist by #'cddr - unless (or (null value) (memq key accu)) collect key into accu - finally (return accu))) - -(defun ert--plist-difference-explanation (a b) - "Return a programmer-readable explanation of why A and B are different plists. - -Returns nil if they are equivalent, i.e., have the same value for -each key, where absent values are treated as nil. The order of -key/value pairs in each list does not matter." - (assert (zerop (mod (length a) 2)) t) - (assert (zerop (mod (length b) 2)) t) - ;; Normalizing the plists would be another way to do this but it - ;; requires a total ordering on all lisp objects (since any object - ;; is valid as a text property key). Perhaps defining such an - ;; ordering is useful in other contexts, too, but it's a lot of - ;; work, so let's punt on it for now. - (let* ((keys-a (ert--significant-plist-keys a)) - (keys-b (ert--significant-plist-keys b)) - (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) - (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) - (flet ((explain-with-key (key) - (let ((value-a (plist-get a key)) - (value-b (plist-get b key))) - (assert (not (equal value-a value-b)) t) - `(different-properties-for-key - ,key ,(ert--explain-equal-including-properties value-a - value-b))))) - (cond (keys-in-a-not-in-b - (explain-with-key (first keys-in-a-not-in-b))) - (keys-in-b-not-in-a - (explain-with-key (first keys-in-b-not-in-a))) - (t - (loop for key in keys-a - when (not (equal (plist-get a key) (plist-get b key))) - return (explain-with-key key))))))) - -(defun ert--abbreviate-string (s len suffixp) - "Shorten string S to at most LEN chars. - -If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." - (let ((n (length s))) - (cond ((< n len) - s) - (suffixp - (substring s (- n len))) - (t - (substring s 0 len))))) - -;; TODO(ohler): Once bug 6581 is fixed, rename this to -;; `ert--explain-equal-including-properties-rec' and add a fast-path -;; wrapper like `ert--explain-equal'. -(defun ert--explain-equal-including-properties (a b) - "Explainer function for `ert-equal-including-properties'. - -Returns a programmer-readable explanation of why A and B are not -`ert-equal-including-properties', or nil if they are." - (if (not (equal a b)) - (ert--explain-equal a b) - (assert (stringp a) t) - (assert (stringp b) t) - (assert (eql (length a) (length b)) t) - (loop for i from 0 to (length a) - for props-a = (text-properties-at i a) - for props-b = (text-properties-at i b) - for difference = (ert--plist-difference-explanation props-a props-b) - do (when difference - (return `(char ,i ,(substring-no-properties a i (1+ i)) - ,difference - context-before - ,(ert--abbreviate-string - (substring-no-properties a 0 i) - 10 t) - context-after - ,(ert--abbreviate-string - (substring-no-properties a (1+ i)) - 10 nil)))) - ;; TODO(ohler): Get `equal-including-properties' fixed in - ;; Emacs, delete `ert-equal-including-properties', and - ;; re-enable this assertion. - ;;finally (assert (equal-including-properties a b) t) - ))) -(put 'ert-equal-including-properties - 'ert-explainer - 'ert--explain-equal-including-properties) - - -;;; Implementation of `ert-info'. - -;; TODO(ohler): The name `info' clashes with -;; `ert--test-execution-info'. One or both should be renamed. -(defvar ert--infos '() - "The stack of `ert-info' infos that currently apply. - -Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") - -(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) - &body body) - "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. - -To be used within ERT tests. MESSAGE-FORM should evaluate to a -string that will be displayed together with the test result if -the test fails. PREFIX-FORM should evaluate to a string as well -and is displayed in front of the value of MESSAGE-FORM." - (declare (debug ((form &rest [sexp form]) body)) - (indent 1)) - `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) - ,@body)) - - - -;;; Facilities for running a single test. - -(defvar ert-debug-on-error nil - "Non-nil means enter debugger when a test fails or terminates with an error.") - -;; The data structures that represent the result of running a test. -(defstruct ert-test-result - (messages nil) - (should-forms nil) - ) -(defstruct (ert-test-passed (:include ert-test-result))) -(defstruct (ert-test-result-with-condition (:include ert-test-result)) - (condition (assert nil)) - (backtrace (assert nil)) - (infos (assert nil))) -(defstruct (ert-test-quit (:include ert-test-result-with-condition))) -(defstruct (ert-test-failed (:include ert-test-result-with-condition))) -(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) - - -(defun ert--record-backtrace () - "Record the current backtrace (as a list) and return it." - ;; Since the backtrace is stored in the result object, result - ;; objects must only be printed with appropriate limits - ;; (`print-level' and `print-length') in place. For interactive - ;; use, the cost of ensuring this possibly outweighs the advantage - ;; of storing the backtrace for - ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we - ;; already have `ert-results-rerun-test-debugging-errors-at-point'. - ;; For batch use, however, printing the backtrace may be useful. - (loop - ;; 6 is the number of frames our own debugger adds (when - ;; compiled; more when interpreted). FIXME: Need to describe a - ;; procedure for determining this constant. - for i from 6 - for frame = (backtrace-frame i) - while frame - collect frame)) - -(defun ert--print-backtrace (backtrace) - "Format the backtrace BACKTRACE to the current buffer." - ;; This is essentially a reimplementation of Fbacktrace - ;; (src/eval.c), but for a saved backtrace, not the current one. - (let ((print-escape-newlines t) - (print-level 8) - (print-length 50)) - (dolist (frame backtrace) - (ecase (first frame) - ((nil) - ;; Special operator. - (destructuring-bind (special-operator &rest arg-forms) - (cdr frame) - (insert - (format " %S\n" (list* special-operator arg-forms))))) - ((t) - ;; Function call. - (destructuring-bind (fn &rest args) (cdr frame) - (insert (format " %S(" fn)) - (loop for firstp = t then nil - for arg in args do - (unless firstp - (insert " ")) - (insert (format "%S" arg))) - (insert ")\n"))))))) - -;; A container for the state of the execution of a single test and -;; environment data needed during its execution. -(defstruct ert--test-execution-info - (test (assert nil)) - (result (assert nil)) - ;; A thunk that may be called when RESULT has been set to its final - ;; value and test execution should be terminated. Should not - ;; return. - (exit-continuation (assert nil)) - ;; The binding of `debugger' outside of the execution of the test. - next-debugger - ;; The binding of `ert-debug-on-error' that is in effect for the - ;; execution of the current test. We store it to avoid being - ;; affected by any new bindings the test itself may establish. (I - ;; don't remember whether this feature is important.) - ert-debug-on-error) - -(defun ert--run-test-debugger (info debugger-args) - "During a test run, `debugger' is bound to a closure that calls this function. - -This function records failures and errors and either terminates -the test silently or calls the interactive debugger, as -appropriate. - -INFO is the ert--test-execution-info corresponding to this test -run. DEBUGGER-ARGS are the arguments to `debugger'." - (destructuring-bind (first-debugger-arg &rest more-debugger-args) - debugger-args - (ecase first-debugger-arg - ((lambda debug t exit nil) - (apply (ert--test-execution-info-next-debugger info) debugger-args)) - (error - (let* ((condition (first more-debugger-args)) - (type (case (car condition) - ((quit) 'quit) - (otherwise 'failed))) - (backtrace (ert--record-backtrace)) - (infos (reverse ert--infos))) - (setf (ert--test-execution-info-result info) - (ecase type - (quit - (make-ert-test-quit :condition condition - :backtrace backtrace - :infos infos)) - (failed - (make-ert-test-failed :condition condition - :backtrace backtrace - :infos infos)))) - ;; Work around Emacs' heuristic (in eval.c) for detecting - ;; errors in the debugger. - (incf num-nonmacro-input-events) - ;; FIXME: We should probably implement more fine-grained - ;; control a la non-t `debug-on-error' here. - (cond - ((ert--test-execution-info-ert-debug-on-error info) - (apply (ert--test-execution-info-next-debugger info) debugger-args)) - (t)) - (funcall (ert--test-execution-info-exit-continuation info))))))) - -(defun ert--run-test-internal (ert-test-execution-info) - "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. - -This mainly sets up debugger-related bindings." - (lexical-let ((info ert-test-execution-info)) - (setf (ert--test-execution-info-next-debugger info) debugger - (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) - (catch 'ert--pass - ;; For now, each test gets its own temp buffer and its own - ;; window excursion, just to be safe. If this turns out to be - ;; too expensive, we can remove it. - (with-temp-buffer - (save-window-excursion - (let ((debugger (lambda (&rest debugger-args) - (ert--run-test-debugger info debugger-args))) - (debug-on-error t) - (debug-on-quit t) - ;; FIXME: Do we need to store the old binding of this - ;; and consider it in `ert--run-test-debugger'? - (debug-ignored-errors nil) - (ert--infos '())) - (funcall (ert-test-body (ert--test-execution-info-test info)))))) - (ert-pass)) - (setf (ert--test-execution-info-result info) (make-ert-test-passed))) - nil) - -(defun ert--force-message-log-buffer-truncation () - "Immediately truncate *Messages* buffer according to `message-log-max'. - -This can be useful after reducing the value of `message-log-max'." - (with-current-buffer (get-buffer-create "*Messages*") - ;; This is a reimplementation of this part of message_dolog() in xdisp.c: - ;; if (NATNUMP (Vmessage_log_max)) - ;; { - ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, - ;; -XFASTINT (Vmessage_log_max) - 1, 0); - ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); - ;; } - (when (and (integerp message-log-max) (>= message-log-max 0)) - (let ((begin (point-min)) - (end (save-excursion - (goto-char (point-max)) - (forward-line (- message-log-max)) - (point)))) - (delete-region begin end))))) - -(defvar ert--running-tests nil - "List of tests that are currently in execution. - -This list is empty while no test is running, has one element -while a test is running, two elements while a test run from -inside a test is running, etc. The list is in order of nesting, -innermost test first. - -The elements are of type `ert-test'.") - -(defun ert-run-test (ert-test) - "Run ERT-TEST. - -Returns the result and stores it in ERT-TEST's `most-recent-result' slot." - (setf (ert-test-most-recent-result ert-test) nil) - (block error - (lexical-let ((begin-marker - (with-current-buffer (get-buffer-create "*Messages*") - (set-marker (make-marker) (point-max))))) - (unwind-protect - (lexical-let ((info (make-ert--test-execution-info - :test ert-test - :result - (make-ert-test-aborted-with-non-local-exit) - :exit-continuation (lambda () - (return-from error nil)))) - (should-form-accu (list))) - (unwind-protect - (let ((ert--should-execution-observer - (lambda (form-description) - (push form-description should-form-accu))) - (message-log-max t) - (ert--running-tests (cons ert-test ert--running-tests))) - (ert--run-test-internal info)) - (let ((result (ert--test-execution-info-result info))) - (setf (ert-test-result-messages result) - (with-current-buffer (get-buffer-create "*Messages*") - (buffer-substring begin-marker (point-max)))) - (ert--force-message-log-buffer-truncation) - (setq should-form-accu (nreverse should-form-accu)) - (setf (ert-test-result-should-forms result) - should-form-accu) - (setf (ert-test-most-recent-result ert-test) result)))) - (set-marker begin-marker nil)))) - (ert-test-most-recent-result ert-test)) - -(defun ert-running-test () - "Return the top-level test currently executing." - (car (last ert--running-tests))) - - -;;; Test selectors. - -(defun ert-test-result-type-p (result result-type) - "Return non-nil if RESULT matches type RESULT-TYPE. - -Valid result types: - -nil -- Never matches. -t -- Always matches. -:failed, :passed -- Matches corresponding results. -\(and TYPES...\) -- Matches if all TYPES match. -\(or TYPES...\) -- Matches if some TYPES match. -\(not TYPE\) -- Matches if TYPE does not match. -\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with - RESULT." - ;; It would be easy to add `member' and `eql' types etc., but I - ;; haven't bothered yet. - (etypecase result-type - ((member nil) nil) - ((member t) t) - ((member :failed) (ert-test-failed-p result)) - ((member :passed) (ert-test-passed-p result)) - (cons - (destructuring-bind (operator &rest operands) result-type - (ecase operator - (and - (case (length operands) - (0 t) - (t - (and (ert-test-result-type-p result (first operands)) - (ert-test-result-type-p result `(and ,@(rest operands))))))) - (or - (case (length operands) - (0 nil) - (t - (or (ert-test-result-type-p result (first operands)) - (ert-test-result-type-p result `(or ,@(rest operands))))))) - (not - (assert (eql (length operands) 1)) - (not (ert-test-result-type-p result (first operands)))) - (satisfies - (assert (eql (length operands) 1)) - (funcall (first operands) result))))))) - -(defun ert-test-result-expected-p (test result) - "Return non-nil if TEST's expected result type matches RESULT." - (ert-test-result-type-p result (ert-test-expected-result-type test))) - -(defun ert-select-tests (selector universe) - "Return the tests that match SELECTOR. - -UNIVERSE specifies the set of tests to select from; it should be -a list of tests, or t, which refers to all tests named by symbols -in `obarray'. - -Returns the set of tests as a list. - -Valid selectors: - -nil -- Selects the empty set. -t -- Selects UNIVERSE. -:new -- Selects all tests that have not been run yet. -:failed, :passed -- Select tests according to their most recent result. -:expected, :unexpected -- Select tests according to their most recent result. -a string -- Selects all tests that have a name that matches the string, - a regexp. -a test -- Selects that test. -a symbol -- Selects the test that the symbol names, errors if none. -\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. -\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. -\(and SELECTORS...\) -- Selects the tests that match all SELECTORS. -\(or SELECTORS...\) -- Selects the tests that match any SELECTOR. -\(not SELECTOR\) -- Selects all tests that do not match SELECTOR. -\(tag TAG) -- Selects all tests that have TAG on their tags list. -\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. - -Only selectors that require a superset of tests, such -as (satisfies ...), strings, :new, etc. make use of UNIVERSE. -Selectors that do not, such as \(member ...\), just return the -set implied by them without checking whether it is really -contained in UNIVERSE." - ;; This code needs to match the etypecase in - ;; `ert-insert-human-readable-selector'. - (etypecase selector - ((member nil) nil) - ((member t) (etypecase universe - (list universe) - ((member t) (ert-select-tests "" universe)))) - ((member :new) (ert-select-tests - `(satisfies ,(lambda (test) - (null (ert-test-most-recent-result test)))) - universe)) - ((member :failed) (ert-select-tests - `(satisfies ,(lambda (test) - (ert-test-result-type-p - (ert-test-most-recent-result test) - ':failed))) - universe)) - ((member :passed) (ert-select-tests - `(satisfies ,(lambda (test) - (ert-test-result-type-p - (ert-test-most-recent-result test) - ':passed))) - universe)) - ((member :expected) (ert-select-tests - `(satisfies - ,(lambda (test) - (ert-test-result-expected-p - test - (ert-test-most-recent-result test)))) - universe)) - ((member :unexpected) (ert-select-tests `(not :expected) universe)) - (string - (etypecase universe - ((member t) (mapcar #'ert-get-test - (apropos-internal selector #'ert-test-boundp))) - (list (ert--remove-if-not (lambda (test) - (and (ert-test-name test) - (string-match selector - (ert-test-name test)))) - universe)))) - (ert-test (list selector)) - (symbol - (assert (ert-test-boundp selector)) - (list (ert-get-test selector))) - (cons - (destructuring-bind (operator &rest operands) selector - (ecase operator - (member - (mapcar (lambda (purported-test) - (etypecase purported-test - (symbol (assert (ert-test-boundp purported-test)) - (ert-get-test purported-test)) - (ert-test purported-test))) - operands)) - (eql - (assert (eql (length operands) 1)) - (ert-select-tests `(member ,@operands) universe)) - (and - ;; Do these definitions of AND, NOT and OR satisfy de - ;; Morgan's laws? Should they? - (case (length operands) - (0 (ert-select-tests 't universe)) - (t (ert-select-tests `(and ,@(rest operands)) - (ert-select-tests (first operands) - universe))))) - (not - (assert (eql (length operands) 1)) - (let ((all-tests (ert-select-tests 't universe))) - (ert--set-difference all-tests - (ert-select-tests (first operands) - all-tests)))) - (or - (case (length operands) - (0 (ert-select-tests 'nil universe)) - (t (ert--union (ert-select-tests (first operands) universe) - (ert-select-tests `(or ,@(rest operands)) - universe))))) - (tag - (assert (eql (length operands) 1)) - (let ((tag (first operands))) - (ert-select-tests `(satisfies - ,(lambda (test) - (member tag (ert-test-tags test)))) - universe))) - (satisfies - (assert (eql (length operands) 1)) - (ert--remove-if-not (first operands) - (ert-select-tests 't universe)))))))) - -(defun ert--insert-human-readable-selector (selector) - "Insert a human-readable presentation of SELECTOR into the current buffer." - ;; This is needed to avoid printing the (huge) contents of the - ;; `backtrace' slot of the result objects in the - ;; `most-recent-result' slots of test case objects in (eql ...) or - ;; (member ...) selectors. - (labels ((rec (selector) - ;; This code needs to match the etypecase in `ert-select-tests'. - (etypecase selector - ((or (member nil t - :new :failed :passed - :expected :unexpected) - string - symbol) - selector) - (ert-test - (if (ert-test-name selector) - (make-symbol (format "<%S>" (ert-test-name selector))) - (make-symbol ""))) - (cons - (destructuring-bind (operator &rest operands) selector - (ecase operator - ((member eql and not or) - `(,operator ,@(mapcar #'rec operands))) - ((member tag satisfies) - selector))))))) - (insert (format "%S" (rec selector))))) - - -;;; Facilities for running a whole set of tests. - -;; The data structure that contains the set of tests being executed -;; during one particular test run, their results, the state of the -;; execution, and some statistics. -;; -;; The data about results and expected results of tests may seem -;; redundant here, since the test objects also carry such information. -;; However, the information in the test objects may be more recent, it -;; may correspond to a different test run. We need the information -;; that corresponds to this run in order to be able to update the -;; statistics correctly when a test is re-run interactively and has a -;; different result than before. -(defstruct ert--stats - (selector (assert nil)) - ;; The tests, in order. - (tests (assert nil) :type vector) - ;; A map of test names (or the test objects themselves for unnamed - ;; tests) to indices into the `tests' vector. - (test-map (assert nil) :type hash-table) - ;; The results of the tests during this run, in order. - (test-results (assert nil) :type vector) - ;; The start times of the tests, in order, as reported by - ;; `current-time'. - (test-start-times (assert nil) :type vector) - ;; The end times of the tests, in order, as reported by - ;; `current-time'. - (test-end-times (assert nil) :type vector) - (passed-expected 0) - (passed-unexpected 0) - (failed-expected 0) - (failed-unexpected 0) - (start-time nil) - (end-time nil) - (aborted-p nil) - (current-test nil) - ;; The time at or after which the next redisplay should occur, as a - ;; float. - (next-redisplay 0.0)) - -(defun ert-stats-completed-expected (stats) - "Return the number of tests in STATS that had expected results." - (+ (ert--stats-passed-expected stats) - (ert--stats-failed-expected stats))) - -(defun ert-stats-completed-unexpected (stats) - "Return the number of tests in STATS that had unexpected results." - (+ (ert--stats-passed-unexpected stats) - (ert--stats-failed-unexpected stats))) - -(defun ert-stats-completed (stats) - "Number of tests in STATS that have run so far." - (+ (ert-stats-completed-expected stats) - (ert-stats-completed-unexpected stats))) - -(defun ert-stats-total (stats) - "Number of tests in STATS, regardless of whether they have run yet." - (length (ert--stats-tests stats))) - -;; The stats object of the current run, dynamically bound. This is -;; used for the mode line progress indicator. -(defvar ert--current-run-stats nil) - -(defun ert--stats-test-key (test) - "Return the key used for TEST in the test map of ert--stats objects. - -Returns the name of TEST if it has one, or TEST itself otherwise." - (or (ert-test-name test) test)) - -(defun ert--stats-set-test-and-result (stats pos test result) - "Change STATS by replacing the test at position POS with TEST and RESULT. - -Also changes the counters in STATS to match." - (let* ((tests (ert--stats-tests stats)) - (results (ert--stats-test-results stats)) - (old-test (aref tests pos)) - (map (ert--stats-test-map stats))) - (flet ((update (d) - (if (ert-test-result-expected-p (aref tests pos) - (aref results pos)) - (etypecase (aref results pos) - (ert-test-passed (incf (ert--stats-passed-expected stats) d)) - (ert-test-failed (incf (ert--stats-failed-expected stats) d)) - (null) - (ert-test-aborted-with-non-local-exit) - (ert-test-quit)) - (etypecase (aref results pos) - (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) - (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) - (null) - (ert-test-aborted-with-non-local-exit) - (ert-test-quit))))) - ;; Adjust counters to remove the result that is currently in stats. - (update -1) - ;; Put new test and result into stats. - (setf (aref tests pos) test - (aref results pos) result) - (remhash (ert--stats-test-key old-test) map) - (setf (gethash (ert--stats-test-key test) map) pos) - ;; Adjust counters to match new result. - (update +1) - nil))) - -(defun ert--make-stats (tests selector) - "Create a new `ert--stats' object for running TESTS. - -SELECTOR is the selector that was used to select TESTS." - (setq tests (ert--coerce-to-vector tests)) - (let ((map (make-hash-table :size (length tests)))) - (loop for i from 0 - for test across tests - for key = (ert--stats-test-key test) do - (assert (not (gethash key map))) - (setf (gethash key map) i)) - (make-ert--stats :selector selector - :tests tests - :test-map map - :test-results (make-vector (length tests) nil) - :test-start-times (make-vector (length tests) nil) - :test-end-times (make-vector (length tests) nil)))) - -(defun ert-run-or-rerun-test (stats test listener) - ;; checkdoc-order: nil - "Run the single test TEST and record the result using STATS and LISTENER." - (let ((ert--current-run-stats stats) - (pos (ert--stats-test-pos stats test))) - (ert--stats-set-test-and-result stats pos test nil) - ;; Call listener after setting/before resetting - ;; (ert--stats-current-test stats); the listener might refresh the - ;; mode line display, and if the value is not set yet/any more - ;; during this refresh, the mode line will flicker unnecessarily. - (setf (ert--stats-current-test stats) test) - (funcall listener 'test-started stats test) - (setf (ert-test-most-recent-result test) nil) - (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) - (unwind-protect - (ert-run-test test) - (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) - (let ((result (ert-test-most-recent-result test))) - (ert--stats-set-test-and-result stats pos test result) - (funcall listener 'test-ended stats test result)) - (setf (ert--stats-current-test stats) nil)))) - -(defun ert-run-tests (selector listener) - "Run the tests specified by SELECTOR, sending progress updates to LISTENER." - (let* ((tests (ert-select-tests selector t)) - (stats (ert--make-stats tests selector))) - (setf (ert--stats-start-time stats) (current-time)) - (funcall listener 'run-started stats) - (let ((abortedp t)) - (unwind-protect - (let ((ert--current-run-stats stats)) - (force-mode-line-update) - (unwind-protect - (progn - (loop for test in tests do - (ert-run-or-rerun-test stats test listener)) - (setq abortedp nil)) - (setf (ert--stats-aborted-p stats) abortedp) - (setf (ert--stats-end-time stats) (current-time)) - (funcall listener 'run-ended stats abortedp))) - (force-mode-line-update)) - stats))) - -(defun ert--stats-test-pos (stats test) - ;; checkdoc-order: nil - "Return the position (index) of TEST in the run represented by STATS." - (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) - - -;;; Formatting functions shared across UIs. - -(defun ert--format-time-iso8601 (time) - "Format TIME in the variant of ISO 8601 used for timestamps in ERT." - (format-time-string "%Y-%m-%d %T%z" time)) - -(defun ert-char-for-test-result (result expectedp) - "Return a character that represents the test result RESULT. - -EXPECTEDP specifies whether the result was expected." - (let ((s (etypecase result - (ert-test-passed ".P") - (ert-test-failed "fF") - (null "--") - (ert-test-aborted-with-non-local-exit "aA") - (ert-test-quit "qQ")))) - (elt s (if expectedp 0 1)))) - -(defun ert-string-for-test-result (result expectedp) - "Return a string that represents the test result RESULT. - -EXPECTEDP specifies whether the result was expected." - (let ((s (etypecase result - (ert-test-passed '("passed" "PASSED")) - (ert-test-failed '("failed" "FAILED")) - (null '("unknown" "UNKNOWN")) - (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")) - (ert-test-quit '("quit" "QUIT"))))) - (elt s (if expectedp 0 1)))) - -(defun ert--pp-with-indentation-and-newline (object) - "Pretty-print OBJECT, indenting it to the current column of point. -Ensures a final newline is inserted." - (let ((begin (point))) - (pp object (current-buffer)) - (unless (bolp) (insert "\n")) - (save-excursion - (goto-char begin) - (indent-sexp)))) - -(defun ert--insert-infos (result) - "Insert `ert-info' infos from RESULT into current buffer. - -RESULT must be an `ert-test-result-with-condition'." - (check-type result ert-test-result-with-condition) - (dolist (info (ert-test-result-with-condition-infos result)) - (destructuring-bind (prefix . message) info - (let ((begin (point)) - (indentation (make-string (+ (length prefix) 4) ?\s)) - (end nil)) - (unwind-protect - (progn - (insert message "\n") - (setq end (copy-marker (point))) - (goto-char begin) - (insert " " prefix) - (forward-line 1) - (while (< (point) end) - (insert indentation) - (forward-line 1))) - (when end (set-marker end nil))))))) - - -;;; Running tests in batch mode. - -(defvar ert-batch-backtrace-right-margin 70 - "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") - -;;;###autoload -(defun ert-run-tests-batch (&optional selector) - "Run the tests specified by SELECTOR, printing results to the terminal. - -SELECTOR works as described in `ert-select-tests', except if -SELECTOR is nil, in which case all tests rather than none will be -run; this makes the command line \"emacs -batch -l my-tests.el -f -ert-run-tests-batch-and-exit\" useful. - -Returns the stats object." - (unless selector (setq selector 't)) - (ert-run-tests - selector - (lambda (event-type &rest event-args) - (ecase event-type - (run-started - (destructuring-bind (stats) event-args - (message "Running %s tests (%s)" - (length (ert--stats-tests stats)) - (ert--format-time-iso8601 (ert--stats-start-time stats))))) - (run-ended - (destructuring-bind (stats abortedp) event-args - (let ((unexpected (ert-stats-completed-unexpected stats)) - (expected-failures (ert--stats-failed-expected stats))) - (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" - (if (not abortedp) - "" - "Aborted: ") - (ert-stats-total stats) - (ert-stats-completed-expected stats) - (if (zerop unexpected) - "" - (format ", %s unexpected" unexpected)) - (ert--format-time-iso8601 (ert--stats-end-time stats)) - (if (zerop expected-failures) - "" - (format "\n%s expected failures" expected-failures))) - (unless (zerop unexpected) - (message "%s unexpected results:" unexpected) - (loop for test across (ert--stats-tests stats) - for result = (ert-test-most-recent-result test) do - (when (not (ert-test-result-expected-p test result)) - (message "%9s %S" - (ert-string-for-test-result result nil) - (ert-test-name test)))) - (message "%s" ""))))) - (test-started - ) - (test-ended - (destructuring-bind (stats test result) event-args - (unless (ert-test-result-expected-p test result) - (etypecase result - (ert-test-passed - (message "Test %S passed unexpectedly" (ert-test-name test))) - (ert-test-result-with-condition - (message "Test %S backtrace:" (ert-test-name test)) - (with-temp-buffer - (ert--print-backtrace (ert-test-result-with-condition-backtrace - result)) - (goto-char (point-min)) - (while (not (eobp)) - (let ((start (point)) - (end (progn (end-of-line) (point)))) - (setq end (min end - (+ start ert-batch-backtrace-right-margin))) - (message "%s" (buffer-substring-no-properties - start end))) - (forward-line 1))) - (with-temp-buffer - (ert--insert-infos result) - (insert " ") - (let ((print-escape-newlines t) - (print-level 5) - (print-length 10)) - (let ((begin (point))) - (ert--pp-with-indentation-and-newline - (ert-test-result-with-condition-condition result)))) - (goto-char (1- (point-max))) - (assert (looking-at "\n")) - (delete-char 1) - (message "Test %S condition:" (ert-test-name test)) - (message "%s" (buffer-string)))) - (ert-test-aborted-with-non-local-exit - (message "Test %S aborted with non-local exit" - (ert-test-name test))) - (ert-test-quit - (message "Quit during %S" (ert-test-name test))))) - (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) - (format-string (concat "%9s %" - (prin1-to-string (length max)) - "s/" max " %S"))) - (message format-string - (ert-string-for-test-result result - (ert-test-result-expected-p - test result)) - (1+ (ert--stats-test-pos stats test)) - (ert-test-name test))))))))) - -;;;###autoload -(defun ert-run-tests-batch-and-exit (&optional selector) - "Like `ert-run-tests-batch', but exits Emacs when done. - -The exit status will be 0 if all test results were as expected, 1 -on unexpected results, or 2 if the tool detected an error outside -of the tests (e.g. invalid SELECTOR or bug in the code that runs -the tests)." - (unwind-protect - (let ((stats (ert-run-tests-batch selector))) - (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) - (unwind-protect - (progn - (message "Error running tests") - (backtrace)) - (kill-emacs 2)))) - - -;;; Utility functions for load/unload actions. - -(defun ert--activate-font-lock-keywords () - "Activate font-lock keywords for some of ERT's symbols." - (font-lock-add-keywords - nil - '(("(\\(\\\\s *\\(\\sw+\\)?" - (1 font-lock-keyword-face nil t) - (2 font-lock-function-name-face nil t))))) - -(defun* ert--remove-from-list (list-var element &key key test) - "Remove ELEMENT from the value of LIST-VAR if present. - -This can be used as an inverse of `add-to-list'." - (unless key (setq key #'identity)) - (unless test (setq test #'equal)) - (setf (symbol-value list-var) - (ert--remove* element - (symbol-value list-var) - :key key - :test test))) - - -;;; Some basic interactive functions. - -(defun ert-read-test-name (prompt &optional default history - add-default-to-prompt) - "Read the name of a test and return it as a symbol. - -Prompt with PROMPT. If DEFAULT is a valid test name, use it as a -default. HISTORY is the history to use; see `completing-read'. -If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to -include the default, if any. - -Signals an error if no test name was read." - (etypecase default - (string (let ((symbol (intern-soft default))) - (unless (and symbol (ert-test-boundp symbol)) - (setq default nil)))) - (symbol (setq default - (if (ert-test-boundp default) - (symbol-name default) - nil))) - (ert-test (setq default (ert-test-name default)))) - (when add-default-to-prompt - (setq prompt (if (null default) - (format "%s: " prompt) - (format "%s (default %s): " prompt default)))) - (let ((input (completing-read prompt obarray #'ert-test-boundp - t nil history default nil))) - ;; completing-read returns an empty string if default was nil and - ;; the user just hit enter. - (let ((sym (intern-soft input))) - (if (ert-test-boundp sym) - sym - (error "Input does not name a test"))))) - -(defun ert-read-test-name-at-point (prompt) - "Read the name of a test and return it as a symbol. -As a default, use the symbol at point, or the test at point if in -the ERT results buffer. Prompt with PROMPT, augmented with the -default (if any)." - (ert-read-test-name prompt (ert-test-at-point) nil t)) - -(defun ert-find-test-other-window (test-name) - "Find, in another window, the definition of TEST-NAME." - (interactive (list (ert-read-test-name-at-point "Find test definition: "))) - (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) - -(defun ert-delete-test (test-name) - "Make the test TEST-NAME unbound. - -Nothing more than an interactive interface to `ert-make-test-unbound'." - (interactive (list (ert-read-test-name-at-point "Delete test"))) - (ert-make-test-unbound test-name)) - -(defun ert-delete-all-tests () - "Make all symbols in `obarray' name no test." - (interactive) - (when (interactive-p) - (unless (y-or-n-p "Delete all tests? ") - (error "Aborted"))) - ;; We can't use `ert-select-tests' here since that gives us only - ;; test objects, and going from them back to the test name symbols - ;; can fail if the `ert-test' defstruct has been redefined. - (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) - t) - - -;;; Display of test progress and results. - -;; An entry in the results buffer ewoc. There is one entry per test. -(defstruct ert--ewoc-entry - (test (assert nil)) - ;; If the result of this test was expected, its ewoc entry is hidden - ;; initially. - (hidden-p (assert nil)) - ;; An ewoc entry may be collapsed to hide details such as the error - ;; condition. - ;; - ;; I'm not sure the ability to expand and collapse entries is still - ;; a useful feature. - (expanded-p t) - ;; By default, the ewoc entry presents the error condition with - ;; certain limits on how much to print (`print-level', - ;; `print-length'). The user can interactively switch to a set of - ;; higher limits. - (extended-printer-limits-p nil)) - -;; Variables local to the results buffer. - -;; The ewoc. -(defvar ert--results-ewoc) -;; The stats object. -(defvar ert--results-stats) -;; A string with one character per test. Each character represents -;; the result of the corresponding test. The string is displayed near -;; the top of the buffer and serves as a progress bar. -(defvar ert--results-progress-bar-string) -;; The position where the progress bar button begins. -(defvar ert--results-progress-bar-button-begin) -;; The test result listener that updates the buffer when tests are run. -(defvar ert--results-listener) - -(defun ert-insert-test-name-button (test-name) - "Insert a button that links to TEST-NAME." - (insert-text-button (format "%S" test-name) - :type 'ert--test-name-button - 'ert-test-name test-name)) - -(defun ert--results-format-expected-unexpected (expected unexpected) - "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." - (if (zerop unexpected) - (format "%s" expected) - (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) - -(defun ert--results-update-ewoc-hf (ewoc stats) - "Update the header and footer of EWOC to show certain information from STATS. - -Also sets `ert--results-progress-bar-button-begin'." - (let ((run-count (ert-stats-completed stats)) - (results-buffer (current-buffer)) - ;; Need to save buffer-local value. - (font-lock font-lock-mode)) - (ewoc-set-hf - ewoc - ;; header - (with-temp-buffer - (insert "Selector: ") - (ert--insert-human-readable-selector (ert--stats-selector stats)) - (insert "\n") - (insert - (format (concat "Passed: %s\n" - "Failed: %s\n" - "Total: %s/%s\n\n") - (ert--results-format-expected-unexpected - (ert--stats-passed-expected stats) - (ert--stats-passed-unexpected stats)) - (ert--results-format-expected-unexpected - (ert--stats-failed-expected stats) - (ert--stats-failed-unexpected stats)) - run-count - (ert-stats-total stats))) - (insert - (format "Started at: %s\n" - (ert--format-time-iso8601 (ert--stats-start-time stats)))) - ;; FIXME: This is ugly. Need to properly define invariants of - ;; the `stats' data structure. - (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) - ((ert--stats-current-test stats) 'running) - ((ert--stats-end-time stats) 'finished) - (t 'preparing)))) - (ecase state - (preparing - (insert "")) - (aborted - (cond ((ert--stats-current-test stats) - (insert "Aborted during test: ") - (ert-insert-test-name-button - (ert-test-name (ert--stats-current-test stats)))) - (t - (insert "Aborted.")))) - (running - (assert (ert--stats-current-test stats)) - (insert "Running test: ") - (ert-insert-test-name-button (ert-test-name - (ert--stats-current-test stats)))) - (finished - (assert (not (ert--stats-current-test stats))) - (insert "Finished."))) - (insert "\n") - (if (ert--stats-end-time stats) - (insert - (format "%s%s\n" - (if (ert--stats-aborted-p stats) - "Aborted at: " - "Finished at: ") - (ert--format-time-iso8601 (ert--stats-end-time stats)))) - (insert "\n")) - (insert "\n")) - (let ((progress-bar-string (with-current-buffer results-buffer - ert--results-progress-bar-string))) - (let ((progress-bar-button-begin - (insert-text-button progress-bar-string - :type 'ert--results-progress-bar-button - 'face (or (and font-lock - (ert-face-for-stats stats)) - 'button)))) - ;; The header gets copied verbatim to the results buffer, - ;; and all positions remain the same, so - ;; `progress-bar-button-begin' will be the right position - ;; even in the results buffer. - (with-current-buffer results-buffer - (set (make-local-variable 'ert--results-progress-bar-button-begin) - progress-bar-button-begin)))) - (insert "\n\n") - (buffer-string)) - ;; footer - ;; - ;; We actually want an empty footer, but that would trigger a bug - ;; in ewoc, sometimes clearing the entire buffer. (It's possible - ;; that this bug has been fixed since this has been tested; we - ;; should test it again.) - "\n"))) - - -(defvar ert-test-run-redisplay-interval-secs .1 - "How many seconds ERT should wait between redisplays while running tests. - -While running tests, ERT shows the current progress, and this variable -determines how frequently the progress display is updated.") - -(defun ert--results-update-stats-display (ewoc stats) - "Update EWOC and the mode line to show data from STATS." - ;; TODO(ohler): investigate using `make-progress-reporter'. - (ert--results-update-ewoc-hf ewoc stats) - (force-mode-line-update) - (redisplay t) - (setf (ert--stats-next-redisplay stats) - (+ (float-time) ert-test-run-redisplay-interval-secs))) - -(defun ert--results-update-stats-display-maybe (ewoc stats) - "Call `ert--results-update-stats-display' if not called recently. - -EWOC and STATS are arguments for `ert--results-update-stats-display'." - (when (>= (float-time) (ert--stats-next-redisplay stats)) - (ert--results-update-stats-display ewoc stats))) - -(defun ert--tests-running-mode-line-indicator () - "Return a string for the mode line that shows the test run progress." - (let* ((stats ert--current-run-stats) - (tests-total (ert-stats-total stats)) - (tests-completed (ert-stats-completed stats))) - (if (>= tests-completed tests-total) - (format " ERT(%s/%s,finished)" tests-completed tests-total) - (format " ERT(%s/%s):%s" - (1+ tests-completed) - tests-total - (if (null (ert--stats-current-test stats)) - "?" - (format "%S" - (ert-test-name (ert--stats-current-test stats)))))))) - -(defun ert--make-xrefs-region (begin end) - "Attach cross-references to function names between BEGIN and END. - -BEGIN and END specify a region in the current buffer." - (save-excursion - (save-restriction - (narrow-to-region begin (point)) - ;; Inhibit optimization in `debugger-make-xrefs' that would - ;; sometimes insert unrelated backtrace info into our buffer. - (let ((debugger-previous-backtrace nil)) - (debugger-make-xrefs))))) - -(defun ert--string-first-line (s) - "Return the first line of S, or S if it contains no newlines. - -The return value does not include the line terminator." - (substring s 0 (ert--string-position ?\n s))) - -(defun ert-face-for-test-result (expectedp) - "Return a face that shows whether a test result was expected or unexpected. - -If EXPECTEDP is nil, returns the face for unexpected results; if -non-nil, returns the face for expected results.." - (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) - -(defun ert-face-for-stats (stats) - "Return a face that represents STATS." - (cond ((ert--stats-aborted-p stats) 'nil) - ((plusp (ert-stats-completed-unexpected stats)) - (ert-face-for-test-result nil)) - ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) - (ert-face-for-test-result t)) - (t 'nil))) - -(defun ert--print-test-for-ewoc (entry) - "The ewoc print function for ewoc test entries. ENTRY is the entry to print." - (let* ((test (ert--ewoc-entry-test entry)) - (stats ert--results-stats) - (result (let ((pos (ert--stats-test-pos stats test))) - (assert pos) - (aref (ert--stats-test-results stats) pos))) - (hiddenp (ert--ewoc-entry-hidden-p entry)) - (expandedp (ert--ewoc-entry-expanded-p entry)) - (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p - entry))) - (cond (hiddenp) - (t - (let ((expectedp (ert-test-result-expected-p test result))) - (insert-text-button (format "%c" (ert-char-for-test-result - result expectedp)) - :type 'ert--results-expand-collapse-button - 'face (or (and font-lock-mode - (ert-face-for-test-result - expectedp)) - 'button))) - (insert " ") - (ert-insert-test-name-button (ert-test-name test)) - (insert "\n") - (when (and expandedp (not (eql result 'nil))) - (when (ert-test-documentation test) - (insert " " - (propertize - (ert--string-first-line (ert-test-documentation test)) - 'font-lock-face 'font-lock-doc-face) - "\n")) - (etypecase result - (ert-test-passed - (if (ert-test-result-expected-p test result) - (insert " passed\n") - (insert " passed unexpectedly\n")) - (insert "")) - (ert-test-result-with-condition - (ert--insert-infos result) - (let ((print-escape-newlines t) - (print-level (if extended-printer-limits-p 12 6)) - (print-length (if extended-printer-limits-p 100 10))) - (insert " ") - (let ((begin (point))) - (ert--pp-with-indentation-and-newline - (ert-test-result-with-condition-condition result)) - (ert--make-xrefs-region begin (point))))) - (ert-test-aborted-with-non-local-exit - (insert " aborted\n")) - (ert-test-quit - (insert " quit\n"))) - (insert "\n"))))) - nil) - -(defun ert--results-font-lock-function (enabledp) - "Redraw the ERT results buffer after font-lock-mode was switched on or off. - -ENABLEDP is true if font-lock-mode is switched on, false -otherwise." - (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) - (ewoc-refresh ert--results-ewoc) - (font-lock-default-function enabledp)) - -(defun ert--setup-results-buffer (stats listener buffer-name) - "Set up a test results buffer. - -STATS is the stats object; LISTENER is the results listener; -BUFFER-NAME, if non-nil, is the buffer name to use." - (unless buffer-name (setq buffer-name "*ert*")) - (let ((buffer (get-buffer-create buffer-name))) - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (buffer-disable-undo) - (erase-buffer) - (ert-results-mode) - ;; Erase buffer again in case switching out of the previous - ;; mode inserted anything. (This happens e.g. when switching - ;; from ert-results-mode to ert-results-mode when - ;; font-lock-mode turns itself off in change-major-mode-hook.) - (erase-buffer) - (set (make-local-variable 'font-lock-function) - 'ert--results-font-lock-function) - (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) - (set (make-local-variable 'ert--results-ewoc) ewoc) - (set (make-local-variable 'ert--results-stats) stats) - (set (make-local-variable 'ert--results-progress-bar-string) - (make-string (ert-stats-total stats) - (ert-char-for-test-result nil t))) - (set (make-local-variable 'ert--results-listener) listener) - (loop for test across (ert--stats-tests stats) do - (ewoc-enter-last ewoc - (make-ert--ewoc-entry :test test :hidden-p t))) - (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) - (goto-char (1- (point-max))) - buffer))))) - - -(defvar ert--selector-history nil - "List of recent test selectors read from terminal.") - -;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? -;; They are needed only for our automated self-tests at the moment. -;; Or should there be some other mechanism? -;;;###autoload -(defun ert-run-tests-interactively (selector - &optional output-buffer-name message-fn) - "Run the tests specified by SELECTOR and display the results in a buffer. - -SELECTOR works as described in `ert-select-tests'. -OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they -are used for automated self-tests and specify which buffer to use -and how to display message." - (interactive - (list (let ((default (if ert--selector-history - ;; Can't use `first' here as this form is - ;; not compiled, and `first' is not - ;; defined without cl. - (car ert--selector-history) - "t"))) - (read-from-minibuffer (if (null default) - "Run tests: " - (format "Run tests (default %s): " default)) - nil nil t 'ert--selector-history - default nil)) - nil)) - (unless message-fn (setq message-fn 'message)) - (lexical-let ((output-buffer-name output-buffer-name) - buffer - listener - (message-fn message-fn)) - (setq listener - (lambda (event-type &rest event-args) - (ecase event-type - (run-started - (destructuring-bind (stats) event-args - (setq buffer (ert--setup-results-buffer stats - listener - output-buffer-name)) - (pop-to-buffer buffer))) - (run-ended - (destructuring-bind (stats abortedp) event-args - (funcall message-fn - "%sRan %s tests, %s results were as expected%s" - (if (not abortedp) - "" - "Aborted: ") - (ert-stats-total stats) - (ert-stats-completed-expected stats) - (let ((unexpected - (ert-stats-completed-unexpected stats))) - (if (zerop unexpected) - "" - (format ", %s unexpected" unexpected)))) - (ert--results-update-stats-display (with-current-buffer buffer - ert--results-ewoc) - stats))) - (test-started - (destructuring-bind (stats test) event-args - (with-current-buffer buffer - (let* ((ewoc ert--results-ewoc) - (pos (ert--stats-test-pos stats test)) - (node (ewoc-nth ewoc pos))) - (assert node) - (setf (ert--ewoc-entry-test (ewoc-data node)) test) - (aset ert--results-progress-bar-string pos - (ert-char-for-test-result nil t)) - (ert--results-update-stats-display-maybe ewoc stats) - (ewoc-invalidate ewoc node))))) - (test-ended - (destructuring-bind (stats test result) event-args - (with-current-buffer buffer - (let* ((ewoc ert--results-ewoc) - (pos (ert--stats-test-pos stats test)) - (node (ewoc-nth ewoc pos))) - (when (ert--ewoc-entry-hidden-p (ewoc-data node)) - (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) - (ert-test-result-expected-p test result))) - (aset ert--results-progress-bar-string pos - (ert-char-for-test-result result - (ert-test-result-expected-p - test result))) - (ert--results-update-stats-display-maybe ewoc stats) - (ewoc-invalidate ewoc node)))))))) - (ert-run-tests - selector - listener))) -;;;###autoload -(defalias 'ert 'ert-run-tests-interactively) - - -;;; Simple view mode for auxiliary information like stack traces or -;;; messages. Mainly binds "q" for quit. - -(define-derived-mode ert-simple-view-mode special-mode "ERT-View" - "Major mode for viewing auxiliary information in ERT.") - -;;; Commands and button actions for the results buffer. - -(define-derived-mode ert-results-mode special-mode "ERT-Results" - "Major mode for viewing results of ERT test runs.") - -(loop for (key binding) in - '(;; Stuff that's not in the menu. - ("\t" forward-button) - ([backtab] backward-button) - ("j" ert-results-jump-between-summary-and-result) - ("L" ert-results-toggle-printer-limits-for-test-at-point) - ("n" ert-results-next-test) - ("p" ert-results-previous-test) - ;; Stuff that is in the menu. - ("R" ert-results-rerun-all-tests) - ("r" ert-results-rerun-test-at-point) - ("d" ert-results-rerun-test-at-point-debugging-errors) - ("." ert-results-find-test-at-point-other-window) - ("b" ert-results-pop-to-backtrace-for-test-at-point) - ("m" ert-results-pop-to-messages-for-test-at-point) - ("l" ert-results-pop-to-should-forms-for-test-at-point) - ("h" ert-results-describe-test-at-point) - ("D" ert-delete-test) - ("T" ert-results-pop-to-timings) - ) - do - (define-key ert-results-mode-map key binding)) - -(easy-menu-define ert-results-mode-menu ert-results-mode-map - "Menu for `ert-results-mode'." - '("ERT Results" - ["Re-run all tests" ert-results-rerun-all-tests] - "--" - ["Re-run test" ert-results-rerun-test-at-point] - ["Debug test" ert-results-rerun-test-at-point-debugging-errors] - ["Show test definition" ert-results-find-test-at-point-other-window] - "--" - ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] - ["Show messages" ert-results-pop-to-messages-for-test-at-point] - ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] - ["Describe test" ert-results-describe-test-at-point] - "--" - ["Delete test" ert-delete-test] - "--" - ["Show execution time of each test" ert-results-pop-to-timings] - )) - -(define-button-type 'ert--results-progress-bar-button - 'action #'ert--results-progress-bar-button-action - 'help-echo "mouse-2, RET: Reveal test result") - -(define-button-type 'ert--test-name-button - 'action #'ert--test-name-button-action - 'help-echo "mouse-2, RET: Find test definition") - -(define-button-type 'ert--results-expand-collapse-button - 'action #'ert--results-expand-collapse-button-action - 'help-echo "mouse-2, RET: Expand/collapse test result") - -(defun ert--results-test-node-or-null-at-point () - "If point is on a valid ewoc node, return it; return nil otherwise. - -To be used in the ERT results buffer." - (let* ((ewoc ert--results-ewoc) - (node (ewoc-locate ewoc))) - ;; `ewoc-locate' will return an arbitrary node when point is on - ;; header or footer, or when all nodes are invisible. So we need - ;; to validate its return value here. - ;; - ;; Update: I'm seeing nil being returned in some cases now, - ;; perhaps this has been changed? - (if (and node - (>= (point) (ewoc-location node)) - (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) - node - nil))) - -(defun ert--results-test-node-at-point () - "If point is on a valid ewoc node, return it; signal an error otherwise. - -To be used in the ERT results buffer." - (or (ert--results-test-node-or-null-at-point) - (error "No test at point"))) - -(defun ert-results-next-test () - "Move point to the next test. - -To be used in the ERT results buffer." - (interactive) - (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next - "No tests below")) - -(defun ert-results-previous-test () - "Move point to the previous test. - -To be used in the ERT results buffer." - (interactive) - (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev - "No tests above")) - -(defun ert--results-move (node ewoc-fn error-message) - "Move point from NODE to the previous or next node. - -EWOC-FN specifies the direction and should be either `ewoc-prev' -or `ewoc-next'. If there are no more nodes in that direction, an -error is signalled with the message ERROR-MESSAGE." - (loop - (setq node (funcall ewoc-fn ert--results-ewoc node)) - (when (null node) - (error "%s" error-message)) - (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) - (goto-char (ewoc-location node)) - (return)))) - -(defun ert--results-expand-collapse-button-action (button) - "Expand or collapse the test node BUTTON belongs to." - (let* ((ewoc ert--results-ewoc) - (node (save-excursion - (goto-char (ert--button-action-position)) - (ert--results-test-node-at-point))) - (entry (ewoc-data node))) - (setf (ert--ewoc-entry-expanded-p entry) - (not (ert--ewoc-entry-expanded-p entry))) - (ewoc-invalidate ewoc node))) - -(defun ert-results-find-test-at-point-other-window () - "Find the definition of the test at point in another window. - -To be used in the ERT results buffer." - (interactive) - (let ((name (ert-test-at-point))) - (unless name - (error "No test at point")) - (ert-find-test-other-window name))) - -(defun ert--test-name-button-action (button) - "Find the definition of the test BUTTON belongs to, in another window." - (let ((name (button-get button 'ert-test-name))) - (ert-find-test-other-window name))) - -(defun ert--ewoc-position (ewoc node) - ;; checkdoc-order: nil - "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." - (loop for i from 0 - for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) - do (when (eql node node-here) - (return i)) - finally (return nil))) - -(defun ert-results-jump-between-summary-and-result () - "Jump back and forth between the test run summary and individual test results. - -From an ewoc node, jumps to the character that represents the -same test in the progress bar, and vice versa. - -To be used in the ERT results buffer." - ;; Maybe this command isn't actually needed much, but if it is, it - ;; seems like an indication that the UI design is not optimal. If - ;; jumping back and forth between a summary at the top of the buffer - ;; and the error log in the remainder of the buffer is useful, then - ;; the summary apparently needs to be easily accessible from the - ;; error log, and perhaps it would be better to have it in a - ;; separate buffer to keep it visible. - (interactive) - (let ((ewoc ert--results-ewoc) - (progress-bar-begin ert--results-progress-bar-button-begin)) - (cond ((ert--results-test-node-or-null-at-point) - (let* ((node (ert--results-test-node-at-point)) - (pos (ert--ewoc-position ewoc node))) - (goto-char (+ progress-bar-begin pos)))) - ((and (<= progress-bar-begin (point)) - (< (point) (button-end (button-at progress-bar-begin)))) - (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) - (entry (ewoc-data node))) - (when (ert--ewoc-entry-hidden-p entry) - (setf (ert--ewoc-entry-hidden-p entry) nil) - (ewoc-invalidate ewoc node)) - (ewoc-goto-node ewoc node))) - (t - (goto-char progress-bar-begin))))) - -(defun ert-test-at-point () - "Return the name of the test at point as a symbol, or nil if none." - (or (and (eql major-mode 'ert-results-mode) - (let ((test (ert--results-test-at-point-no-redefinition))) - (and test (ert-test-name test)))) - (let* ((thing (thing-at-point 'symbol)) - (sym (intern-soft thing))) - (and (ert-test-boundp sym) - sym)))) - -(defun ert--results-test-at-point-no-redefinition () - "Return the test at point, or nil. - -To be used in the ERT results buffer." - (assert (eql major-mode 'ert-results-mode)) - (if (ert--results-test-node-or-null-at-point) - (let* ((node (ert--results-test-node-at-point)) - (test (ert--ewoc-entry-test (ewoc-data node)))) - test) - (let ((progress-bar-begin ert--results-progress-bar-button-begin)) - (when (and (<= progress-bar-begin (point)) - (< (point) (button-end (button-at progress-bar-begin)))) - (let* ((test-index (- (point) progress-bar-begin)) - (test (aref (ert--stats-tests ert--results-stats) - test-index))) - test))))) - -(defun ert--results-test-at-point-allow-redefinition () - "Look up the test at point, and check whether it has been redefined. - -To be used in the ERT results buffer. - -Returns a list of two elements: the test (or nil) and a symbol -specifying whether the test has been redefined. - -If a new test has been defined with the same name as the test at -point, replaces the test at point with the new test, and returns -the new test and the symbol `redefined'. - -If the test has been deleted, returns the old test and the symbol -`deleted'. - -If the test is still current, returns the test and the symbol nil. - -If there is no test at point, returns a list with two nils." - (let ((test (ert--results-test-at-point-no-redefinition))) - (cond ((null test) - `(nil nil)) - ((null (ert-test-name test)) - `(,test nil)) - (t - (let* ((name (ert-test-name test)) - (new-test (and (ert-test-boundp name) - (ert-get-test name)))) - (cond ((eql test new-test) - `(,test nil)) - ((null new-test) - `(,test deleted)) - (t - (ert--results-update-after-test-redefinition - (ert--stats-test-pos ert--results-stats test) - new-test) - `(,new-test redefined)))))))) - -(defun ert--results-update-after-test-redefinition (pos new-test) - "Update results buffer after the test at pos POS has been redefined. - -Also updates the stats object. NEW-TEST is the new test -definition." - (let* ((stats ert--results-stats) - (ewoc ert--results-ewoc) - (node (ewoc-nth ewoc pos)) - (entry (ewoc-data node))) - (ert--stats-set-test-and-result stats pos new-test nil) - (setf (ert--ewoc-entry-test entry) new-test - (aref ert--results-progress-bar-string pos) (ert-char-for-test-result - nil t)) - (ewoc-invalidate ewoc node)) - nil) - -(defun ert--button-action-position () - "The buffer position where the last button action was triggered." - (cond ((integerp last-command-event) - (point)) - ((eventp last-command-event) - (posn-point (event-start last-command-event))) - (t (assert nil)))) - -(defun ert--results-progress-bar-button-action (button) - "Jump to details for the test represented by the character clicked in BUTTON." - (goto-char (ert--button-action-position)) - (ert-results-jump-between-summary-and-result)) - -(defun ert-results-rerun-all-tests () - "Re-run all tests, using the same selector. - -To be used in the ERT results buffer." - (interactive) - (assert (eql major-mode 'ert-results-mode)) - (let ((selector (ert--stats-selector ert--results-stats))) - (ert-run-tests-interactively selector (buffer-name)))) - -(defun ert-results-rerun-test-at-point () - "Re-run the test at point. - -To be used in the ERT results buffer." - (interactive) - (destructuring-bind (test redefinition-state) - (ert--results-test-at-point-allow-redefinition) - (when (null test) - (error "No test at point")) - (let* ((stats ert--results-stats) - (progress-message (format "Running %stest %S" - (ecase redefinition-state - ((nil) "") - (redefined "new definition of ") - (deleted "deleted ")) - (ert-test-name test)))) - ;; Need to save and restore point manually here: When point is on - ;; the first visible ewoc entry while the header is updated, point - ;; moves to the top of the buffer. This is undesirable, and a - ;; simple `save-excursion' doesn't prevent it. - (let ((point (point))) - (unwind-protect - (unwind-protect - (progn - (message "%s..." progress-message) - (ert-run-or-rerun-test stats test - ert--results-listener)) - (ert--results-update-stats-display ert--results-ewoc stats) - (message "%s...%s" - progress-message - (let ((result (ert-test-most-recent-result test))) - (ert-string-for-test-result - result (ert-test-result-expected-p test result))))) - (goto-char point)))))) - -(defun ert-results-rerun-test-at-point-debugging-errors () - "Re-run the test at point with `ert-debug-on-error' bound to t. - -To be used in the ERT results buffer." - (interactive) - (let ((ert-debug-on-error t)) - (ert-results-rerun-test-at-point))) - -(defun ert-results-pop-to-backtrace-for-test-at-point () - "Display the backtrace for the test at point. - -To be used in the ERT results buffer." - (interactive) - (let* ((test (ert--results-test-at-point-no-redefinition)) - (stats ert--results-stats) - (pos (ert--stats-test-pos stats test)) - (result (aref (ert--stats-test-results stats) pos))) - (etypecase result - (ert-test-passed (error "Test passed, no backtrace available")) - (ert-test-result-with-condition - (let ((backtrace (ert-test-result-with-condition-backtrace result)) - (buffer (get-buffer-create "*ERT Backtrace*"))) - (pop-to-buffer buffer) - (let ((inhibit-read-only t)) - (buffer-disable-undo) - (erase-buffer) - (ert-simple-view-mode) - ;; Use unibyte because `debugger-setup-buffer' also does so. - (set-buffer-multibyte nil) - (setq truncate-lines t) - (ert--print-backtrace backtrace) - (debugger-make-xrefs) - (goto-char (point-min)) - (insert "Backtrace for test `") - (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n"))))))) - -(defun ert-results-pop-to-messages-for-test-at-point () - "Display the part of the *Messages* buffer generated during the test at point. - -To be used in the ERT results buffer." - (interactive) - (let* ((test (ert--results-test-at-point-no-redefinition)) - (stats ert--results-stats) - (pos (ert--stats-test-pos stats test)) - (result (aref (ert--stats-test-results stats) pos))) - (let ((buffer (get-buffer-create "*ERT Messages*"))) - (pop-to-buffer buffer) - (let ((inhibit-read-only t)) - (buffer-disable-undo) - (erase-buffer) - (ert-simple-view-mode) - (insert (ert-test-result-messages result)) - (goto-char (point-min)) - (insert "Messages for test `") - (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n"))))) - -(defun ert-results-pop-to-should-forms-for-test-at-point () - "Display the list of `should' forms executed during the test at point. - -To be used in the ERT results buffer." - (interactive) - (let* ((test (ert--results-test-at-point-no-redefinition)) - (stats ert--results-stats) - (pos (ert--stats-test-pos stats test)) - (result (aref (ert--stats-test-results stats) pos))) - (let ((buffer (get-buffer-create "*ERT list of should forms*"))) - (pop-to-buffer buffer) - (let ((inhibit-read-only t)) - (buffer-disable-undo) - (erase-buffer) - (ert-simple-view-mode) - (if (null (ert-test-result-should-forms result)) - (insert "\n(No should forms during this test.)\n") - (loop for form-description in (ert-test-result-should-forms result) - for i from 1 do - (insert "\n") - (insert (format "%s: " i)) - (let ((begin (point))) - (ert--pp-with-indentation-and-newline form-description) - (ert--make-xrefs-region begin (point))))) - (goto-char (point-min)) - (insert "`should' forms executed during test `") - (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n") - (insert "\n") - (insert (concat "(Values are shallow copies and may have " - "looked different during the test if they\n" - "have been modified destructively.)\n")) - (forward-line 1))))) - -(defun ert-results-toggle-printer-limits-for-test-at-point () - "Toggle how much of the condition to print for the test at point. - -To be used in the ERT results buffer." - (interactive) - (let* ((ewoc ert--results-ewoc) - (node (ert--results-test-node-at-point)) - (entry (ewoc-data node))) - (setf (ert--ewoc-entry-extended-printer-limits-p entry) - (not (ert--ewoc-entry-extended-printer-limits-p entry))) - (ewoc-invalidate ewoc node))) - -(defun ert-results-pop-to-timings () - "Display test timings for the last run. - -To be used in the ERT results buffer." - (interactive) - (let* ((stats ert--results-stats) - (start-times (ert--stats-test-start-times stats)) - (end-times (ert--stats-test-end-times stats)) - (buffer (get-buffer-create "*ERT timings*")) - (data (loop for test across (ert--stats-tests stats) - for start-time across (ert--stats-test-start-times stats) - for end-time across (ert--stats-test-end-times stats) - collect (list test - (float-time (subtract-time end-time - start-time)))))) - (setq data (sort data (lambda (a b) - (> (second a) (second b))))) - (pop-to-buffer buffer) - (let ((inhibit-read-only t)) - (buffer-disable-undo) - (erase-buffer) - (ert-simple-view-mode) - (if (null data) - (insert "(No data)\n") - (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) - (loop for (test time) in data - for cumul-time = time then (+ cumul-time time) - for i from 1 do - (let ((begin (point))) - (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) - (ert-insert-test-name-button (ert-test-name test)) - (insert "\n")))) - (goto-char (point-min)) - (insert "Tests by run time (seconds):\n\n") - (forward-line 1)))) - -;;;###autoload -(defun ert-describe-test (test-or-test-name) - "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." - (interactive (list (ert-read-test-name-at-point "Describe test"))) - (when (< emacs-major-version 24) - (error "Requires Emacs 24")) - (let (test-name - test-definition) - (etypecase test-or-test-name - (symbol (setq test-name test-or-test-name - test-definition (ert-get-test test-or-test-name))) - (ert-test (setq test-name (ert-test-name test-or-test-name) - test-definition test-or-test-name))) - (help-setup-xref (list #'ert-describe-test test-or-test-name) - (called-interactively-p 'interactive)) - (save-excursion - (with-help-window (help-buffer) - (with-current-buffer (help-buffer) - (insert (if test-name (format "%S" test-name) "")) - (insert " is a test") - (let ((file-name (and test-name - (symbol-file test-name 'ert-deftest)))) - (when file-name - (insert " defined in `" (file-name-nondirectory file-name) "'") - (save-excursion - (re-search-backward "`\\([^`']+\\)'" nil t) - (help-xref-button 1 'help-function-def test-name file-name))) - (insert ".") - (fill-region-as-paragraph (point-min) (point)) - (insert "\n\n") - (unless (and (ert-test-boundp test-name) - (eql (ert-get-test test-name) test-definition)) - (let ((begin (point))) - (insert "Note: This test has been redefined or deleted, " - "this documentation refers to an old definition.") - (fill-region-as-paragraph begin (point))) - (insert "\n\n")) - (insert (or (ert-test-documentation test-definition) - "It is not documented.") - "\n"))))))) - -(defun ert-results-describe-test-at-point () - "Display the documentation of the test at point. - -To be used in the ERT results buffer." - (interactive) - (ert-describe-test (ert--results-test-at-point-no-redefinition))) - - -;;; Actions on load/unload. - -(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) -(add-to-list 'minor-mode-alist '(ert--current-run-stats - (:eval - (ert--tests-running-mode-line-indicator)))) -(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) - -(defun ert--unload-function () - "Unload function to undo the side-effects of loading ert.el." - (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) - (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) - (ert--remove-from-list 'emacs-lisp-mode-hook - 'ert--activate-font-lock-keywords) - nil) - -(defvar ert-unload-hook '()) -(add-hook 'ert-unload-hook 'ert--unload-function) - - -(provide 'ert) - -;;; ert.el ends here diff --git a/goto-chg.el b/goto-chg.el deleted file mode 100644 index 3881706..0000000 --- a/goto-chg.el +++ /dev/null @@ -1,317 +0,0 @@ -;;; goto-chg.el --- goto last change -;;-------------------------------------------------------------------- -;; -;; Copyright (C) 2002-2008, David Andersson -;; -;; This program is free software; you can 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., 59 Temple Place, Suite 330, Boston, -;; MA 02111-1307 USA -;; -;;------------------------------------------------------------------- -;; -;; Author: David Andersson -;; Created: 16 May 2002 -;; Version: 1.4 -;; -;;; Commentary: -;; -;; Goto Last Change -;; -;; Goto the point of the most recent edit in the buffer. -;; When repeated, goto the second most recent edit, etc. -;; Negative argument, C-u -, for reverse direction. -;; Works by looking into buffer-undo-list to find points of edit. -;; -;; You would probably like to bind this command to a key. -;; For example in your ~/.emacs: -;; -;; (require 'goto-chg) -;; -;; (global-set-key [(control ?.)] 'goto-last-change) -;; (global-set-key [(control ?,)] 'goto-last-change-reverse) -;; -;; Works with emacs-19.29, 19.31, 20.3, 20.7, 21.1, 21.4 and 22.1. -;; Works with XEmacs-20.4 and 21.4 (but see todo about `last-command' below) -;; -;;-------------------------------------------------------------------- -;; History -;; -;; Ver 1.4 2008-09-20 David Andersson -;; Improved property change description; Update comments. -;; Ver 1.3 2007-03-14 David Andersson -;; Added `goto-last-change-reverse' -;; Ver 1.2 2003-04-06 David Andersson -;; Don't let repeating error depthen glc-probe-depth. -;; Ver 1.1 2003-04-06 David Andersson -;; Zero arg describe changes. Negative arg go back. -;; Autoload. Remove message using nil in stead of an empty string. -;; Ver 1.0 2002-05-18 David Andersson -;; Initial version -;; -;;-------------------------------------------------------------------- -;; -;;todo: Rename "goto-chg.el" -> "gotochange.el" or "goto-chgs" ? -;;todo: Rename function goto-last-change -> goto-last-edit ? -;;todo: Rename adjective "-last-" -> "-latest-" or "-most-recent-" ? -;;todo: There are some, maybe useful, funcs for region undo -;; in simple.el in emacs 20. Take a look. -;;todo: Add functionality to visit changed point in text order, not only in -;; chronological order. (Naa, highlight-changes-mode does that). -;;todo: Inverse indication that a change has been saved or not -;;todo: Highlight the range of text involved in the last change? -;;todo: Function that goes in reverse direction. Either a function -;; 'goto-next-change' only callable after 'goto-last-change' -;; or enter a minor mode similar to isearch. -;;todo: See session-jump-to-last-change in session.el? -;;todo: Unhide invisible text (e.g. outline mode) like isearch do. -;;todo: XEmacs sets last-command to `t' after an error, so you cannot reverse -;; after "No furter change info". Should we bother? -;;todo: Try distinguish "No further change info" (end of truncated undo list) -;; and "No further changes" (end of a complete undo list). -;; -;;-------------------------------------------------------------------- - -;;; Code: - -(defvar glc-default-span 8 "*goto-last-change don't visit the same point twice. glc-default-span tells how far around a visited point not to visit again.") -(defvar glc-current-span 8 "Internal for goto-last-change.\nA copy of glc-default-span or the ARG passed to goto-last-change.") -(defvar glc-probe-depth 0 "Internal for goto-last-change.\nIt is non-zero between successive goto-last-change.") - -;;todo: Find begin and end of line, then use it somewhere - -(defun glc-center-ellipsis (str maxlen &optional ellipsis) - "Truncate STRING in the middle to length MAXLEN. -If STRING is max MAXLEN just return the string. -Optional third argument is the replacement, which defaults to \"...\"." - (if (<= (length str) maxlen) - str - ;; else - (let* ((lipsis (or ellipsis "...")) - (i (/ (- maxlen (length lipsis)) 2))) - (concat (substring str 0 i) - lipsis - (substring str (- i)))))) - -(defun glc-adjust-pos2 (pos p1 p2 adj) - ;; Helper function to glc-adjust-pos - (cond ((<= pos (- p1 glc-current-span)) - pos) - ((> pos (+ p2 glc-current-span)) - (+ pos adj)) - ((zerop glc-current-span) - p1) - (t - nil))) - -(defun glc-adjust-pos (pos e) - "Given POS, a buffer position before the edit E, compute and return -the \"same\" buffer position after E happened. -Exception: return nil if POS is closer than `glc-current-span' to the edit E. -\nInsertion edits before POS returns a larger value. -Deletion edits before POS returns a smaller value. -\nThe edit E is an entry from the `buffer-undo-list'. See for details." - (cond ((atom e) ; nil==cmd boundary, or, num==changed pos - pos) - ((numberp (car e)) ; (beg . end)==insertion - (glc-adjust-pos2 pos (car e) (car e) (- (cdr e) (car e)))) -;; (cond ((< pos (- (car e) glc-current-span)) pos) -;; ((> pos (+ (car e) glc-current-span)) (+ pos (- (cdr e) (car e)))) -;; (t nil))) - ((stringp (car e)) ; (string . pos)==deletion - (glc-adjust-pos2 pos (abs (cdr e)) (+ (abs (cdr e)) (length (car e))) (- (length (car e))))) -;; (cond ((< pos (- (abs (cdr e)) glc-current-span)) pos) -;; ((> pos (+ (abs (cdr e)) (length (car e)) glc-current-span)) (- pos (length (car e)))) -;; (t nil))) - ((null (car e)) ; (nil prop val beg . end)==prop change - (glc-adjust-pos2 pos (nth 3 e) (nthcdr 4 e) 0)) -;; (cond ((< pos (- (nth 3 e) glc-current-span)) pos) -;; ((> pos (+ (nthcdr 4 e) glc-current-span)) pos) -;; (t nil))) - (t ; (marker . dist)==marker moved - pos))) - -;; If recursive in stead of iterative (while), it tends to fill the call stack. -;; (Isn't it tail optimized?) -(defun glc-adjust-list (r) - "R is list of edit entries in chronological order. -Pick the point of the first edit entry and update that point with -the second, third, etc, edit entries. Return the final updated point, -or nil if the point was closer than `glc-current-span' to some edit in R. -\nR is basically a reversed slice from the buffer-undo-list." - (if r - ;; Get pos - (let ((pos (glc-get-pos (car r)))) - (setq r (cdr r)) - ;; Walk back in reverse list - (while (and r pos) - (setq pos (glc-adjust-pos pos (car r)) - r (cdr r))) - pos) - ;; else - nil)) - -(defun glc-get-pos (e) - "If E represents an edit, return a position value in E, the position -where the edit took place. Return nil if E represents no real change. -\nE is a entry in the buffer-undo-list." - (cond ((numberp e) e) ; num==changed position - ((atom e) nil) ; nil==command boundary - ((numberp (car e)) (cdr e)) ; (beg . end)==insertion - ((stringp (car e)) (abs (cdr e))) ; (string . pos)==deletion - ((null (car e)) (nthcdr 4 e)) ; (nil ...)==text property change - ((atom (car e)) nil) ; (t ...)==file modification time - (t nil))) ; (marker ...)==marker moved - -(defun glc-get-descript (e &optional n) - "If E represents an edit, return a short string describing E. -Return nil if E represents no real change. -\nE is a entry in the buffer-undo-list." - (let ((nn (or (format "T-%d: " n) ""))) - (cond ((numberp e) "New position") ; num==changed position - ((atom e) nil) ; nil==command boundary - ((numberp (car e)) ; (beg . end)==insertion - (if (and n (< n 2)) - (format "%sInserted %d chars \"%s\"" nn (- (cdr e) (car e)) - (glc-center-ellipsis (buffer-substring (car e) (cdr e)) 60)) - ;; else - ;; An older insert. The inserted text cannot easily be computed. - ;; Just show the char count. - (format "%sInserted %d chars" nn (- (cdr e) (car e))))) - ((stringp (car e)) ; (string . pos)==deletion - (format "%sDeleted \"%s\"" nn (glc-center-ellipsis (car e) 60))) - ((null (car e)) ; (nil ...)==text property change - (format "%sProperty change" nn)) - ((atom (car e)) nil) ; (t ...)==file modification time - (t nil)))) ; (marker ...)==marker moved - -(defun glc-is-positionable (e) - "Return non-nil if E is an insertion, deletion or text property change. -\nE is a entry in the buffer-undo-list." - (and (not (numberp e)) (glc-get-pos e))) - -(defun glc-is-filetime (e) - "Return t if E indicates a buffer became \"modified\", -that is, it was previously saved or unchanged. Nil otherwise." - (and (listp e) (eq (car e) t))) - -;;;###autoload -(defun goto-last-change (arg) -"Go to the point where the last edit was made in the current buffer. -Repeat the command to go to the second last edit, etc. -A preceding \\[universal-argument] - (minus) will reverse direction for the next command in -the sequence, to go back to a more recent edit. -\nIt does not go to the same point twice even if there has been many edits -there. I call the minimal distance between distinguishable edits \"span\". -Set variable `glc-default-span' to control how close is \"the same point\". -Default span is 8. -The span can be changed temporarily with \\[universal-argument] right before \\[goto-last-change]: -\\[universal-argument] set current span to that number, -\\[universal-argument] (no number) multiplies span by 4, starting with default. -The so set span remains until it is changed again with \\[universal-argument], or the consecutive -repetition of this command is ended by any other command. -\nWhen span is zero (i.e. \\[universal-argument] 0) subsequent \\[goto-last-change] visits each and -every point of edit and a message shows what change was made there. -In this case it may go to the same point twice. -\nThis command uses undo information. If undo is disabled, so is this command. -At times, when undo information becomes too large, the oldest information is -discarded. See variable `undo-limit'." - (interactive "P") - (cond ((not (eq this-command last-command)) - ;; Start a glc sequence - ;; Don't go to current point if last command was an obvious edit - ;; (yank or self-insert, but not kill-region). Makes it easier to - ;; jump back and forth when copying seleced lines. - (setq glc-probe-depth (if (memq last-command '(yank self-insert-command)) 1 0) - glc-direction 1 - glc-current-span glc-default-span) - (if (< (prefix-numeric-value arg) 0) - (error "Negative arg: Cannot reverse as the first operation")))) - (cond ((null buffer-undo-list) - (error "Buffer has not been changed")) - ((eq buffer-undo-list t) - (error "No change info (undo is disabled)"))) - (cond ((numberp arg) ; Numeric arg sets span - (setq glc-current-span (abs arg))) - ((consp arg) ; C-u's multiply previous span by 4 - (setq glc-current-span (* (abs (car arg)) glc-default-span)) - (message "Current span is %d chars" glc-current-span))) ;todo: keep message with "waiting" and "is saved" - (cond ((< (prefix-numeric-value arg) 0) - (setq glc-direction -1)) - (t - (setq glc-direction 1))) - (let (rev ; Reversed (and filtered) undo list - pos ; The pos we look for, nil until found - (n 0) ; Steps in undo list (length of 'rev') - (l buffer-undo-list) - (passed-save-entry (not (buffer-modified-p))) - (new-probe-depth glc-probe-depth)) - ;; Walk back and forth in the buffer-undo-list, each time one step deeper, - ;; until we can walk back the whole list with a 'pos' that is not coming - ;; too close to another edit. - (while (null pos) - (setq new-probe-depth (+ new-probe-depth glc-direction)) - (if (< glc-direction 0) - (setq rev () - n 0 - l buffer-undo-list - passed-save-entry (not (buffer-modified-p)))) - (if (< new-probe-depth 1) - (error "No later change info")) - (if (> n 150) - (message "working...")) - ;; Walk forward in buffer-undo-list, glc-probe-depth steps. - ;; Build reverse list along the way - (while (< n new-probe-depth) - (cond ((null l) - ;(setq this-command t) ; Disrupt repeat sequence - (error "No further change info")) - ((glc-is-positionable (car l)) - (setq n (1+ n) - rev (cons (car l) rev))) - ((or passed-save-entry (glc-is-filetime (car l))) - (setq passed-save-entry t))) - (setq l (cdr l))) - ;; Walk back in reverse list, from older to newer edits. - ;; Adjusting pos along the way. - (setq pos (glc-adjust-list rev))) - ;; Found a place not previously visited, in 'pos'. - ;; (An error have been issued if nothing (more) found.) - (if (> n 150) - (message nil)) ; remove message "working..." - (if (and (= glc-current-span 0) (glc-get-descript (car rev) n)) - (message "%s" (glc-get-descript (car rev) n)) - ;; else - (if passed-save-entry - (message "(This change is saved)"))) - (setq glc-probe-depth new-probe-depth) - (goto-char pos))) - -;; ;;;###autoload -(defun goto-last-change-reverse (arg) - (interactive "P") - ;; Negate arg, all kinds - (cond ((eq arg nil) (setq arg '-)) - ((eq arg '-) (setq arg nil)) - ((listp arg) (setq arg (list (- (car arg))))) - (t (setq arg (- arg)))) - ;; Make 'goto-last-change-reverse' look like 'goto-last-change' - (cond ((eq last-command this-command) - (setq last-command 'goto-last-change))) - (setq this-command 'goto-last-change) - ;; Call 'goto-last-change' to do the job - (goto-last-change arg)) - -(provide 'goto-chg) - -;;; goto-chg.el ends here diff --git a/lib/README b/lib/README new file mode 100644 index 0000000..16766cb --- /dev/null +++ b/lib/README @@ -0,0 +1,6 @@ +This folder contains external libraries that are freely distributable +under the GNU GPL license. They may not be up to date. + +Emacs does not add subdirectories to the `load-path' by default. +Therefore this directory is not covered by the installation +instructions. diff --git a/lib/ert.el b/lib/ert.el new file mode 100644 index 0000000..5bd8fd0 --- /dev/null +++ b/lib/ert.el @@ -0,0 +1,2549 @@ +;;; ert.el --- Emacs Lisp Regression Testing + +;; Copyright (C) 2007-2008, 2010-2011 Free Software Foundation, Inc. + +;; Author: Christian Ohler +;; Keywords: lisp, tools + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; ERT is a tool for automated testing in Emacs Lisp. Its main +;; features are facilities for defining and running test cases and +;; reporting the results as well as for debugging test failures +;; interactively. +;; +;; The main entry points are `ert-deftest', which is similar to +;; `defun' but defines a test, and `ert-run-tests-interactively', +;; which runs tests and offers an interactive interface for inspecting +;; results and debugging. There is also +;; `ert-run-tests-batch-and-exit' for non-interactive use. +;; +;; The body of `ert-deftest' forms resembles a function body, but the +;; additional operators `should', `should-not' and `should-error' are +;; available. `should' is similar to cl's `assert', but signals a +;; different error when its condition is violated that is caught and +;; processed by ERT. In addition, it analyzes its argument form and +;; records information that helps debugging (`assert' tries to do +;; something similar when its second argument SHOW-ARGS is true, but +;; `should' is more sophisticated). For information on `should-not' +;; and `should-error', see their docstrings. +;; +;; See ERT's info manual as well as the docstrings for more details. +;; To compile the manual, run `makeinfo ert.texinfo' in the ERT +;; directory, then C-u M-x info ert.info in Emacs to view it. +;; +;; To see some examples of tests written in ERT, see its self-tests in +;; ert-tests.el. Some of these are tricky due to the bootstrapping +;; problem of writing tests for a testing tool, others test simple +;; functions and are straightforward. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'button) +(require 'debug) +(require 'easymenu) +(require 'ewoc) +(require 'find-func) +(require 'help) + + +;;; UI customization options. + +(defgroup ert () + "ERT, the Emacs Lisp regression testing tool." + :prefix "ert-" + :group 'lisp) + +(defface ert-test-result-expected '((((class color) (background light)) + :background "green1") + (((class color) (background dark)) + :background "green3")) + "Face used for expected results in the ERT results buffer." + :group 'ert) + +(defface ert-test-result-unexpected '((((class color) (background light)) + :background "red1") + (((class color) (background dark)) + :background "red3")) + "Face used for unexpected results in the ERT results buffer." + :group 'ert) + + +;;; Copies/reimplementations of cl functions. + +(defun ert--cl-do-remf (plist tag) + "Copy of `cl-do-remf'. Modify PLIST by removing TAG." + (let ((p (cdr plist))) + (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) + (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) + +(defun ert--remprop (sym tag) + "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." + (let ((plist (symbol-plist sym))) + (if (and plist (eq tag (car plist))) + (progn (setplist sym (cdr (cdr plist))) t) + (ert--cl-do-remf plist tag)))) + +(defun ert--remove-if-not (ert-pred ert-list) + "A reimplementation of `remove-if-not'. + +ERT-PRED is a predicate, ERT-LIST is the input list." + (loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) + +(defun ert--intersection (a b) + "A reimplementation of `intersection'. Intersect the sets A and B. + +Elements are compared using `eql'." + (loop for x in a + if (memql x b) + collect x)) + +(defun ert--set-difference (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eql'." + (loop for x in a + unless (memql x b) + collect x)) + +(defun ert--set-difference-eq (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eq'." + (loop for x in a + unless (memq x b) + collect x)) + +(defun ert--union (a b) + "A reimplementation of `union'. Compute the union of the sets A and B. + +Elements are compared using `eql'." + (append a (ert--set-difference b a))) + +(eval-and-compile + (defvar ert--gensym-counter 0)) + +(eval-and-compile + (defun ert--gensym (&optional prefix) + "Only allows string PREFIX, not compatible with CL." + (unless prefix (setq prefix "G")) + (make-symbol (format "%s%s" + prefix + (prog1 ert--gensym-counter + (incf ert--gensym-counter)))))) + +(defun ert--coerce-to-vector (x) + "Coerce X to a vector." + (when (char-table-p x) (error "Not supported")) + (if (vectorp x) + x + (vconcat x))) + +(defun* ert--remove* (x list &key key test) + "Does not support all the keywords of remove*." + (unless key (setq key #'identity)) + (unless test (setq test #'eql)) + (loop for y in list + unless (funcall test x (funcall key y)) + collect y)) + +(defun ert--string-position (c s) + "Return the position of the first occurrence of C in S, or nil if none." + (loop for i from 0 + for x across s + when (eql x c) return i)) + +(defun ert--mismatch (a b) + "Return index of first element that differs between A and B. + +Like `mismatch'. Uses `equal' for comparison." + (cond ((or (listp a) (listp b)) + (ert--mismatch (ert--coerce-to-vector a) + (ert--coerce-to-vector b))) + ((> (length a) (length b)) + (ert--mismatch b a)) + (t + (let ((la (length a)) + (lb (length b))) + (assert (arrayp a) t) + (assert (arrayp b) t) + (assert (<= la lb) t) + (loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (return (if (/= la lb) + la + (assert (equal a b) t) + nil))))))) + +(defun ert--subseq (seq start &optional end) + "Return a subsequence of SEQ from START to END." + (when (char-table-p seq) (error "Not supported")) + (let ((vector (substring (ert--coerce-to-vector seq) start end))) + (etypecase seq + (vector vector) + (string (concat vector)) + (list (append vector nil)) + (bool-vector (loop with result = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (return result))) + (char-table (assert nil))))) + +(defun ert-equal-including-properties (a b) + "Return t if A and B have similar structure and contents. + +This is like `equal-including-properties' except that it compares +the property values of text properties structurally (by +recursing) rather than with `eq'. Perhaps this is what +`equal-including-properties' should do in the first place; see +Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." + ;; This implementation is inefficient. Rather than making it + ;; efficient, let's hope bug 6581 gets fixed so that we can delete + ;; it altogether. + (not (ert--explain-equal-including-properties a b))) + + +;;; Defining and locating tests. + +;; The data structure that represents a test case. +(defstruct ert-test + (name nil) + (documentation nil) + (body (assert nil)) + (most-recent-result nil) + (expected-result-type ':passed) + (tags '())) + +(defun ert-test-boundp (symbol) + "Return non-nil if SYMBOL names a test." + (and (get symbol 'ert--test) t)) + +(defun ert-get-test (symbol) + "If SYMBOL names a test, return that. Signal an error otherwise." + (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) + (get symbol 'ert--test)) + +(defun ert-set-test (symbol definition) + "Make SYMBOL name the test DEFINITION, and return DEFINITION." + (when (eq symbol 'nil) + ;; We disallow nil since `ert-test-at-point' and related functions + ;; want to return a test name, but also need an out-of-band value + ;; on failure. Nil is the most natural out-of-band value; using 0 + ;; or "" or signalling an error would be too awkward. + ;; + ;; Note that nil is still a valid value for the `name' slot in + ;; ert-test objects. It designates an anonymous test. + (error "Attempt to define a test named nil")) + (put symbol 'ert--test definition) + definition) + +(defun ert-make-test-unbound (symbol) + "Make SYMBOL name no test. Return SYMBOL." + (ert--remprop symbol 'ert--test) + symbol) + +(defun ert--parse-keys-and-body (keys-and-body) + "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. + +KEYS-AND-BODY should have the form of a property list, with the +exception that only keywords are permitted as keys and that the +tail -- the body -- is a list of forms that does not start with a +keyword. + +Returns a two-element list containing the keys-and-values plist +and the body." + (let ((extracted-key-accu '()) + (remaining keys-and-body)) + (while (and (consp remaining) (keywordp (first remaining))) + (let ((keyword (pop remaining))) + (unless (consp remaining) + (error "Value expected after keyword %S in %S" + keyword keys-and-body)) + (when (assoc keyword extracted-key-accu) + (warn "Keyword %S appears more than once in %S" keyword + keys-and-body)) + (push (cons keyword (pop remaining)) extracted-key-accu))) + (setq extracted-key-accu (nreverse extracted-key-accu)) + (list (loop for (key . value) in extracted-key-accu + collect key + collect value) + remaining))) + +;;;###autoload +(defmacro* ert-deftest (name () &body docstring-keys-and-body) + "Define NAME (a symbol) as a test. + +BODY is evaluated as a `progn' when the test is run. It should +signal a condition on failure or just return if the test passes. + +`should', `should-not' and `should-error' are useful for +assertions in BODY. + +Use `ert' to run tests interactively. + +Tests that are expected to fail can be marked as such +using :expected-result. See `ert-test-result-type-p' for a +description of valid values for RESULT-TYPE. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +\[:tags '(TAG...)] BODY...)" + (declare (debug (&define :name test + name sexp [&optional stringp] + [&rest keywordp sexp] def-body)) + (doc-string 3) + (indent 2)) + (let ((documentation nil) + (documentation-supplied-p nil)) + (when (stringp (first docstring-keys-and-body)) + (setq documentation (pop docstring-keys-and-body) + documentation-supplied-p t)) + (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) + (ert--parse-keys-and-body docstring-keys-and-body) + `(progn + (ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when expected-result-supplied-p + `(:expected-result-type ,expected-result)) + ,@(when tags-supplied-p + `(:tags ,tags)) + :body (lambda () ,@body))) + ;; This hack allows `symbol-file' to associate `ert-deftest' + ;; forms with files, and therefore enables `find-function' to + ;; work with tests. However, it leads to warnings in + ;; `unload-feature', which doesn't know how to undefine tests + ;; and has no mechanism for extension. + (push '(ert-deftest . ,name) current-load-list) + ',name)))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-deftest 'lisp-indent-function 2) + (put 'ert-info 'lisp-indent-function 1)) + +(defvar ert--find-test-regexp + (concat "^\\s-*(ert-deftest" + find-function-space-re + "%s\\(\\s-\\|$\\)") + "The regexp the `find-function' mechanisms use for finding test definitions.") + + +(put 'ert-test-failed 'error-conditions '(error ert-test-failed)) +(put 'ert-test-failed 'error-message "Test failed") + +(defun ert-pass () + "Terminate the current test and mark it passed. Does not return." + (throw 'ert--pass nil)) + +(defun ert-fail (data) + "Terminate the current test and mark it failed. Does not return. +DATA is displayed to the user and should state the reason of the failure." + (signal 'ert-test-failed (list data))) + + +;;; The `should' macros. + +(defvar ert--should-execution-observer nil) + +(defun ert--signal-should-execution (form-description) + "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." + (when ert--should-execution-observer + (funcall ert--should-execution-observer form-description))) + +(defun ert--special-operator-p (thing) + "Return non-nil if THING is a symbol naming a special operator." + (and (symbolp thing) + (let ((definition (indirect-function thing t))) + (and (subrp definition) + (eql (cdr (subr-arity definition)) 'unevalled))))) + +(defun ert--expand-should-1 (whole form inner-expander) + "Helper function for the `should' macro and its variants." + (let ((form + ;; If `cl-macroexpand' isn't bound, the code that we're + ;; compiling doesn't depend on cl and thus doesn't need an + ;; environment arg for `macroexpand'. + (if (fboundp 'cl-macroexpand) + ;; Suppress warning about run-time call to cl funtion: we + ;; only call it if it's fboundp. + (with-no-warnings + (cl-macroexpand form (and (boundp 'cl-macro-environment) + cl-macro-environment))) + (macroexpand form)))) + (cond + ((or (atom form) (ert--special-operator-p (car form))) + (let ((value (ert--gensym "value-"))) + `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) + ,(funcall inner-expander + `(setq ,value ,form) + `(list ',whole :form ',form :value ,value) + value) + ,value))) + (t + (let ((fn-name (car form)) + (arg-forms (cdr form))) + (assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) + (let ((fn (ert--gensym "fn-")) + (args (ert--gensym "args-")) + (value (ert--gensym "value-")) + (default-value (ert--gensym "ert-form-evaluation-aborted-"))) + `(let ((,fn (function ,fn-name)) + (,args (list ,@arg-forms))) + (let ((,value ',default-value)) + ,(funcall inner-expander + `(setq ,value (apply ,fn ,args)) + `(nconc (list ',whole) + (list :form `(,,fn ,@,args)) + (unless (eql ,value ',default-value) + (list :value ,value)) + (let ((-explainer- + (and (symbolp ',fn-name) + (get ',fn-name 'ert-explainer)))) + (when -explainer- + (list :explanation + (apply -explainer- ,args))))) + value) + ,value)))))))) + +(defun ert--expand-should (whole form inner-expander) + "Helper function for the `should' macro and its variants. + +Analyzes FORM and returns an expression that has the same +semantics under evaluation but records additional debugging +information. + +INNER-EXPANDER should be a function and is called with two +arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM +is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is +an expression that returns a description of FORM. INNER-EXPANDER +should return code that calls INNER-FORM and performs the checks +and error signalling specific to the particular variant of +`should'. The code that INNER-EXPANDER returns must not call +FORM-DESCRIPTION-FORM before it has called INNER-FORM." + (lexical-let ((inner-expander inner-expander)) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var))))))) + +(defmacro* should (form) + "Evaluate FORM. If it returns nil, abort the current test as failed. + +Returns the value of FORM." + (ert--expand-should `(should ,form) form + (lambda (inner-form form-description-form value-var) + `(unless ,inner-form + (ert-fail ,form-description-form))))) + +(defmacro* should-not (form) + "Evaluate FORM. If it returns non-nil, abort the current test as failed. + +Returns nil." + (ert--expand-should `(should-not ,form) form + (lambda (inner-form form-description-form value-var) + `(unless (not ,inner-form) + (ert-fail ,form-description-form))))) + +(defun ert--should-error-handle-error (form-description-fn + condition type exclude-subtypes) + "Helper function for `should-error'. + +Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, +and aborts the current test as failed if it doesn't." + (let ((signalled-conditions (get (car condition) 'error-conditions)) + (handled-conditions (etypecase type + (list type) + (symbol (list type))))) + (assert signalled-conditions) + (unless (ert--intersection signalled-conditions handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled did not" + " have the expected type"))))) + (when exclude-subtypes + (unless (member (car condition) handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled was a subtype" + " of the expected type")))))))) + +;; FIXME: The expansion will evaluate the keyword args (if any) in +;; nonstandard order. +(defmacro* should-error (form &rest keys &key type exclude-subtypes) + "Evaluate FORM and check that it signals an error. + +The error signalled needs to match TYPE. TYPE should be a list +of condition names. (It can also be a non-nil symbol, which is +equivalent to a singleton list containing that symbol.) If +EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its +condition names is an element of TYPE. If EXCLUDE-SUBTYPES is +non-nil, the error matches TYPE if it is an element of TYPE. + +If the error matches, returns (ERROR-SYMBOL . DATA) from the +error. If not, or if no error was signalled, abort the test as +failed." + (unless type (setq type ''error)) + (ert--expand-should + `(should-error ,form ,@keys) + form + (lambda (inner-form form-description-form value-var) + (let ((errorp (ert--gensym "errorp")) + (form-description-fn (ert--gensym "form-description-fn-"))) + `(let ((,errorp nil) + (,form-description-fn (lambda () ,form-description-form))) + (condition-case -condition- + ,inner-form + ;; We can't use ,type here because we want to evaluate it. + (error + (setq ,errorp t) + (ert--should-error-handle-error ,form-description-fn + -condition- + ,type ,exclude-subtypes) + (setq ,value-var -condition-))) + (unless ,errorp + (ert-fail (append + (funcall ,form-description-fn) + (list + :fail-reason "did not signal an error"))))))))) + + +;;; Explanation of `should' failures. + +;; TODO(ohler): Rework explanations so that they are displayed in a +;; similar way to `ert-info' messages; in particular, allow text +;; buttons in explanations that give more detail or open an ediff +;; buffer. Perhaps explanations should be reported through `ert-info' +;; rather than as part of the condition. + +(defun ert--proper-list-p (x) + "Return non-nil if X is a proper list, nil otherwise." + (loop + for firstp = t then nil + for fast = x then (cddr fast) + for slow = x then (cdr slow) do + (when (null fast) (return t)) + (when (not (consp fast)) (return nil)) + (when (null (cdr fast)) (return t)) + (when (not (consp (cdr fast))) (return nil)) + (when (and (not firstp) (eq fast slow)) (return nil)))) + +(defun ert--explain-format-atom (x) + "Format the atom X for `ert--explain-equal'." + (typecase x + (fixnum (list x (format "#x%x" x) (format "?%c" x))) + (t x))) + +(defun ert--explain-equal-rec (a b) + "Returns a programmer-readable explanation of why A and B are not `equal'. + +Returns nil if they are." + (if (not (equal (type-of a) (type-of b))) + `(different-types ,a ,b) + (etypecase a + (cons + (let ((a-proper-p (ert--proper-list-p a)) + (b-proper-p (ert--proper-list-p b))) + (if (not (eql (not a-proper-p) (not b-proper-p))) + `(one-list-proper-one-improper ,a ,b) + (if a-proper-p + (if (not (equal (length a) (length b))) + `(proper-lists-of-different-length ,(length a) ,(length b) + ,a ,b + first-mismatch-at + ,(ert--mismatch a b)) + (loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (return `(list-elt ,i ,xi))) + finally (assert (equal a b) t))) + (let ((car-x (ert--explain-equal-rec (car a) (car b)))) + (if car-x + `(car ,car-x) + (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) + (if cdr-x + `(cdr ,cdr-x) + (assert (equal a b) t) + nil)))))))) + (array (if (not (equal (length a) (length b))) + `(arrays-of-different-length ,(length a) ,(length b) + ,a ,b + ,@(unless (char-table-p a) + `(first-mismatch-at + ,(ert--mismatch a b)))) + (loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (return `(array-elt ,i ,xi))) + finally (assert (equal a b) t)))) + (atom (if (not (equal a b)) + (if (and (symbolp a) (symbolp b) (string= a b)) + `(different-symbols-with-the-same-name ,a ,b) + `(different-atoms ,(ert--explain-format-atom a) + ,(ert--explain-format-atom b))) + nil))))) + +(defun ert--explain-equal (a b) + "Explainer function for `equal'." + ;; Do a quick comparison in C to avoid running our expensive + ;; comparison when possible. + (if (equal a b) + nil + (ert--explain-equal-rec a b))) +(put 'equal 'ert-explainer 'ert--explain-equal) + +(defun ert--significant-plist-keys (plist) + "Return the keys of PLIST that have non-null values, in order." + (assert (zerop (mod (length plist) 2)) t) + (loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (return accu))) + +(defun ert--plist-difference-explanation (a b) + "Return a programmer-readable explanation of why A and B are different plists. + +Returns nil if they are equivalent, i.e., have the same value for +each key, where absent values are treated as nil. The order of +key/value pairs in each list does not matter." + (assert (zerop (mod (length a) 2)) t) + (assert (zerop (mod (length b) 2)) t) + ;; Normalizing the plists would be another way to do this but it + ;; requires a total ordering on all lisp objects (since any object + ;; is valid as a text property key). Perhaps defining such an + ;; ordering is useful in other contexts, too, but it's a lot of + ;; work, so let's punt on it for now. + (let* ((keys-a (ert--significant-plist-keys a)) + (keys-b (ert--significant-plist-keys b)) + (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) + (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) + (flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-equal-including-properties value-a + value-b))))) + (cond (keys-in-a-not-in-b + (explain-with-key (first keys-in-a-not-in-b))) + (keys-in-b-not-in-a + (explain-with-key (first keys-in-b-not-in-a))) + (t + (loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) + +(defun ert--abbreviate-string (s len suffixp) + "Shorten string S to at most LEN chars. + +If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." + (let ((n (length s))) + (cond ((< n len) + s) + (suffixp + (substring s (- n len))) + (t + (substring s 0 len))))) + +;; TODO(ohler): Once bug 6581 is fixed, rename this to +;; `ert--explain-equal-including-properties-rec' and add a fast-path +;; wrapper like `ert--explain-equal'. +(defun ert--explain-equal-including-properties (a b) + "Explainer function for `ert-equal-including-properties'. + +Returns a programmer-readable explanation of why A and B are not +`ert-equal-including-properties', or nil if they are." + (if (not (equal a b)) + (ert--explain-equal a b) + (assert (stringp a) t) + (assert (stringp b) t) + (assert (eql (length a) (length b)) t) + (loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation props-a props-b) + do (when difference + (return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (assert (equal-including-properties a b) t) + ))) +(put 'ert-equal-including-properties + 'ert-explainer + 'ert--explain-equal-including-properties) + + +;;; Implementation of `ert-info'. + +;; TODO(ohler): The name `info' clashes with +;; `ert--test-execution-info'. One or both should be renamed. +(defvar ert--infos '() + "The stack of `ert-info' infos that currently apply. + +Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") + +(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) + "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. + +To be used within ERT tests. MESSAGE-FORM should evaluate to a +string that will be displayed together with the test result if +the test fails. PREFIX-FORM should evaluate to a string as well +and is displayed in front of the value of MESSAGE-FORM." + (declare (debug ((form &rest [sexp form]) body)) + (indent 1)) + `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) + ,@body)) + + + +;;; Facilities for running a single test. + +(defvar ert-debug-on-error nil + "Non-nil means enter debugger when a test fails or terminates with an error.") + +;; The data structures that represent the result of running a test. +(defstruct ert-test-result + (messages nil) + (should-forms nil) + ) +(defstruct (ert-test-passed (:include ert-test-result))) +(defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (assert nil)) + (backtrace (assert nil)) + (infos (assert nil))) +(defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) + + +(defun ert--record-backtrace () + "Record the current backtrace (as a list) and return it." + ;; Since the backtrace is stored in the result object, result + ;; objects must only be printed with appropriate limits + ;; (`print-level' and `print-length') in place. For interactive + ;; use, the cost of ensuring this possibly outweighs the advantage + ;; of storing the backtrace for + ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we + ;; already have `ert-results-rerun-test-debugging-errors-at-point'. + ;; For batch use, however, printing the backtrace may be useful. + (loop + ;; 6 is the number of frames our own debugger adds (when + ;; compiled; more when interpreted). FIXME: Need to describe a + ;; procedure for determining this constant. + for i from 6 + for frame = (backtrace-frame i) + while frame + collect frame)) + +(defun ert--print-backtrace (backtrace) + "Format the backtrace BACKTRACE to the current buffer." + ;; This is essentially a reimplementation of Fbacktrace + ;; (src/eval.c), but for a saved backtrace, not the current one. + (let ((print-escape-newlines t) + (print-level 8) + (print-length 50)) + (dolist (frame backtrace) + (ecase (first frame) + ((nil) + ;; Special operator. + (destructuring-bind (special-operator &rest arg-forms) + (cdr frame) + (insert + (format " %S\n" (list* special-operator arg-forms))))) + ((t) + ;; Function call. + (destructuring-bind (fn &rest args) (cdr frame) + (insert (format " %S(" fn)) + (loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) + (insert ")\n"))))))) + +;; A container for the state of the execution of a single test and +;; environment data needed during its execution. +(defstruct ert--test-execution-info + (test (assert nil)) + (result (assert nil)) + ;; A thunk that may be called when RESULT has been set to its final + ;; value and test execution should be terminated. Should not + ;; return. + (exit-continuation (assert nil)) + ;; The binding of `debugger' outside of the execution of the test. + next-debugger + ;; The binding of `ert-debug-on-error' that is in effect for the + ;; execution of the current test. We store it to avoid being + ;; affected by any new bindings the test itself may establish. (I + ;; don't remember whether this feature is important.) + ert-debug-on-error) + +(defun ert--run-test-debugger (info debugger-args) + "During a test run, `debugger' is bound to a closure that calls this function. + +This function records failures and errors and either terminates +the test silently or calls the interactive debugger, as +appropriate. + +INFO is the ert--test-execution-info corresponding to this test +run. DEBUGGER-ARGS are the arguments to `debugger'." + (destructuring-bind (first-debugger-arg &rest more-debugger-args) + debugger-args + (ecase first-debugger-arg + ((lambda debug t exit nil) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (error + (let* ((condition (first more-debugger-args)) + (type (case (car condition) + ((quit) 'quit) + (otherwise 'failed))) + (backtrace (ert--record-backtrace)) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; Work around Emacs' heuristic (in eval.c) for detecting + ;; errors in the debugger. + (incf num-nonmacro-input-events) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info))))))) + +(defun ert--run-test-internal (ert-test-execution-info) + "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. + +This mainly sets up debugger-related bindings." + (lexical-let ((info ert-test-execution-info)) + (setf (ert--test-execution-info-next-debugger info) debugger + (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest debugger-args) + (ert--run-test-debugger info debugger-args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + nil) + +(defun ert--force-message-log-buffer-truncation () + "Immediately truncate *Messages* buffer according to `message-log-max'. + +This can be useful after reducing the value of `message-log-max'." + (with-current-buffer (get-buffer-create "*Messages*") + ;; This is a reimplementation of this part of message_dolog() in xdisp.c: + ;; if (NATNUMP (Vmessage_log_max)) + ;; { + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, + ;; -XFASTINT (Vmessage_log_max) - 1, 0); + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); + ;; } + (when (and (integerp message-log-max) (>= message-log-max 0)) + (let ((begin (point-min)) + (end (save-excursion + (goto-char (point-max)) + (forward-line (- message-log-max)) + (point)))) + (delete-region begin end))))) + +(defvar ert--running-tests nil + "List of tests that are currently in execution. + +This list is empty while no test is running, has one element +while a test is running, two elements while a test run from +inside a test is running, etc. The list is in order of nesting, +innermost test first. + +The elements are of type `ert-test'.") + +(defun ert-run-test (ert-test) + "Run ERT-TEST. + +Returns the result and stores it in ERT-TEST's `most-recent-result' slot." + (setf (ert-test-most-recent-result ert-test) nil) + (block error + (lexical-let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (set-marker (make-marker) (point-max))))) + (unwind-protect + (lexical-let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (return-from error nil)))) + (should-form-accu (list))) + (unwind-protect + (let ((ert--should-execution-observer + (lambda (form-description) + (push form-description should-form-accu))) + (message-log-max t) + (ert--running-tests (cons ert-test ert--running-tests))) + (ert--run-test-internal info)) + (let ((result (ert--test-execution-info-result info))) + (setf (ert-test-result-messages result) + (with-current-buffer (get-buffer-create "*Messages*") + (buffer-substring begin-marker (point-max)))) + (ert--force-message-log-buffer-truncation) + (setq should-form-accu (nreverse should-form-accu)) + (setf (ert-test-result-should-forms result) + should-form-accu) + (setf (ert-test-most-recent-result ert-test) result)))) + (set-marker begin-marker nil)))) + (ert-test-most-recent-result ert-test)) + +(defun ert-running-test () + "Return the top-level test currently executing." + (car (last ert--running-tests))) + + +;;; Test selectors. + +(defun ert-test-result-type-p (result result-type) + "Return non-nil if RESULT matches type RESULT-TYPE. + +Valid result types: + +nil -- Never matches. +t -- Always matches. +:failed, :passed -- Matches corresponding results. +\(and TYPES...\) -- Matches if all TYPES match. +\(or TYPES...\) -- Matches if some TYPES match. +\(not TYPE\) -- Matches if TYPE does not match. +\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with + RESULT." + ;; It would be easy to add `member' and `eql' types etc., but I + ;; haven't bothered yet. + (etypecase result-type + ((member nil) nil) + ((member t) t) + ((member :failed) (ert-test-failed-p result)) + ((member :passed) (ert-test-passed-p result)) + (cons + (destructuring-bind (operator &rest operands) result-type + (ecase operator + (and + (case (length operands) + (0 t) + (t + (and (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(and ,@(rest operands))))))) + (or + (case (length operands) + (0 nil) + (t + (or (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(or ,@(rest operands))))))) + (not + (assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (first operands)))) + (satisfies + (assert (eql (length operands) 1)) + (funcall (first operands) result))))))) + +(defun ert-test-result-expected-p (test result) + "Return non-nil if TEST's expected result type matches RESULT." + (ert-test-result-type-p result (ert-test-expected-result-type test))) + +(defun ert-select-tests (selector universe) + "Return the tests that match SELECTOR. + +UNIVERSE specifies the set of tests to select from; it should be +a list of tests, or t, which refers to all tests named by symbols +in `obarray'. + +Returns the set of tests as a list. + +Valid selectors: + +nil -- Selects the empty set. +t -- Selects UNIVERSE. +:new -- Selects all tests that have not been run yet. +:failed, :passed -- Select tests according to their most recent result. +:expected, :unexpected -- Select tests according to their most recent result. +a string -- Selects all tests that have a name that matches the string, + a regexp. +a test -- Selects that test. +a symbol -- Selects the test that the symbol names, errors if none. +\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. +\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. +\(and SELECTORS...\) -- Selects the tests that match all SELECTORS. +\(or SELECTORS...\) -- Selects the tests that match any SELECTOR. +\(not SELECTOR\) -- Selects all tests that do not match SELECTOR. +\(tag TAG) -- Selects all tests that have TAG on their tags list. +\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. + +Only selectors that require a superset of tests, such +as (satisfies ...), strings, :new, etc. make use of UNIVERSE. +Selectors that do not, such as \(member ...\), just return the +set implied by them without checking whether it is really +contained in UNIVERSE." + ;; This code needs to match the etypecase in + ;; `ert-insert-human-readable-selector'. + (etypecase selector + ((member nil) nil) + ((member t) (etypecase universe + (list universe) + ((member t) (ert-select-tests "" universe)))) + ((member :new) (ert-select-tests + `(satisfies ,(lambda (test) + (null (ert-test-most-recent-result test)))) + universe)) + ((member :failed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':failed))) + universe)) + ((member :passed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':passed))) + universe)) + ((member :expected) (ert-select-tests + `(satisfies + ,(lambda (test) + (ert-test-result-expected-p + test + (ert-test-most-recent-result test)))) + universe)) + ((member :unexpected) (ert-select-tests `(not :expected) universe)) + (string + (etypecase universe + ((member t) (mapcar #'ert-get-test + (apropos-internal selector #'ert-test-boundp))) + (list (ert--remove-if-not (lambda (test) + (and (ert-test-name test) + (string-match selector + (ert-test-name test)))) + universe)))) + (ert-test (list selector)) + (symbol + (assert (ert-test-boundp selector)) + (list (ert-get-test selector))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + (member + (mapcar (lambda (purported-test) + (etypecase purported-test + (symbol (assert (ert-test-boundp purported-test)) + (ert-get-test purported-test)) + (ert-test purported-test))) + operands)) + (eql + (assert (eql (length operands) 1)) + (ert-select-tests `(member ,@operands) universe)) + (and + ;; Do these definitions of AND, NOT and OR satisfy de + ;; Morgan's laws? Should they? + (case (length operands) + (0 (ert-select-tests 't universe)) + (t (ert-select-tests `(and ,@(rest operands)) + (ert-select-tests (first operands) + universe))))) + (not + (assert (eql (length operands) 1)) + (let ((all-tests (ert-select-tests 't universe))) + (ert--set-difference all-tests + (ert-select-tests (first operands) + all-tests)))) + (or + (case (length operands) + (0 (ert-select-tests 'nil universe)) + (t (ert--union (ert-select-tests (first operands) universe) + (ert-select-tests `(or ,@(rest operands)) + universe))))) + (tag + (assert (eql (length operands) 1)) + (let ((tag (first operands))) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe))) + (satisfies + (assert (eql (length operands) 1)) + (ert--remove-if-not (first operands) + (ert-select-tests 't universe)))))))) + +(defun ert--insert-human-readable-selector (selector) + "Insert a human-readable presentation of SELECTOR into the current buffer." + ;; This is needed to avoid printing the (huge) contents of the + ;; `backtrace' slot of the result objects in the + ;; `most-recent-result' slots of test case objects in (eql ...) or + ;; (member ...) selectors. + (labels ((rec (selector) + ;; This code needs to match the etypecase in `ert-select-tests'. + (etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol ""))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) + (insert (format "%S" (rec selector))))) + + +;;; Facilities for running a whole set of tests. + +;; The data structure that contains the set of tests being executed +;; during one particular test run, their results, the state of the +;; execution, and some statistics. +;; +;; The data about results and expected results of tests may seem +;; redundant here, since the test objects also carry such information. +;; However, the information in the test objects may be more recent, it +;; may correspond to a different test run. We need the information +;; that corresponds to this run in order to be able to update the +;; statistics correctly when a test is re-run interactively and has a +;; different result than before. +(defstruct ert--stats + (selector (assert nil)) + ;; The tests, in order. + (tests (assert nil) :type vector) + ;; A map of test names (or the test objects themselves for unnamed + ;; tests) to indices into the `tests' vector. + (test-map (assert nil) :type hash-table) + ;; The results of the tests during this run, in order. + (test-results (assert nil) :type vector) + ;; The start times of the tests, in order, as reported by + ;; `current-time'. + (test-start-times (assert nil) :type vector) + ;; The end times of the tests, in order, as reported by + ;; `current-time'. + (test-end-times (assert nil) :type vector) + (passed-expected 0) + (passed-unexpected 0) + (failed-expected 0) + (failed-unexpected 0) + (start-time nil) + (end-time nil) + (aborted-p nil) + (current-test nil) + ;; The time at or after which the next redisplay should occur, as a + ;; float. + (next-redisplay 0.0)) + +(defun ert-stats-completed-expected (stats) + "Return the number of tests in STATS that had expected results." + (+ (ert--stats-passed-expected stats) + (ert--stats-failed-expected stats))) + +(defun ert-stats-completed-unexpected (stats) + "Return the number of tests in STATS that had unexpected results." + (+ (ert--stats-passed-unexpected stats) + (ert--stats-failed-unexpected stats))) + +(defun ert-stats-completed (stats) + "Number of tests in STATS that have run so far." + (+ (ert-stats-completed-expected stats) + (ert-stats-completed-unexpected stats))) + +(defun ert-stats-total (stats) + "Number of tests in STATS, regardless of whether they have run yet." + (length (ert--stats-tests stats))) + +;; The stats object of the current run, dynamically bound. This is +;; used for the mode line progress indicator. +(defvar ert--current-run-stats nil) + +(defun ert--stats-test-key (test) + "Return the key used for TEST in the test map of ert--stats objects. + +Returns the name of TEST if it has one, or TEST itself otherwise." + (or (ert-test-name test) test)) + +(defun ert--stats-set-test-and-result (stats pos test result) + "Change STATS by replacing the test at position POS with TEST and RESULT. + +Also changes the counters in STATS to match." + (let* ((tests (ert--stats-tests stats)) + (results (ert--stats-test-results stats)) + (old-test (aref tests pos)) + (map (ert--stats-test-map stats))) + (flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-expected stats) d)) + (ert-test-failed (incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit))))) + ;; Adjust counters to remove the result that is currently in stats. + (update -1) + ;; Put new test and result into stats. + (setf (aref tests pos) test + (aref results pos) result) + (remhash (ert--stats-test-key old-test) map) + (setf (gethash (ert--stats-test-key test) map) pos) + ;; Adjust counters to match new result. + (update +1) + nil))) + +(defun ert--make-stats (tests selector) + "Create a new `ert--stats' object for running TESTS. + +SELECTOR is the selector that was used to select TESTS." + (setq tests (ert--coerce-to-vector tests)) + (let ((map (make-hash-table :size (length tests)))) + (loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (assert (not (gethash key map))) + (setf (gethash key map) i)) + (make-ert--stats :selector selector + :tests tests + :test-map map + :test-results (make-vector (length tests) nil) + :test-start-times (make-vector (length tests) nil) + :test-end-times (make-vector (length tests) nil)))) + +(defun ert-run-or-rerun-test (stats test listener) + ;; checkdoc-order: nil + "Run the single test TEST and record the result using STATS and LISTENER." + (let ((ert--current-run-stats stats) + (pos (ert--stats-test-pos stats test))) + (ert--stats-set-test-and-result stats pos test nil) + ;; Call listener after setting/before resetting + ;; (ert--stats-current-test stats); the listener might refresh the + ;; mode line display, and if the value is not set yet/any more + ;; during this refresh, the mode line will flicker unnecessarily. + (setf (ert--stats-current-test stats) test) + (funcall listener 'test-started stats test) + (setf (ert-test-most-recent-result test) nil) + (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) + (unwind-protect + (ert-run-test test) + (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) + (let ((result (ert-test-most-recent-result test))) + (ert--stats-set-test-and-result stats pos test result) + (funcall listener 'test-ended stats test result)) + (setf (ert--stats-current-test stats) nil)))) + +(defun ert-run-tests (selector listener) + "Run the tests specified by SELECTOR, sending progress updates to LISTENER." + (let* ((tests (ert-select-tests selector t)) + (stats (ert--make-stats tests selector))) + (setf (ert--stats-start-time stats) (current-time)) + (funcall listener 'run-started stats) + (let ((abortedp t)) + (unwind-protect + (let ((ert--current-run-stats stats)) + (force-mode-line-update) + (unwind-protect + (progn + (loop for test in tests do + (ert-run-or-rerun-test stats test listener)) + (setq abortedp nil)) + (setf (ert--stats-aborted-p stats) abortedp) + (setf (ert--stats-end-time stats) (current-time)) + (funcall listener 'run-ended stats abortedp))) + (force-mode-line-update)) + stats))) + +(defun ert--stats-test-pos (stats test) + ;; checkdoc-order: nil + "Return the position (index) of TEST in the run represented by STATS." + (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) + + +;;; Formatting functions shared across UIs. + +(defun ert--format-time-iso8601 (time) + "Format TIME in the variant of ISO 8601 used for timestamps in ERT." + (format-time-string "%Y-%m-%d %T%z" time)) + +(defun ert-char-for-test-result (result expectedp) + "Return a character that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed ".P") + (ert-test-failed "fF") + (null "--") + (ert-test-aborted-with-non-local-exit "aA") + (ert-test-quit "qQ")))) + (elt s (if expectedp 0 1)))) + +(defun ert-string-for-test-result (result expectedp) + "Return a string that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed '("passed" "PASSED")) + (ert-test-failed '("failed" "FAILED")) + (null '("unknown" "UNKNOWN")) + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")) + (ert-test-quit '("quit" "QUIT"))))) + (elt s (if expectedp 0 1)))) + +(defun ert--pp-with-indentation-and-newline (object) + "Pretty-print OBJECT, indenting it to the current column of point. +Ensures a final newline is inserted." + (let ((begin (point))) + (pp object (current-buffer)) + (unless (bolp) (insert "\n")) + (save-excursion + (goto-char begin) + (indent-sexp)))) + +(defun ert--insert-infos (result) + "Insert `ert-info' infos from RESULT into current buffer. + +RESULT must be an `ert-test-result-with-condition'." + (check-type result ert-test-result-with-condition) + (dolist (info (ert-test-result-with-condition-infos result)) + (destructuring-bind (prefix . message) info + (let ((begin (point)) + (indentation (make-string (+ (length prefix) 4) ?\s)) + (end nil)) + (unwind-protect + (progn + (insert message "\n") + (setq end (copy-marker (point))) + (goto-char begin) + (insert " " prefix) + (forward-line 1) + (while (< (point) end) + (insert indentation) + (forward-line 1))) + (when end (set-marker end nil))))))) + + +;;; Running tests in batch mode. + +(defvar ert-batch-backtrace-right-margin 70 + "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") + +;;;###autoload +(defun ert-run-tests-batch (&optional selector) + "Run the tests specified by SELECTOR, printing results to the terminal. + +SELECTOR works as described in `ert-select-tests', except if +SELECTOR is nil, in which case all tests rather than none will be +run; this makes the command line \"emacs -batch -l my-tests.el -f +ert-run-tests-batch-and-exit\" useful. + +Returns the stats object." + (unless selector (setq selector 't)) + (ert-run-tests + selector + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (message "Running %s tests (%s)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (let ((unexpected (ert-stats-completed-unexpected stats)) + (expected-failures (ert--stats-failed-expected stats))) + (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)) + (ert--format-time-iso8601 (ert--stats-end-time stats)) + (if (zerop expected-failures) + "" + (format "\n%s expected failures" expected-failures))) + (unless (zerop unexpected) + (message "%s unexpected results:" unexpected) + (loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) + (message "%s" ""))))) + (test-started + ) + (test-ended + (destructuring-bind (stats test result) event-args + (unless (ert-test-result-expected-p test result) + (etypecase result + (ert-test-passed + (message "Test %S passed unexpectedly" (ert-test-name test))) + (ert-test-result-with-condition + (message "Test %S backtrace:" (ert-test-name test)) + (with-temp-buffer + (ert--print-backtrace (ert-test-result-with-condition-backtrace + result)) + (goto-char (point-min)) + (while (not (eobp)) + (let ((start (point)) + (end (progn (end-of-line) (point)))) + (setq end (min end + (+ start ert-batch-backtrace-right-margin))) + (message "%s" (buffer-substring-no-properties + start end))) + (forward-line 1))) + (with-temp-buffer + (ert--insert-infos result) + (insert " ") + (let ((print-escape-newlines t) + (print-level 5) + (print-length 10)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)))) + (goto-char (1- (point-max))) + (assert (looking-at "\n")) + (delete-char 1) + (message "Test %S condition:" (ert-test-name test)) + (message "%s" (buffer-string)))) + (ert-test-aborted-with-non-local-exit + (message "Test %S aborted with non-local exit" + (ert-test-name test))) + (ert-test-quit + (message "Quit during %S" (ert-test-name test))))) + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test))))))))) + +;;;###autoload +(defun ert-run-tests-batch-and-exit (&optional selector) + "Like `ert-run-tests-batch', but exits Emacs when done. + +The exit status will be 0 if all test results were as expected, 1 +on unexpected results, or 2 if the tool detected an error outside +of the tests (e.g. invalid SELECTOR or bug in the code that runs +the tests)." + (unwind-protect + (let ((stats (ert-run-tests-batch selector))) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 2)))) + + +;;; Utility functions for load/unload actions. + +(defun ert--activate-font-lock-keywords () + "Activate font-lock keywords for some of ERT's symbols." + (font-lock-add-keywords + nil + '(("(\\(\\\\s *\\(\\sw+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t))))) + +(defun* ert--remove-from-list (list-var element &key key test) + "Remove ELEMENT from the value of LIST-VAR if present. + +This can be used as an inverse of `add-to-list'." + (unless key (setq key #'identity)) + (unless test (setq test #'equal)) + (setf (symbol-value list-var) + (ert--remove* element + (symbol-value list-var) + :key key + :test test))) + + +;;; Some basic interactive functions. + +(defun ert-read-test-name (prompt &optional default history + add-default-to-prompt) + "Read the name of a test and return it as a symbol. + +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a +default. HISTORY is the history to use; see `completing-read'. +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to +include the default, if any. + +Signals an error if no test name was read." + (etypecase default + (string (let ((symbol (intern-soft default))) + (unless (and symbol (ert-test-boundp symbol)) + (setq default nil)))) + (symbol (setq default + (if (ert-test-boundp default) + (symbol-name default) + nil))) + (ert-test (setq default (ert-test-name default)))) + (when add-default-to-prompt + (setq prompt (if (null default) + (format "%s: " prompt) + (format "%s (default %s): " prompt default)))) + (let ((input (completing-read prompt obarray #'ert-test-boundp + t nil history default nil))) + ;; completing-read returns an empty string if default was nil and + ;; the user just hit enter. + (let ((sym (intern-soft input))) + (if (ert-test-boundp sym) + sym + (error "Input does not name a test"))))) + +(defun ert-read-test-name-at-point (prompt) + "Read the name of a test and return it as a symbol. +As a default, use the symbol at point, or the test at point if in +the ERT results buffer. Prompt with PROMPT, augmented with the +default (if any)." + (ert-read-test-name prompt (ert-test-at-point) nil t)) + +(defun ert-find-test-other-window (test-name) + "Find, in another window, the definition of TEST-NAME." + (interactive (list (ert-read-test-name-at-point "Find test definition: "))) + (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) + +(defun ert-delete-test (test-name) + "Make the test TEST-NAME unbound. + +Nothing more than an interactive interface to `ert-make-test-unbound'." + (interactive (list (ert-read-test-name-at-point "Delete test"))) + (ert-make-test-unbound test-name)) + +(defun ert-delete-all-tests () + "Make all symbols in `obarray' name no test." + (interactive) + (when (interactive-p) + (unless (y-or-n-p "Delete all tests? ") + (error "Aborted"))) + ;; We can't use `ert-select-tests' here since that gives us only + ;; test objects, and going from them back to the test name symbols + ;; can fail if the `ert-test' defstruct has been redefined. + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) + t) + + +;;; Display of test progress and results. + +;; An entry in the results buffer ewoc. There is one entry per test. +(defstruct ert--ewoc-entry + (test (assert nil)) + ;; If the result of this test was expected, its ewoc entry is hidden + ;; initially. + (hidden-p (assert nil)) + ;; An ewoc entry may be collapsed to hide details such as the error + ;; condition. + ;; + ;; I'm not sure the ability to expand and collapse entries is still + ;; a useful feature. + (expanded-p t) + ;; By default, the ewoc entry presents the error condition with + ;; certain limits on how much to print (`print-level', + ;; `print-length'). The user can interactively switch to a set of + ;; higher limits. + (extended-printer-limits-p nil)) + +;; Variables local to the results buffer. + +;; The ewoc. +(defvar ert--results-ewoc) +;; The stats object. +(defvar ert--results-stats) +;; A string with one character per test. Each character represents +;; the result of the corresponding test. The string is displayed near +;; the top of the buffer and serves as a progress bar. +(defvar ert--results-progress-bar-string) +;; The position where the progress bar button begins. +(defvar ert--results-progress-bar-button-begin) +;; The test result listener that updates the buffer when tests are run. +(defvar ert--results-listener) + +(defun ert-insert-test-name-button (test-name) + "Insert a button that links to TEST-NAME." + (insert-text-button (format "%S" test-name) + :type 'ert--test-name-button + 'ert-test-name test-name)) + +(defun ert--results-format-expected-unexpected (expected unexpected) + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." + (if (zerop unexpected) + (format "%s" expected) + (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) + +(defun ert--results-update-ewoc-hf (ewoc stats) + "Update the header and footer of EWOC to show certain information from STATS. + +Also sets `ert--results-progress-bar-button-begin'." + (let ((run-count (ert-stats-completed stats)) + (results-buffer (current-buffer)) + ;; Need to save buffer-local value. + (font-lock font-lock-mode)) + (ewoc-set-hf + ewoc + ;; header + (with-temp-buffer + (insert "Selector: ") + (ert--insert-human-readable-selector (ert--stats-selector stats)) + (insert "\n") + (insert + (format (concat "Passed: %s\n" + "Failed: %s\n" + "Total: %s/%s\n\n") + (ert--results-format-expected-unexpected + (ert--stats-passed-expected stats) + (ert--stats-passed-unexpected stats)) + (ert--results-format-expected-unexpected + (ert--stats-failed-expected stats) + (ert--stats-failed-unexpected stats)) + run-count + (ert-stats-total stats))) + (insert + (format "Started at: %s\n" + (ert--format-time-iso8601 (ert--stats-start-time stats)))) + ;; FIXME: This is ugly. Need to properly define invariants of + ;; the `stats' data structure. + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) + ((ert--stats-current-test stats) 'running) + ((ert--stats-end-time stats) 'finished) + (t 'preparing)))) + (ecase state + (preparing + (insert "")) + (aborted + (cond ((ert--stats-current-test stats) + (insert "Aborted during test: ") + (ert-insert-test-name-button + (ert-test-name (ert--stats-current-test stats)))) + (t + (insert "Aborted.")))) + (running + (assert (ert--stats-current-test stats)) + (insert "Running test: ") + (ert-insert-test-name-button (ert-test-name + (ert--stats-current-test stats)))) + (finished + (assert (not (ert--stats-current-test stats))) + (insert "Finished."))) + (insert "\n") + (if (ert--stats-end-time stats) + (insert + (format "%s%s\n" + (if (ert--stats-aborted-p stats) + "Aborted at: " + "Finished at: ") + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert "\n")) + (insert "\n")) + (let ((progress-bar-string (with-current-buffer results-buffer + ert--results-progress-bar-string))) + (let ((progress-bar-button-begin + (insert-text-button progress-bar-string + :type 'ert--results-progress-bar-button + 'face (or (and font-lock + (ert-face-for-stats stats)) + 'button)))) + ;; The header gets copied verbatim to the results buffer, + ;; and all positions remain the same, so + ;; `progress-bar-button-begin' will be the right position + ;; even in the results buffer. + (with-current-buffer results-buffer + (set (make-local-variable 'ert--results-progress-bar-button-begin) + progress-bar-button-begin)))) + (insert "\n\n") + (buffer-string)) + ;; footer + ;; + ;; We actually want an empty footer, but that would trigger a bug + ;; in ewoc, sometimes clearing the entire buffer. (It's possible + ;; that this bug has been fixed since this has been tested; we + ;; should test it again.) + "\n"))) + + +(defvar ert-test-run-redisplay-interval-secs .1 + "How many seconds ERT should wait between redisplays while running tests. + +While running tests, ERT shows the current progress, and this variable +determines how frequently the progress display is updated.") + +(defun ert--results-update-stats-display (ewoc stats) + "Update EWOC and the mode line to show data from STATS." + ;; TODO(ohler): investigate using `make-progress-reporter'. + (ert--results-update-ewoc-hf ewoc stats) + (force-mode-line-update) + (redisplay t) + (setf (ert--stats-next-redisplay stats) + (+ (float-time) ert-test-run-redisplay-interval-secs))) + +(defun ert--results-update-stats-display-maybe (ewoc stats) + "Call `ert--results-update-stats-display' if not called recently. + +EWOC and STATS are arguments for `ert--results-update-stats-display'." + (when (>= (float-time) (ert--stats-next-redisplay stats)) + (ert--results-update-stats-display ewoc stats))) + +(defun ert--tests-running-mode-line-indicator () + "Return a string for the mode line that shows the test run progress." + (let* ((stats ert--current-run-stats) + (tests-total (ert-stats-total stats)) + (tests-completed (ert-stats-completed stats))) + (if (>= tests-completed tests-total) + (format " ERT(%s/%s,finished)" tests-completed tests-total) + (format " ERT(%s/%s):%s" + (1+ tests-completed) + tests-total + (if (null (ert--stats-current-test stats)) + "?" + (format "%S" + (ert-test-name (ert--stats-current-test stats)))))))) + +(defun ert--make-xrefs-region (begin end) + "Attach cross-references to function names between BEGIN and END. + +BEGIN and END specify a region in the current buffer." + (save-excursion + (save-restriction + (narrow-to-region begin (point)) + ;; Inhibit optimization in `debugger-make-xrefs' that would + ;; sometimes insert unrelated backtrace info into our buffer. + (let ((debugger-previous-backtrace nil)) + (debugger-make-xrefs))))) + +(defun ert--string-first-line (s) + "Return the first line of S, or S if it contains no newlines. + +The return value does not include the line terminator." + (substring s 0 (ert--string-position ?\n s))) + +(defun ert-face-for-test-result (expectedp) + "Return a face that shows whether a test result was expected or unexpected. + +If EXPECTEDP is nil, returns the face for unexpected results; if +non-nil, returns the face for expected results.." + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) + +(defun ert-face-for-stats (stats) + "Return a face that represents STATS." + (cond ((ert--stats-aborted-p stats) 'nil) + ((plusp (ert-stats-completed-unexpected stats)) + (ert-face-for-test-result nil)) + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) + (ert-face-for-test-result t)) + (t 'nil))) + +(defun ert--print-test-for-ewoc (entry) + "The ewoc print function for ewoc test entries. ENTRY is the entry to print." + (let* ((test (ert--ewoc-entry-test entry)) + (stats ert--results-stats) + (result (let ((pos (ert--stats-test-pos stats test))) + (assert pos) + (aref (ert--stats-test-results stats) pos))) + (hiddenp (ert--ewoc-entry-hidden-p entry)) + (expandedp (ert--ewoc-entry-expanded-p entry)) + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p + entry))) + (cond (hiddenp) + (t + (let ((expectedp (ert-test-result-expected-p test result))) + (insert-text-button (format "%c" (ert-char-for-test-result + result expectedp)) + :type 'ert--results-expand-collapse-button + 'face (or (and font-lock-mode + (ert-face-for-test-result + expectedp)) + 'button))) + (insert " ") + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n") + (when (and expandedp (not (eql result 'nil))) + (when (ert-test-documentation test) + (insert " " + (propertize + (ert--string-first-line (ert-test-documentation test)) + 'font-lock-face 'font-lock-doc-face) + "\n")) + (etypecase result + (ert-test-passed + (if (ert-test-result-expected-p test result) + (insert " passed\n") + (insert " passed unexpectedly\n")) + (insert "")) + (ert-test-result-with-condition + (ert--insert-infos result) + (let ((print-escape-newlines t) + (print-level (if extended-printer-limits-p 12 6)) + (print-length (if extended-printer-limits-p 100 10))) + (insert " ") + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)) + (ert--make-xrefs-region begin (point))))) + (ert-test-aborted-with-non-local-exit + (insert " aborted\n")) + (ert-test-quit + (insert " quit\n"))) + (insert "\n"))))) + nil) + +(defun ert--results-font-lock-function (enabledp) + "Redraw the ERT results buffer after font-lock-mode was switched on or off. + +ENABLEDP is true if font-lock-mode is switched on, false +otherwise." + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (ewoc-refresh ert--results-ewoc) + (font-lock-default-function enabledp)) + +(defun ert--setup-results-buffer (stats listener buffer-name) + "Set up a test results buffer. + +STATS is the stats object; LISTENER is the results listener; +BUFFER-NAME, if non-nil, is the buffer name to use." + (unless buffer-name (setq buffer-name "*ert*")) + (let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-results-mode) + ;; Erase buffer again in case switching out of the previous + ;; mode inserted anything. (This happens e.g. when switching + ;; from ert-results-mode to ert-results-mode when + ;; font-lock-mode turns itself off in change-major-mode-hook.) + (erase-buffer) + (set (make-local-variable 'font-lock-function) + 'ert--results-font-lock-function) + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) + (set (make-local-variable 'ert--results-ewoc) ewoc) + (set (make-local-variable 'ert--results-stats) stats) + (set (make-local-variable 'ert--results-progress-bar-string) + (make-string (ert-stats-total stats) + (ert-char-for-test-result nil t))) + (set (make-local-variable 'ert--results-listener) listener) + (loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test :hidden-p t))) + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (goto-char (1- (point-max))) + buffer))))) + + +(defvar ert--selector-history nil + "List of recent test selectors read from terminal.") + +;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? +;; They are needed only for our automated self-tests at the moment. +;; Or should there be some other mechanism? +;;;###autoload +(defun ert-run-tests-interactively (selector + &optional output-buffer-name message-fn) + "Run the tests specified by SELECTOR and display the results in a buffer. + +SELECTOR works as described in `ert-select-tests'. +OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they +are used for automated self-tests and specify which buffer to use +and how to display message." + (interactive + (list (let ((default (if ert--selector-history + ;; Can't use `first' here as this form is + ;; not compiled, and `first' is not + ;; defined without cl. + (car ert--selector-history) + "t"))) + (read-from-minibuffer (if (null default) + "Run tests: " + (format "Run tests (default %s): " default)) + nil nil t 'ert--selector-history + default nil)) + nil)) + (unless message-fn (setq message-fn 'message)) + (lexical-let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) + (setq listener + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (setq buffer (ert--setup-results-buffer stats + listener + output-buffer-name)) + (pop-to-buffer buffer))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (funcall message-fn + "%sRan %s tests, %s results were as expected%s" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (let ((unexpected + (ert-stats-completed-unexpected stats))) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)))) + (ert--results-update-stats-display (with-current-buffer buffer + ert--results-ewoc) + stats))) + (test-started + (destructuring-bind (stats test) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (assert node) + (setf (ert--ewoc-entry-test (ewoc-data node)) test) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result nil t)) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node))))) + (test-ended + (destructuring-bind (stats test result) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (when (ert--ewoc-entry-hidden-p (ewoc-data node)) + (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) + (ert-test-result-expected-p test result))) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result result + (ert-test-result-expected-p + test result))) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node)))))))) + (ert-run-tests + selector + listener))) +;;;###autoload +(defalias 'ert 'ert-run-tests-interactively) + + +;;; Simple view mode for auxiliary information like stack traces or +;;; messages. Mainly binds "q" for quit. + +(define-derived-mode ert-simple-view-mode special-mode "ERT-View" + "Major mode for viewing auxiliary information in ERT.") + +;;; Commands and button actions for the results buffer. + +(define-derived-mode ert-results-mode special-mode "ERT-Results" + "Major mode for viewing results of ERT test runs.") + +(loop for (key binding) in + '(;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) + +(easy-menu-define ert-results-mode-menu ert-results-mode-map + "Menu for `ert-results-mode'." + '("ERT Results" + ["Re-run all tests" ert-results-rerun-all-tests] + "--" + ["Re-run test" ert-results-rerun-test-at-point] + ["Debug test" ert-results-rerun-test-at-point-debugging-errors] + ["Show test definition" ert-results-find-test-at-point-other-window] + "--" + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] + ["Show messages" ert-results-pop-to-messages-for-test-at-point] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] + ["Describe test" ert-results-describe-test-at-point] + "--" + ["Delete test" ert-delete-test] + "--" + ["Show execution time of each test" ert-results-pop-to-timings] + )) + +(define-button-type 'ert--results-progress-bar-button + 'action #'ert--results-progress-bar-button-action + 'help-echo "mouse-2, RET: Reveal test result") + +(define-button-type 'ert--test-name-button + 'action #'ert--test-name-button-action + 'help-echo "mouse-2, RET: Find test definition") + +(define-button-type 'ert--results-expand-collapse-button + 'action #'ert--results-expand-collapse-button-action + 'help-echo "mouse-2, RET: Expand/collapse test result") + +(defun ert--results-test-node-or-null-at-point () + "If point is on a valid ewoc node, return it; return nil otherwise. + +To be used in the ERT results buffer." + (let* ((ewoc ert--results-ewoc) + (node (ewoc-locate ewoc))) + ;; `ewoc-locate' will return an arbitrary node when point is on + ;; header or footer, or when all nodes are invisible. So we need + ;; to validate its return value here. + ;; + ;; Update: I'm seeing nil being returned in some cases now, + ;; perhaps this has been changed? + (if (and node + (>= (point) (ewoc-location node)) + (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) + node + nil))) + +(defun ert--results-test-node-at-point () + "If point is on a valid ewoc node, return it; signal an error otherwise. + +To be used in the ERT results buffer." + (or (ert--results-test-node-or-null-at-point) + (error "No test at point"))) + +(defun ert-results-next-test () + "Move point to the next test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next + "No tests below")) + +(defun ert-results-previous-test () + "Move point to the previous test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev + "No tests above")) + +(defun ert--results-move (node ewoc-fn error-message) + "Move point from NODE to the previous or next node. + +EWOC-FN specifies the direction and should be either `ewoc-prev' +or `ewoc-next'. If there are no more nodes in that direction, an +error is signalled with the message ERROR-MESSAGE." + (loop + (setq node (funcall ewoc-fn ert--results-ewoc node)) + (when (null node) + (error "%s" error-message)) + (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) + (goto-char (ewoc-location node)) + (return)))) + +(defun ert--results-expand-collapse-button-action (button) + "Expand or collapse the test node BUTTON belongs to." + (let* ((ewoc ert--results-ewoc) + (node (save-excursion + (goto-char (ert--button-action-position)) + (ert--results-test-node-at-point))) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-expanded-p entry) + (not (ert--ewoc-entry-expanded-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-find-test-at-point-other-window () + "Find the definition of the test at point in another window. + +To be used in the ERT results buffer." + (interactive) + (let ((name (ert-test-at-point))) + (unless name + (error "No test at point")) + (ert-find-test-other-window name))) + +(defun ert--test-name-button-action (button) + "Find the definition of the test BUTTON belongs to, in another window." + (let ((name (button-get button 'ert-test-name))) + (ert-find-test-other-window name))) + +(defun ert--ewoc-position (ewoc node) + ;; checkdoc-order: nil + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." + (loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (return i)) + finally (return nil))) + +(defun ert-results-jump-between-summary-and-result () + "Jump back and forth between the test run summary and individual test results. + +From an ewoc node, jumps to the character that represents the +same test in the progress bar, and vice versa. + +To be used in the ERT results buffer." + ;; Maybe this command isn't actually needed much, but if it is, it + ;; seems like an indication that the UI design is not optimal. If + ;; jumping back and forth between a summary at the top of the buffer + ;; and the error log in the remainder of the buffer is useful, then + ;; the summary apparently needs to be easily accessible from the + ;; error log, and perhaps it would be better to have it in a + ;; separate buffer to keep it visible. + (interactive) + (let ((ewoc ert--results-ewoc) + (progress-bar-begin ert--results-progress-bar-button-begin)) + (cond ((ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (pos (ert--ewoc-position ewoc node))) + (goto-char (+ progress-bar-begin pos)))) + ((and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) + (entry (ewoc-data node))) + (when (ert--ewoc-entry-hidden-p entry) + (setf (ert--ewoc-entry-hidden-p entry) nil) + (ewoc-invalidate ewoc node)) + (ewoc-goto-node ewoc node))) + (t + (goto-char progress-bar-begin))))) + +(defun ert-test-at-point () + "Return the name of the test at point as a symbol, or nil if none." + (or (and (eql major-mode 'ert-results-mode) + (let ((test (ert--results-test-at-point-no-redefinition))) + (and test (ert-test-name test)))) + (let* ((thing (thing-at-point 'symbol)) + (sym (intern-soft thing))) + (and (ert-test-boundp sym) + sym)))) + +(defun ert--results-test-at-point-no-redefinition () + "Return the test at point, or nil. + +To be used in the ERT results buffer." + (assert (eql major-mode 'ert-results-mode)) + (if (ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (test (ert--ewoc-entry-test (ewoc-data node)))) + test) + (let ((progress-bar-begin ert--results-progress-bar-button-begin)) + (when (and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((test-index (- (point) progress-bar-begin)) + (test (aref (ert--stats-tests ert--results-stats) + test-index))) + test))))) + +(defun ert--results-test-at-point-allow-redefinition () + "Look up the test at point, and check whether it has been redefined. + +To be used in the ERT results buffer. + +Returns a list of two elements: the test (or nil) and a symbol +specifying whether the test has been redefined. + +If a new test has been defined with the same name as the test at +point, replaces the test at point with the new test, and returns +the new test and the symbol `redefined'. + +If the test has been deleted, returns the old test and the symbol +`deleted'. + +If the test is still current, returns the test and the symbol nil. + +If there is no test at point, returns a list with two nils." + (let ((test (ert--results-test-at-point-no-redefinition))) + (cond ((null test) + `(nil nil)) + ((null (ert-test-name test)) + `(,test nil)) + (t + (let* ((name (ert-test-name test)) + (new-test (and (ert-test-boundp name) + (ert-get-test name)))) + (cond ((eql test new-test) + `(,test nil)) + ((null new-test) + `(,test deleted)) + (t + (ert--results-update-after-test-redefinition + (ert--stats-test-pos ert--results-stats test) + new-test) + `(,new-test redefined)))))))) + +(defun ert--results-update-after-test-redefinition (pos new-test) + "Update results buffer after the test at pos POS has been redefined. + +Also updates the stats object. NEW-TEST is the new test +definition." + (let* ((stats ert--results-stats) + (ewoc ert--results-ewoc) + (node (ewoc-nth ewoc pos)) + (entry (ewoc-data node))) + (ert--stats-set-test-and-result stats pos new-test nil) + (setf (ert--ewoc-entry-test entry) new-test + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result + nil t)) + (ewoc-invalidate ewoc node)) + nil) + +(defun ert--button-action-position () + "The buffer position where the last button action was triggered." + (cond ((integerp last-command-event) + (point)) + ((eventp last-command-event) + (posn-point (event-start last-command-event))) + (t (assert nil)))) + +(defun ert--results-progress-bar-button-action (button) + "Jump to details for the test represented by the character clicked in BUTTON." + (goto-char (ert--button-action-position)) + (ert-results-jump-between-summary-and-result)) + +(defun ert-results-rerun-all-tests () + "Re-run all tests, using the same selector. + +To be used in the ERT results buffer." + (interactive) + (assert (eql major-mode 'ert-results-mode)) + (let ((selector (ert--stats-selector ert--results-stats))) + (ert-run-tests-interactively selector (buffer-name)))) + +(defun ert-results-rerun-test-at-point () + "Re-run the test at point. + +To be used in the ERT results buffer." + (interactive) + (destructuring-bind (test redefinition-state) + (ert--results-test-at-point-allow-redefinition) + (when (null test) + (error "No test at point")) + (let* ((stats ert--results-stats) + (progress-message (format "Running %stest %S" + (ecase redefinition-state + ((nil) "") + (redefined "new definition of ") + (deleted "deleted ")) + (ert-test-name test)))) + ;; Need to save and restore point manually here: When point is on + ;; the first visible ewoc entry while the header is updated, point + ;; moves to the top of the buffer. This is undesirable, and a + ;; simple `save-excursion' doesn't prevent it. + (let ((point (point))) + (unwind-protect + (unwind-protect + (progn + (message "%s..." progress-message) + (ert-run-or-rerun-test stats test + ert--results-listener)) + (ert--results-update-stats-display ert--results-ewoc stats) + (message "%s...%s" + progress-message + (let ((result (ert-test-most-recent-result test))) + (ert-string-for-test-result + result (ert-test-result-expected-p test result))))) + (goto-char point)))))) + +(defun ert-results-rerun-test-at-point-debugging-errors () + "Re-run the test at point with `ert-debug-on-error' bound to t. + +To be used in the ERT results buffer." + (interactive) + (let ((ert-debug-on-error t)) + (ert-results-rerun-test-at-point))) + +(defun ert-results-pop-to-backtrace-for-test-at-point () + "Display the backtrace for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (etypecase result + (ert-test-passed (error "Test passed, no backtrace available")) + (ert-test-result-with-condition + (let ((backtrace (ert-test-result-with-condition-backtrace result)) + (buffer (get-buffer-create "*ERT Backtrace*"))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + ;; Use unibyte because `debugger-setup-buffer' also does so. + (set-buffer-multibyte nil) + (setq truncate-lines t) + (ert--print-backtrace backtrace) + (debugger-make-xrefs) + (goto-char (point-min)) + (insert "Backtrace for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))))) + +(defun ert-results-pop-to-messages-for-test-at-point () + "Display the part of the *Messages* buffer generated during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT Messages*"))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (insert (ert-test-result-messages result)) + (goto-char (point-min)) + (insert "Messages for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))) + +(defun ert-results-pop-to-should-forms-for-test-at-point () + "Display the list of `should' forms executed during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT list of should forms*"))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null (ert-test-result-should-forms result)) + (insert "\n(No should forms during this test.)\n") + (loop for form-description in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) + (goto-char (point-min)) + (insert "`should' forms executed during test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n") + (insert "\n") + (insert (concat "(Values are shallow copies and may have " + "looked different during the test if they\n" + "have been modified destructively.)\n")) + (forward-line 1))))) + +(defun ert-results-toggle-printer-limits-for-test-at-point () + "Toggle how much of the condition to print for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((ewoc ert--results-ewoc) + (node (ert--results-test-node-at-point)) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-extended-printer-limits-p entry) + (not (ert--ewoc-entry-extended-printer-limits-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-pop-to-timings () + "Display test timings for the last run. + +To be used in the ERT results buffer." + (interactive) + (let* ((stats ert--results-stats) + (start-times (ert--stats-test-start-times stats)) + (end-times (ert--stats-test-end-times stats)) + (buffer (get-buffer-create "*ERT timings*")) + (data (loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time end-time + start-time)))))) + (setq data (sort data (lambda (a b) + (> (second a) (second b))))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null data) + (insert "(No data)\n") + (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) + (loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (let ((begin (point))) + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) + (goto-char (point-min)) + (insert "Tests by run time (seconds):\n\n") + (forward-line 1)))) + +;;;###autoload +(defun ert-describe-test (test-or-test-name) + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." + (interactive (list (ert-read-test-name-at-point "Describe test"))) + (when (< emacs-major-version 24) + (error "Requires Emacs 24")) + (let (test-name + test-definition) + (etypecase test-or-test-name + (symbol (setq test-name test-or-test-name + test-definition (ert-get-test test-or-test-name))) + (ert-test (setq test-name (ert-test-name test-or-test-name) + test-definition test-or-test-name))) + (help-setup-xref (list #'ert-describe-test test-or-test-name) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (if test-name (format "%S" test-name) "")) + (insert " is a test") + (let ((file-name (and test-name + (symbol-file test-name 'ert-deftest)))) + (when file-name + (insert " defined in `" (file-name-nondirectory file-name) "'") + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-def test-name file-name))) + (insert ".") + (fill-region-as-paragraph (point-min) (point)) + (insert "\n\n") + (unless (and (ert-test-boundp test-name) + (eql (ert-get-test test-name) test-definition)) + (let ((begin (point))) + (insert "Note: This test has been redefined or deleted, " + "this documentation refers to an old definition.") + (fill-region-as-paragraph begin (point))) + (insert "\n\n")) + (insert (or (ert-test-documentation test-definition) + "It is not documented.") + "\n"))))))) + +(defun ert-results-describe-test-at-point () + "Display the documentation of the test at point. + +To be used in the ERT results buffer." + (interactive) + (ert-describe-test (ert--results-test-at-point-no-redefinition))) + + +;;; Actions on load/unload. + +(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) +(add-to-list 'minor-mode-alist '(ert--current-run-stats + (:eval + (ert--tests-running-mode-line-indicator)))) +(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) + +(defun ert--unload-function () + "Unload function to undo the side-effects of loading ert.el." + (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) + (ert--remove-from-list 'emacs-lisp-mode-hook + 'ert--activate-font-lock-keywords) + nil) + +(defvar ert-unload-hook '()) +(add-hook 'ert-unload-hook 'ert--unload-function) + + +(provide 'ert) + +;;; ert.el ends here diff --git a/lib/goto-chg.el b/lib/goto-chg.el new file mode 100644 index 0000000..3881706 --- /dev/null +++ b/lib/goto-chg.el @@ -0,0 +1,317 @@ +;;; goto-chg.el --- goto last change +;;-------------------------------------------------------------------- +;; +;; Copyright (C) 2002-2008, David Andersson +;; +;; This program is free software; you can 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., 59 Temple Place, Suite 330, Boston, +;; MA 02111-1307 USA +;; +;;------------------------------------------------------------------- +;; +;; Author: David Andersson +;; Created: 16 May 2002 +;; Version: 1.4 +;; +;;; Commentary: +;; +;; Goto Last Change +;; +;; Goto the point of the most recent edit in the buffer. +;; When repeated, goto the second most recent edit, etc. +;; Negative argument, C-u -, for reverse direction. +;; Works by looking into buffer-undo-list to find points of edit. +;; +;; You would probably like to bind this command to a key. +;; For example in your ~/.emacs: +;; +;; (require 'goto-chg) +;; +;; (global-set-key [(control ?.)] 'goto-last-change) +;; (global-set-key [(control ?,)] 'goto-last-change-reverse) +;; +;; Works with emacs-19.29, 19.31, 20.3, 20.7, 21.1, 21.4 and 22.1. +;; Works with XEmacs-20.4 and 21.4 (but see todo about `last-command' below) +;; +;;-------------------------------------------------------------------- +;; History +;; +;; Ver 1.4 2008-09-20 David Andersson +;; Improved property change description; Update comments. +;; Ver 1.3 2007-03-14 David Andersson +;; Added `goto-last-change-reverse' +;; Ver 1.2 2003-04-06 David Andersson +;; Don't let repeating error depthen glc-probe-depth. +;; Ver 1.1 2003-04-06 David Andersson +;; Zero arg describe changes. Negative arg go back. +;; Autoload. Remove message using nil in stead of an empty string. +;; Ver 1.0 2002-05-18 David Andersson +;; Initial version +;; +;;-------------------------------------------------------------------- +;; +;;todo: Rename "goto-chg.el" -> "gotochange.el" or "goto-chgs" ? +;;todo: Rename function goto-last-change -> goto-last-edit ? +;;todo: Rename adjective "-last-" -> "-latest-" or "-most-recent-" ? +;;todo: There are some, maybe useful, funcs for region undo +;; in simple.el in emacs 20. Take a look. +;;todo: Add functionality to visit changed point in text order, not only in +;; chronological order. (Naa, highlight-changes-mode does that). +;;todo: Inverse indication that a change has been saved or not +;;todo: Highlight the range of text involved in the last change? +;;todo: Function that goes in reverse direction. Either a function +;; 'goto-next-change' only callable after 'goto-last-change' +;; or enter a minor mode similar to isearch. +;;todo: See session-jump-to-last-change in session.el? +;;todo: Unhide invisible text (e.g. outline mode) like isearch do. +;;todo: XEmacs sets last-command to `t' after an error, so you cannot reverse +;; after "No furter change info". Should we bother? +;;todo: Try distinguish "No further change info" (end of truncated undo list) +;; and "No further changes" (end of a complete undo list). +;; +;;-------------------------------------------------------------------- + +;;; Code: + +(defvar glc-default-span 8 "*goto-last-change don't visit the same point twice. glc-default-span tells how far around a visited point not to visit again.") +(defvar glc-current-span 8 "Internal for goto-last-change.\nA copy of glc-default-span or the ARG passed to goto-last-change.") +(defvar glc-probe-depth 0 "Internal for goto-last-change.\nIt is non-zero between successive goto-last-change.") + +;;todo: Find begin and end of line, then use it somewhere + +(defun glc-center-ellipsis (str maxlen &optional ellipsis) + "Truncate STRING in the middle to length MAXLEN. +If STRING is max MAXLEN just return the string. +Optional third argument is the replacement, which defaults to \"...\"." + (if (<= (length str) maxlen) + str + ;; else + (let* ((lipsis (or ellipsis "...")) + (i (/ (- maxlen (length lipsis)) 2))) + (concat (substring str 0 i) + lipsis + (substring str (- i)))))) + +(defun glc-adjust-pos2 (pos p1 p2 adj) + ;; Helper function to glc-adjust-pos + (cond ((<= pos (- p1 glc-current-span)) + pos) + ((> pos (+ p2 glc-current-span)) + (+ pos adj)) + ((zerop glc-current-span) + p1) + (t + nil))) + +(defun glc-adjust-pos (pos e) + "Given POS, a buffer position before the edit E, compute and return +the \"same\" buffer position after E happened. +Exception: return nil if POS is closer than `glc-current-span' to the edit E. +\nInsertion edits before POS returns a larger value. +Deletion edits before POS returns a smaller value. +\nThe edit E is an entry from the `buffer-undo-list'. See for details." + (cond ((atom e) ; nil==cmd boundary, or, num==changed pos + pos) + ((numberp (car e)) ; (beg . end)==insertion + (glc-adjust-pos2 pos (car e) (car e) (- (cdr e) (car e)))) +;; (cond ((< pos (- (car e) glc-current-span)) pos) +;; ((> pos (+ (car e) glc-current-span)) (+ pos (- (cdr e) (car e)))) +;; (t nil))) + ((stringp (car e)) ; (string . pos)==deletion + (glc-adjust-pos2 pos (abs (cdr e)) (+ (abs (cdr e)) (length (car e))) (- (length (car e))))) +;; (cond ((< pos (- (abs (cdr e)) glc-current-span)) pos) +;; ((> pos (+ (abs (cdr e)) (length (car e)) glc-current-span)) (- pos (length (car e)))) +;; (t nil))) + ((null (car e)) ; (nil prop val beg . end)==prop change + (glc-adjust-pos2 pos (nth 3 e) (nthcdr 4 e) 0)) +;; (cond ((< pos (- (nth 3 e) glc-current-span)) pos) +;; ((> pos (+ (nthcdr 4 e) glc-current-span)) pos) +;; (t nil))) + (t ; (marker . dist)==marker moved + pos))) + +;; If recursive in stead of iterative (while), it tends to fill the call stack. +;; (Isn't it tail optimized?) +(defun glc-adjust-list (r) + "R is list of edit entries in chronological order. +Pick the point of the first edit entry and update that point with +the second, third, etc, edit entries. Return the final updated point, +or nil if the point was closer than `glc-current-span' to some edit in R. +\nR is basically a reversed slice from the buffer-undo-list." + (if r + ;; Get pos + (let ((pos (glc-get-pos (car r)))) + (setq r (cdr r)) + ;; Walk back in reverse list + (while (and r pos) + (setq pos (glc-adjust-pos pos (car r)) + r (cdr r))) + pos) + ;; else + nil)) + +(defun glc-get-pos (e) + "If E represents an edit, return a position value in E, the position +where the edit took place. Return nil if E represents no real change. +\nE is a entry in the buffer-undo-list." + (cond ((numberp e) e) ; num==changed position + ((atom e) nil) ; nil==command boundary + ((numberp (car e)) (cdr e)) ; (beg . end)==insertion + ((stringp (car e)) (abs (cdr e))) ; (string . pos)==deletion + ((null (car e)) (nthcdr 4 e)) ; (nil ...)==text property change + ((atom (car e)) nil) ; (t ...)==file modification time + (t nil))) ; (marker ...)==marker moved + +(defun glc-get-descript (e &optional n) + "If E represents an edit, return a short string describing E. +Return nil if E represents no real change. +\nE is a entry in the buffer-undo-list." + (let ((nn (or (format "T-%d: " n) ""))) + (cond ((numberp e) "New position") ; num==changed position + ((atom e) nil) ; nil==command boundary + ((numberp (car e)) ; (beg . end)==insertion + (if (and n (< n 2)) + (format "%sInserted %d chars \"%s\"" nn (- (cdr e) (car e)) + (glc-center-ellipsis (buffer-substring (car e) (cdr e)) 60)) + ;; else + ;; An older insert. The inserted text cannot easily be computed. + ;; Just show the char count. + (format "%sInserted %d chars" nn (- (cdr e) (car e))))) + ((stringp (car e)) ; (string . pos)==deletion + (format "%sDeleted \"%s\"" nn (glc-center-ellipsis (car e) 60))) + ((null (car e)) ; (nil ...)==text property change + (format "%sProperty change" nn)) + ((atom (car e)) nil) ; (t ...)==file modification time + (t nil)))) ; (marker ...)==marker moved + +(defun glc-is-positionable (e) + "Return non-nil if E is an insertion, deletion or text property change. +\nE is a entry in the buffer-undo-list." + (and (not (numberp e)) (glc-get-pos e))) + +(defun glc-is-filetime (e) + "Return t if E indicates a buffer became \"modified\", +that is, it was previously saved or unchanged. Nil otherwise." + (and (listp e) (eq (car e) t))) + +;;;###autoload +(defun goto-last-change (arg) +"Go to the point where the last edit was made in the current buffer. +Repeat the command to go to the second last edit, etc. +A preceding \\[universal-argument] - (minus) will reverse direction for the next command in +the sequence, to go back to a more recent edit. +\nIt does not go to the same point twice even if there has been many edits +there. I call the minimal distance between distinguishable edits \"span\". +Set variable `glc-default-span' to control how close is \"the same point\". +Default span is 8. +The span can be changed temporarily with \\[universal-argument] right before \\[goto-last-change]: +\\[universal-argument] set current span to that number, +\\[universal-argument] (no number) multiplies span by 4, starting with default. +The so set span remains until it is changed again with \\[universal-argument], or the consecutive +repetition of this command is ended by any other command. +\nWhen span is zero (i.e. \\[universal-argument] 0) subsequent \\[goto-last-change] visits each and +every point of edit and a message shows what change was made there. +In this case it may go to the same point twice. +\nThis command uses undo information. If undo is disabled, so is this command. +At times, when undo information becomes too large, the oldest information is +discarded. See variable `undo-limit'." + (interactive "P") + (cond ((not (eq this-command last-command)) + ;; Start a glc sequence + ;; Don't go to current point if last command was an obvious edit + ;; (yank or self-insert, but not kill-region). Makes it easier to + ;; jump back and forth when copying seleced lines. + (setq glc-probe-depth (if (memq last-command '(yank self-insert-command)) 1 0) + glc-direction 1 + glc-current-span glc-default-span) + (if (< (prefix-numeric-value arg) 0) + (error "Negative arg: Cannot reverse as the first operation")))) + (cond ((null buffer-undo-list) + (error "Buffer has not been changed")) + ((eq buffer-undo-list t) + (error "No change info (undo is disabled)"))) + (cond ((numberp arg) ; Numeric arg sets span + (setq glc-current-span (abs arg))) + ((consp arg) ; C-u's multiply previous span by 4 + (setq glc-current-span (* (abs (car arg)) glc-default-span)) + (message "Current span is %d chars" glc-current-span))) ;todo: keep message with "waiting" and "is saved" + (cond ((< (prefix-numeric-value arg) 0) + (setq glc-direction -1)) + (t + (setq glc-direction 1))) + (let (rev ; Reversed (and filtered) undo list + pos ; The pos we look for, nil until found + (n 0) ; Steps in undo list (length of 'rev') + (l buffer-undo-list) + (passed-save-entry (not (buffer-modified-p))) + (new-probe-depth glc-probe-depth)) + ;; Walk back and forth in the buffer-undo-list, each time one step deeper, + ;; until we can walk back the whole list with a 'pos' that is not coming + ;; too close to another edit. + (while (null pos) + (setq new-probe-depth (+ new-probe-depth glc-direction)) + (if (< glc-direction 0) + (setq rev () + n 0 + l buffer-undo-list + passed-save-entry (not (buffer-modified-p)))) + (if (< new-probe-depth 1) + (error "No later change info")) + (if (> n 150) + (message "working...")) + ;; Walk forward in buffer-undo-list, glc-probe-depth steps. + ;; Build reverse list along the way + (while (< n new-probe-depth) + (cond ((null l) + ;(setq this-command t) ; Disrupt repeat sequence + (error "No further change info")) + ((glc-is-positionable (car l)) + (setq n (1+ n) + rev (cons (car l) rev))) + ((or passed-save-entry (glc-is-filetime (car l))) + (setq passed-save-entry t))) + (setq l (cdr l))) + ;; Walk back in reverse list, from older to newer edits. + ;; Adjusting pos along the way. + (setq pos (glc-adjust-list rev))) + ;; Found a place not previously visited, in 'pos'. + ;; (An error have been issued if nothing (more) found.) + (if (> n 150) + (message nil)) ; remove message "working..." + (if (and (= glc-current-span 0) (glc-get-descript (car rev) n)) + (message "%s" (glc-get-descript (car rev) n)) + ;; else + (if passed-save-entry + (message "(This change is saved)"))) + (setq glc-probe-depth new-probe-depth) + (goto-char pos))) + +;; ;;;###autoload +(defun goto-last-change-reverse (arg) + (interactive "P") + ;; Negate arg, all kinds + (cond ((eq arg nil) (setq arg '-)) + ((eq arg '-) (setq arg nil)) + ((listp arg) (setq arg (list (- (car arg))))) + (t (setq arg (- arg)))) + ;; Make 'goto-last-change-reverse' look like 'goto-last-change' + (cond ((eq last-command this-command) + (setq last-command 'goto-last-change))) + (setq this-command 'goto-last-change) + ;; Call 'goto-last-change' to do the job + (goto-last-change arg)) + +(provide 'goto-chg) + +;;; goto-chg.el ends here diff --git a/lib/undo-tree.el b/lib/undo-tree.el new file mode 100644 index 0000000..4edfa9d --- /dev/null +++ b/lib/undo-tree.el @@ -0,0 +1,3075 @@ + +;;; undo-tree.el --- Treat undo history as a tree + + +;; Copyright (C) 2009-2011 Toby Cubitt + +;; Author: Toby Cubitt +;; Version: 0.3 +;; Keywords: undo, redo, history, tree +;; URL: http://www.dr-qubit.org/emacs.php +;; Git Repository: http://www.dr-qubit.org/git/undo-tree.git + +;; This file is NOT part of Emacs. +;; +;; 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 3 of the License, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for +;; more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU Emacs. If not, see . + + +;;; Commentary: +;; +;; Emacs has a powerful undo system. Unlike the standard undo/redo system in +;; most software, it allows you to recover *any* past state of a buffer +;; (whereas the standard undo/redo system can lose past states as soon as you +;; redo). However, this power comes at a price: many people find Emacs' undo +;; system confusing and difficult to use, spawning a number of packages that +;; replace it with the less powerful but more intuitive undo/redo system. +;; +;; Both the loss of data with standard undo/redo, and the confusion of Emacs' +;; undo, stem from trying to treat undo history as a linear sequence of +;; changes. It's not. The `undo-tree-mode' provided by this package replaces +;; Emacs' undo system with a system that treats undo history as what it is: a +;; branching tree of changes. This simple idea allows the more intuitive +;; behaviour of the standard undo/redo system to be combined with the power of +;; never losing any history. An added side bonus is that undo history can in +;; some cases be stored more efficiently, allowing more changes to accumulate +;; before Emacs starts discarding history. +;; +;; The only downside to this more advanced yet simpler undo system is that it +;; was inspired by Vim. But, after all, most successful religions steal the +;; best ideas from their competitors! +;; +;; +;; Installation +;; ============ +;; +;; This package has only been tested with Emacs versions 22, 23 and CVS. It +;; will not work without modifications in earlier versions of Emacs. +;; +;; To install `undo-tree-mode', make sure this file is saved in a directory in +;; your `load-path', and add the line: +;; +;; (require 'undo-tree) +;; +;; to your .emacs file. Byte-compiling undo-tree.el is recommended (e.g. using +;; "M-x byte-compile-file" from within emacs). +;; +;; If you want to replace the standard Emacs' undo system with the +;; `undo-tree-mode' system in all buffers, you can enable it globally by +;; adding: +;; +;; (global-undo-tree-mode) +;; +;; to your .emacs file. +;; +;; +;; Quick-Start +;; =========== +;; +;; If you're the kind of person who likes jump in the car and drive, without +;; bothering to first figure out whether the button on the left dips the +;; headlights or operates the ejector seat (after all, you'll soon figure it +;; out when you push it), then here's the minimum you need to know: +;; +;; `undo-tree-mode' and `global-undo-tree-mode' +;; Enable undo-tree mode (either in the current buffer or globally). +;; +;; C-_ C-/ (`undo-tree-undo') +;; Undo changes. +;; +;; M-_ C-? (`undo-tree-redo') +;; Redo changes. +;; +;; `undo-tree-switch-branch' +;; Switch undo-tree branch. +;; (What does this mean? Better press the button and see!) +;; +;; C-x u (`undo-tree-visualize') +;; Visualize the undo tree. +;; (Better try pressing this button too!) +;; +;; C-x r u (`undo-tree-save-state-to-register') +;; Save current buffer state to register. +;; +;; C-x r U (`undo-tree-restore-state-from-register') +;; Restore buffer state from register. +;; +;; +;; In the undo-tree visualizer: +;; +;; p C-p (`undo-tree-visualize-undo') +;; Undo changes. +;; +;; n C-n (`undo-tree-visualize-redo') +;; Redo changes. +;; +;; b C-b (`undo-tree-visualize-switch-branch-left') +;; Switch to previous undo-tree branch. +;; +;; f C-f (`undo-tree-visualize-switch-branch-right') +;; Switch to next undo-tree branch. +;; +;; t (`undo-tree-visualizer-toggle-timestamps') +;; Toggle display of time-stamps. +;; +;; q C-q (`undo-tree-visualizer-quit') +;; Quit undo-tree-visualizer. +;; +;; , < +;; Scroll left. +;; +;; . > +;; Scroll right. +;; +;; +;; Scroll up. +;; +;; +;; Scroll down. +;; +;; +;; +;; Undo Systems +;; ============ +;; +;; To understand the different undo systems, it's easiest to consider an +;; example. Imagine you make a few edits in a buffer. As you edit, you +;; accumulate a history of changes, which we might visualize as a string of +;; past buffer states, growing downwards: +;; +;; o (initial buffer state) +;; | +;; | +;; o (first edit) +;; | +;; | +;; o (second edit) +;; | +;; | +;; x (current buffer state) +;; +;; +;; Now imagine that you undo the last two changes. We can visualize this as +;; rewinding the current state back two steps: +;; +;; o (initial buffer state) +;; | +;; | +;; x (current buffer state) +;; | +;; | +;; o +;; | +;; | +;; o +;; +;; +;; However, this isn't a good representation of what Emacs' undo system +;; does. Instead, it treats the undos as *new* changes to the buffer, and adds +;; them to the history: +;; +;; o (initial buffer state) +;; | +;; | +;; o (first edit) +;; | +;; | +;; o (second edit) +;; | +;; | +;; x (buffer state before undo) +;; | +;; | +;; o (first undo) +;; | +;; | +;; x (second undo) +;; +;; +;; Actually, since the buffer returns to a previous state after an undo, +;; perhaps a better way to visualize it is to imagine the string of changes +;; turning back on itself: +;; +;; (initial buffer state) o +;; | +;; | +;; (first edit) o x (second undo) +;; | | +;; | | +;; (second edit) o o (first undo) +;; | / +;; |/ +;; o (buffer state before undo) +;; +;; Treating undos as new changes might seem a strange thing to do. But the +;; advantage becomes clear as soon as we imagine what happens when you edit +;; the buffer again. Since you've undone a couple of changes, new edits will +;; branch off from the buffer state that you've rewound to. Conceptually, it +;; looks like this: +;; +;; o (initial buffer state) +;; | +;; | +;; o +;; |\ +;; | \ +;; o x (new edit) +;; | +;; | +;; o +;; +;; The standard undo/redo system only lets you go backwards and forwards +;; linearly. So as soon as you make that new edit, it discards the old +;; branch. Emacs' undo just keeps adding changes to the end of the string. So +;; the undo history in the two systems now looks like this: +;; +;; Undo/Redo: Emacs' undo +;; +;; o o +;; | | +;; | | +;; o o o +;; .\ | |\ +;; . \ | | \ +;; . x (new edit) o o | +;; (discarded . | / | +;; branch) . |/ | +;; . o | +;; | +;; | +;; x (new edit) +;; +;; Now, what if you change your mind about those undos, and decide you did +;; like those other changes you'd made after all? With the standard undo/redo +;; system, you're lost. There's no way to recover them, because that branch +;; was discarded when you made the new edit. +;; +;; However, in Emacs' undo system, those old buffer states are still there in +;; the undo history. You just have to rewind back through the new edit, and +;; back through the changes made by the undos, until you reach them. Of +;; course, since Emacs treats undos (even undos of undos!) as new changes, +;; you're really weaving backwards and forwards through the history, all the +;; time adding new changes to the end of the string as you go: +;; +;; o +;; | +;; | +;; o o o (undo new edit) +;; | |\ |\ +;; | | \ | \ +;; o o | | o (undo the undo) +;; | / | | | +;; |/ | | | +;; (trying to get o | | x (undo the undo) +;; to this state) | / +;; |/ +;; o +;; +;; So far, this is still reasonably intuitive to use. It doesn't behave so +;; differently to standard undo/redo, except that by going back far enough you +;; can access changes that would be lost in standard undo/redo. +;; +;; However, imagine that after undoing as just described, you decide you +;; actually want to rewind right back to the initial state. If you're lucky, +;; and haven't invoked any command since the last undo, you can just keep on +;; undoing until you get back to the start: +;; +;; (trying to get o x (got there!) +;; to this state) | | +;; | | +;; o o o o (keep undoing) +;; | |\ |\ | +;; | | \ | \ | +;; o o | | o o (keep undoing) +;; | / | | | / +;; |/ | | |/ +;; (already undid o | | o (got this far) +;; to this state) | / +;; |/ +;; o +;; +;; But if you're unlucky, and you happen to have moved the point (say) after +;; getting to the state labelled "got this far", then you've "broken the undo +;; chain". Hold on to something solid, because things are about to get +;; hairy. If you try to undo now, Emacs thinks you're trying to undo the +;; undos! So to get back to the initial state you now have to rewind through +;; *all* the changes, including the undos you just did: +;; +;; (trying to get o x (finally got there!) +;; to this state) | | +;; | | +;; o o o o o o +;; | |\ |\ |\ |\ | +;; | | \ | \ | \ | \ | +;; o o | | o o o | o o +;; | / | | | / | | | / +;; |/ | | |/ | | |/ +;; (already undid o | | o<. | | o +;; to this state) | / : | / +;; |/ : |/ +;; o : o +;; : +;; (got this far, but +;; broke the undo chain) +;; +;; Confused? +;; +;; In practice you can just hold down the undo key until you reach the buffer +;; state that you want. But whatever you do, don't move around in the buffer +;; to *check* that you've got back to where you want! Because you'll break the +;; undo chain, and then you'll have to traverse the entire string of undos +;; again, just to get back to the point at which you broke the +;; chain. Undo-in-region and commands such as `undo-only' help to make using +;; Emacs' undo a little easier, but nonetheless it remains confusing for many +;; people. +;; +;; +;; So what does `undo-tree-mode' do? Remember the diagram we drew to represent +;; the history we've been discussing (make a few edits, undo a couple of them, +;; and edit again)? The diagram that conceptually represented our undo +;; history, before we started discussing specific undo systems? It looked like +;; this: +;; +;; o (initial buffer state) +;; | +;; | +;; o +;; |\ +;; | \ +;; o x (current state) +;; | +;; | +;; o +;; +;; Well, that's *exactly* what the undo history looks like to +;; `undo-tree-mode'. It doesn't discard the old branch (as standard undo/redo +;; does), nor does it treat undos as new changes to be added to the end of a +;; linear string of buffer states (as Emacs' undo does). It just keeps track +;; of the tree of branching changes that make up the entire undo history. +;; +;; If you undo from this point, you'll rewind back up the tree to the previous +;; state: +;; +;; o +;; | +;; | +;; x (undo) +;; |\ +;; | \ +;; o o +;; | +;; | +;; o +;; +;; If you were to undo again, you'd rewind back to the initial state. If on +;; the other hand you redo the change, you'll end up back at the bottom of the +;; most recent branch: +;; +;; o (undo takes you here) +;; | +;; | +;; o (start here) +;; |\ +;; | \ +;; o x (redo takes you here) +;; | +;; | +;; o +;; +;; So far, this is just like the standard undo/redo system. But what if you +;; want to return to a buffer state located on a previous branch of the +;; history? Since `undo-tree-mode' keeps the entire history, you simply need +;; to tell it to switch to a different branch, and then redo the changes you +;; want: +;; +;; o +;; | +;; | +;; o (start here, but switch +;; |\ to the other branch) +;; | \ +;; (redo) o o +;; | +;; | +;; (redo) x +;; +;; Now you're on the other branch, if you undo and redo changes you'll stay on +;; that branch, moving up and down through the buffer states located on that +;; branch. Until you decide to switch branches again, of course. +;; +;; Real undo trees might have multiple branches and sub-branches: +;; +;; o +;; ____|______ +;; / \ +;; o o +;; ____|__ __| +;; / | \ / \ +;; o o o o x +;; | | +;; / \ / \ +;; o o o o +;; +;; Trying to imagine what Emacs' undo would do as you move about such a tree +;; will likely frazzle your brain circuits! But in `undo-tree-mode', you're +;; just moving around this undo history tree. Most of the time, you'll +;; probably only need to stay on the most recent branch, in which case it +;; behaves like standard undo/redo, and is just as simple to understand. But +;; if you ever need to recover a buffer state on a different branch, the +;; possibility of switching between branches and accessing the full undo +;; history is still there. +;; +;; +;; +;; The Undo-Tree Visualizer +;; ======================== +;; +;; Actually, it gets better. You don't have to imagine all these tree +;; diagrams, because `undo-tree-mode' includes an undo-tree visualizer which +;; draws them for you! In fact, it draws even better diagrams: it highlights +;; the node representing the current buffer state, it highlights the current +;; branch, and (by hitting "t") you can toggle the display of +;; time-stamps. (There's one other tiny difference: the visualizer puts the +;; most recent branch on the left rather than the right.) +;; +;; In the visualizer, the usual keys for moving up and down a buffer instead +;; move up and down the undo history tree (e.g. the up and down arrow keys, or +;; "C-n" and "C-p"). The state of the "parent" buffer (the buffer whose undo +;; history you are visualizing) is updated as you move around the undo tree in +;; the visualizer. If you reach a branch point in the visualizer, the usual +;; keys for moving forward and backward in a buffer instead switch branch +;; (e.g. the left and right arrow keys, or "C-f" and "C-b"). And clicking with +;; the mouse on any node in the visualizer will take you directly to that +;; node, resetting the state of the parent buffer to the state represented by +;; that node. +;; +;; It can be useful to see how long ago the parent buffer was in the state +;; represented by a particular node in the visualizer. Hitting "t" in the +;; visualizer toggles the display of time-stamps for all the nodes. (Note +;; that, because of the way `undo-tree-mode' works, these time-stamps may be +;; somewhat later than the true times, especially if it's been a long time +;; since you last undid any changes.) +;; +;; Finally, hitting "q" will quit the visualizer, leaving the parent buffer in +;; whatever state you ended at. +;; +;; +;; +;; Undo-in-Region +;; ============== +;; +;; Emacs allows a very useful and powerful method of undoing only selected +;; changes: when a region is active, only changes that affect the text within +;; that region will are undone. With the standard Emacs undo system, changes +;; produced by undoing-in-region naturally get added onto the end of the +;; linear undo history: +;; +;; o +;; | +;; | x (second undo-in-region) +;; o | +;; | | +;; | o (first undo-in-region) +;; o | +;; | / +;; |/ +;; o +;; +;; You can of course redo these undos-in-region as usual, by undoing the +;; undos: +;; +;; o +;; | +;; | o_ +;; o | \ +;; | | | +;; | o o (undo the undo-in-region) +;; o | | +;; | / | +;; |/ | +;; o x (undo the undo-in-region) +;; +;; +;; In `undo-tree-mode', undo-in-region works similarly: when there's an active +;; region, undoing only undoes changes that affect that region. However, the +;; way these undos-in-region are recorded in the undo history is quite +;; different. In `undo-tree-mode', undo-in-region creates a new branch in the +;; undo history. The new branch consists of an undo step that undoes some of +;; the changes that affect the current region, and another step that undoes +;; the remaining changes needed to rejoin the previous undo history. +;; +;; Previous undo history Undo-in-region +;; +;; o o +;; | | +;; | | +;; o o +;; | |\ +;; | | \ +;; o o x (undo-in-region) +;; | | | +;; | | | +;; x o o +;; +;; As long as you don't change the active region after undoing-in-region, +;; continuing to undo-in-region extends the new branch, pulling more changes +;; that affect the current region into an undo step immediately above your +;; current location in the undo tree, and pushing the point at which the new +;; branch is attached further up the tree: +;; +;; First undo-in-region Second undo-in-region +;; +;; o o +;; | |\ +;; | | \ +;; o o x (undo-in-region) +;; |\ | | +;; | \ | | +;; o x o o +;; | | | | +;; | | | | +;; o o o o +;; +;; Redoing takes you back down the undo tree, as usual (as long as you haven't +;; changed the active region after undoing-in-region, it doesn't matter if it +;; is still active): +;; +;; o +;; |\ +;; | \ +;; o o +;; | | +;; | | +;; o o (redo) +;; | | +;; | | +;; o x (redo) +;; +;; +;; What about redo-in-region? Obviously, this only makes sense if you have +;; already undone some changes, so that there are some changes to redo! +;; Redoing-in-region splits off a new branch of the undo history below your +;; current location in the undo tree. This time, the new branch consists of a +;; redo step that redoes some of the redo changes that affect the current +;; region, followed by all the remaining redo changes. +;; +;; Previous undo history Redo-in-region +;; +;; o o +;; | | +;; | | +;; x o +;; | |\ +;; | | \ +;; o o x (redo-in-region) +;; | | | +;; | | | +;; o o o +;; +;; As long as you don't change the active region after redoing-in-region, +;; continuing to redo-in-region extends the new branch, pulling more redo +;; changes into a redo step immediately below your current location in the +;; undo tree. +;; +;; First redo-in-region Second redo-in-region +;; +;; o o +;; | | +;; | | +;; o o +;; |\ |\ +;; | \ | \ +;; o x (redo-in-region) o o +;; | | | | +;; | | | | +;; o o o x (redo-in-region) +;; | +;; | +;; o +;; +;; Note that undo-in-region and redo-in-region only ever add new changes to +;; the undo tree, they *never* modify existing undo history. So you can always +;; return to previous buffer states by switching to a previous branch of the +;; tree. + + + +;;; Change Log: +;; +;; Version 0.3 +;; * implemented undo-in-region +;; * fixed bugs in `undo-list-transfer-to-tree' and +;; `undo-list-rebuild-from-tree' which caused errors when undo history was +;; empty or disabled +;; * defun `region-active-p' if not already defined, for compatibility with +;; older Emacsen +;; +;; Version 0.2.1 +;; * modified `undo-tree-node' defstruct and macros to allow arbitrary +;; meta-data to be stored in a plist associated with a node, and +;; reimplemented storage of visualizer data on top of this +;; * display registers storing undo-tree state in visualizer +;; * implemented keyboard selection in visualizer +;; * rebuild `buffer-undo-list' from tree when disabling `undo-tree-mode' +;; +;; Version 0.2 +;; * added support for marker undo entries +;; +;; Version 0.1.7 +;; * pass null argument to `kill-buffer' call in `undo-tree-visualizer-quit', +;; since the argument's not optional in earlier Emacs versions +;; * added match for "No further redo information" to +;; `debug-ignored-errors' to prevent debugger being called on this error +;; * made `undo-tree-visualizer-quit' select the window displaying the +;; visualizer's parent buffer, or switch to the parent buffer if no window +;; is displaying it +;; * fixed bug in `undo-tree-switch-branch' +;; * general code tidying and reorganisation +;; * fixed bugs in history-discarding logic +;; * fixed bug in `undo-tree-insert' triggered by `undo-tree-visualizer-set' +;; by ensuring mark is deactivated +;; +;; Version 0.1.6 +;; * added `undo-tree-mode-lighter' customization option to allow the +;; mode-line lighter to be changed +;; * bug-fix in `undo-tree-discard-node' +;; * added `undo-tree-save-state-to-register' and +;; `undo-tree-restore-state-from-register' commands and keybindings for +;; saving/restoring undo-tree states using registers +;; +;; Version 0.1.5 +;; * modified `undo-tree-visualize' to mark the visualizer window as +;; soft-dedicated, and changed `undo-tree-visualizer-quit' to use +;; `kill-buffer', so that the visualizer window is deleted along with its +;; buffer if the visualizer buffer was displayed in a new window, but not if +;; it was displayed in an existing window. +;; +;; Version 0.1.4 +;; * modified `undo-tree-undo' and `undo-tree-redo' to always replace +;; redo/undo entries with new ones generated by `primitive-undo', as the new +;; changesets will restore the point more reliably +;; +;; Version 0.1.3 +;; * fixed `undo-tree-visualizer-quit' to remove `after-change-functions' +;; hook there, rather than in `undo-tree-kill-visualizer' +;; +;; Version 0.1.2 +;; * fixed keybindings +;; * renamed `undo-tree-visualizer-switch-previous-branch' and +;; `undo-tree-visualizer-switch-next-branch' to +;; `undo-tree-visualizer-switch-branch-left' and +;; `undo-tree-visualizer-switch-branch-right' +;; +;; Version 0.1.1 +;; * prevented `undo-tree-kill-visualizer' from killing visualizer when +;; undoing/redoing from the visualizer, which completely broke the +;; visualizer! +;; * changed one redo binding, so that at least one set of undo/redo bindings +;; works in a terminal +;; * bound vertical scrolling commands in `undo-tree-visualizer-map', in case +;; they aren't bound globally +;; * added missing :group argument to `defface's +;; +;; Version 0.1 +;; * initial release + + + +;;; Code: + +(eval-when-compile (require 'cl)) + +;; `characterp' isn't defined in Emacs versions <= 22 +(unless (fboundp 'characterp) + (defalias 'characterp 'char-valid-p)) + +;; `region-active-p' isn't defined in Emacs versions <= 22 +(unless (fboundp 'region-active-p) + (defun region-active-p () (and transient-mark-mode mark-active))) + + + +;;; ===================================================================== +;;; Global variables and customization options + +(defvar buffer-undo-tree nil + "Tree of undo entries in current buffer.") +(make-variable-buffer-local 'buffer-undo-tree) + + +(defgroup undo-tree nil + "Tree undo/redo." + :group 'undo) + +(defcustom undo-tree-mode-lighter " Undo-Tree" + "Lighter displayed in mode line +when `undo-tree-mode' is enabled." + :group 'undo-tree + :type 'string) + +(defcustom undo-tree-visualizer-spacing 3 + "Horizontal spacing in undo-tree visualization. +Must be a postivie odd integer." + :group 'undo-tree + :type '(integer + :match (lambda (w n) (and (integerp n) (> n 0) (= (mod n 2) 1))))) +(make-variable-buffer-local 'undo-tree-visualizer-spacing) + +(defvar undo-tree-map nil + "Keymap used in undo-tree-mode.") + + +(defface undo-tree-visualizer-default-face + '((((class color)) :foreground "gray")) + "*Face used to draw undo-tree in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-current-face + '((((class color)) :foreground "red")) + "*Face used to highlight current undo-tree node in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-active-branch-face + '((((class color) (background dark)) + (:foreground "white" :weight bold)) + (((class color) (background light)) + (:foreground "black" :weight bold))) + "*Face used to highlight active undo-tree branch +in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-register-face + '((((class color)) :foreground "yellow")) + "*Face used to highlight undo-tree nodes saved to a register +in visualizer." + :group 'undo-tree) + +(defvar undo-tree-visualizer-map nil + "Keymap used in undo-tree visualizer.") + +(defvar undo-tree-visualizer-selection-map nil + "Keymap used in undo-tree visualizer selection mode.") + + +(defvar undo-tree-visualizer-parent-buffer nil + "Parent buffer in visualizer.") +(make-variable-buffer-local 'undo-tree-visualizer-parent-buffer) + +(defvar undo-tree-visualizer-timestamps nil + "Non-nil when visualizer is displaying time-stamps.") +(make-variable-buffer-local 'undo-tree-visualizer-timestamps) + +(defconst undo-tree-visualizer-buffer-name " *undo-tree*") + +;; prevent debugger being called on "No further redo information" +(add-to-list 'debug-ignored-errors "^No further redo information") + + + + +;;; ================================================================= +;;; Setup default keymaps + +(unless undo-tree-map + (setq undo-tree-map (make-sparse-keymap)) + ;; remap `undo' and `undo-only' to `undo-tree-undo' + (define-key undo-tree-map [remap undo] 'undo-tree-undo) + (define-key undo-tree-map [remap undo-only] 'undo-tree-undo) + ;; bind standard undo bindings (since these match redo counterparts) + (define-key undo-tree-map (kbd "C-/") 'undo-tree-undo) + (define-key undo-tree-map "\C-_" 'undo-tree-undo) + ;; redo doesn't exist normally, so define our own keybindings + (define-key undo-tree-map (kbd "C-?") 'undo-tree-redo) + (define-key undo-tree-map (kbd "M-_") 'undo-tree-redo) + ;; just in case something has defined `redo'... + (define-key undo-tree-map [remap redo] 'undo-tree-redo) + ;; we use "C-x u" for the undo-tree visualizer + (define-key undo-tree-map (kbd "\C-x u") 'undo-tree-visualize) + ;; bind register commands + (define-key undo-tree-map (kbd "C-x r u") + 'undo-tree-save-state-to-register) + (define-key undo-tree-map (kbd "C-x r U") + 'undo-tree-restore-state-from-register)) + + +(unless undo-tree-visualizer-map + (setq undo-tree-visualizer-map (make-keymap)) + ;; vertical motion keys undo/redo + (define-key undo-tree-visualizer-map [remap previous-line] + 'undo-tree-visualize-undo) + (define-key undo-tree-visualizer-map [remap next-line] + 'undo-tree-visualize-redo) + (define-key undo-tree-visualizer-map [up] + 'undo-tree-visualize-undo) + (define-key undo-tree-visualizer-map "p" + 'undo-tree-visualize-undo) + (define-key undo-tree-visualizer-map "\C-p" + 'undo-tree-visualize-undo) + (define-key undo-tree-visualizer-map [down] + 'undo-tree-visualize-redo) + (define-key undo-tree-visualizer-map "n" + 'undo-tree-visualize-redo) + (define-key undo-tree-visualizer-map "\C-n" + 'undo-tree-visualize-redo) + ;; horizontal motion keys switch branch + (define-key undo-tree-visualizer-map [remap forward-char] + 'undo-tree-visualize-switch-branch-right) + (define-key undo-tree-visualizer-map [remap backward-char] + 'undo-tree-visualize-switch-branch-left) + (define-key undo-tree-visualizer-map [right] + 'undo-tree-visualize-switch-branch-right) + (define-key undo-tree-visualizer-map "f" + 'undo-tree-visualize-switch-branch-right) + (define-key undo-tree-visualizer-map "\C-f" + 'undo-tree-visualize-switch-branch-right) + (define-key undo-tree-visualizer-map [left] + 'undo-tree-visualize-switch-branch-left) + (define-key undo-tree-visualizer-map "b" + 'undo-tree-visualize-switch-branch-left) + (define-key undo-tree-visualizer-map "\C-b" + 'undo-tree-visualize-switch-branch-left) + ;; mouse sets buffer state to node at click + (define-key undo-tree-visualizer-map [mouse-1] + 'undo-tree-visualizer-mouse-set) + ;; toggle timestamps + (define-key undo-tree-visualizer-map "t" + 'undo-tree-visualizer-toggle-timestamps) + ;; selection mode + (define-key undo-tree-visualizer-map "s" + 'undo-tree-visualizer-selection-mode) + ;; horizontal scrolling may be needed if the tree is very wide + (define-key undo-tree-visualizer-map "," + 'undo-tree-visualizer-scroll-left) + (define-key undo-tree-visualizer-map "." + 'undo-tree-visualizer-scroll-right) + (define-key undo-tree-visualizer-map "<" + 'undo-tree-visualizer-scroll-left) + (define-key undo-tree-visualizer-map ">" + 'undo-tree-visualizer-scroll-right) + ;; vertical scrolling may be needed if the tree is very tall + (define-key undo-tree-visualizer-map [next] 'scroll-up) + (define-key undo-tree-visualizer-map [prior] 'scroll-down) + ;; quit visualizer + (define-key undo-tree-visualizer-map "q" + 'undo-tree-visualizer-quit) + (define-key undo-tree-visualizer-map "\C-q" + 'undo-tree-visualizer-quit)) + + +(unless undo-tree-visualizer-selection-map + (setq undo-tree-visualizer-selection-map (make-keymap)) + ;; vertical motion keys move up and down tree + (define-key undo-tree-visualizer-selection-map [remap previous-line] + 'undo-tree-visualizer-select-previous) + (define-key undo-tree-visualizer-selection-map [remap next-line] + 'undo-tree-visualizer-select-next) + (define-key undo-tree-visualizer-selection-map [up] + 'undo-tree-visualizer-select-previous) + (define-key undo-tree-visualizer-selection-map "p" + 'undo-tree-visualizer-select-previous) + (define-key undo-tree-visualizer-selection-map "\C-p" + 'undo-tree-visualizer-select-previous) + (define-key undo-tree-visualizer-selection-map [down] + 'undo-tree-visualizer-select-next) + (define-key undo-tree-visualizer-selection-map "n" + 'undo-tree-visualizer-select-next) + (define-key undo-tree-visualizer-selection-map "\C-n" + 'undo-tree-visualizer-select-next) + ;; vertical scroll keys move up and down quickly + (define-key undo-tree-visualizer-selection-map [next] + (lambda () (interactive) (undo-tree-visualizer-select-next 10))) + (define-key undo-tree-visualizer-selection-map [prior] + (lambda () (interactive) (undo-tree-visualizer-select-previous 10))) + ;; horizontal motion keys move to left and right siblings + (define-key undo-tree-visualizer-selection-map [remap forward-char] + 'undo-tree-visualizer-select-right) + (define-key undo-tree-visualizer-selection-map [remap backward-char] + 'undo-tree-visualizer-select-left) + (define-key undo-tree-visualizer-selection-map [right] + 'undo-tree-visualizer-select-right) + (define-key undo-tree-visualizer-selection-map "f" + 'undo-tree-visualizer-select-right) + (define-key undo-tree-visualizer-selection-map "\C-f" + 'undo-tree-visualizer-select-right) + (define-key undo-tree-visualizer-selection-map [left] + 'undo-tree-visualizer-select-left) + (define-key undo-tree-visualizer-selection-map "b" + 'undo-tree-visualizer-select-left) + (define-key undo-tree-visualizer-selection-map "\C-b" + 'undo-tree-visualizer-select-left) + ;; horizontal scroll keys move left or right quickly + (define-key undo-tree-visualizer-selection-map "," + (lambda () (interactive) (undo-tree-visualizer-select-left 10))) + (define-key undo-tree-visualizer-selection-map "." + (lambda () (interactive) (undo-tree-visualizer-select-right 10))) + (define-key undo-tree-visualizer-selection-map "<" + (lambda () (interactive) (undo-tree-visualizer-select-left 10))) + (define-key undo-tree-visualizer-selection-map ">" + (lambda () (interactive) (undo-tree-visualizer-select-right 10))) + ;; mouse or sets buffer state to node at point/click + (define-key undo-tree-visualizer-selection-map "\r" + 'undo-tree-visualizer-set) + (define-key undo-tree-visualizer-selection-map [mouse-1] + 'undo-tree-visualizer-mouse-set) + ;; toggle timestamps + (define-key undo-tree-visualizer-selection-map "t" + 'undo-tree-visualizer-toggle-timestamps) + ;; quit visualizer selection mode + (define-key undo-tree-visualizer-selection-map "s" + 'undo-tree-visualizer-mode) + ;; quit visualizer + (define-key undo-tree-visualizer-selection-map "q" + 'undo-tree-visualizer-quit) + (define-key undo-tree-visualizer-selection-map "\C-q" + 'undo-tree-visualizer-quit)) + + + + +;;; ===================================================================== +;;; Undo-tree data structure + +(defstruct + (undo-tree + :named + (:constructor nil) + (:constructor make-undo-tree + (&aux + (root (make-undo-tree-node nil nil)) + (current root) + (size 0) + (object-pool (make-hash-table :test 'eq :weakness 'value)))) + (:copier nil)) + root current size object-pool) + + + +(defstruct + (undo-tree-node + (:type vector) ; create unnamed struct + (:constructor nil) + (:constructor make-undo-tree-node + (previous undo + &optional redo + &aux + (timestamp (current-time)) + (branch 0))) + (:constructor make-undo-tree-node-backwards + (next-node undo + &optional redo + &aux + (next (list next-node)) + (timestamp (current-time)) + (branch 0))) + (:copier nil)) + previous next undo redo timestamp branch meta-data) + + +(defmacro undo-tree-node-p (n) + (let ((len (length (make-undo-tree-node nil nil)))) + `(and (vectorp ,n) (= (length ,n) ,len)))) + + + +(defstruct + (undo-tree-region-data + (:type vector) ; create unnamed struct + (:constructor nil) + (:constructor make-undo-tree-region-data + (&optional undo-beginning undo-end + redo-beginning redo-end)) + (:constructor make-undo-tree-undo-region-data + (undo-beginning undo-end)) + (:constructor make-undo-tree-redo-region-data + (redo-beginning redo-end)) + (:copier nil)) + undo-beginning undo-end redo-beginning redo-end) + + +(defmacro undo-tree-region-data-p (r) + (let ((len (length (make-undo-tree-region-data)))) + `(and (vectorp ,r) (= (length ,r) ,len)))) + +(defmacro undo-tree-node-clear-region-data (node) + `(setf (undo-tree-node-meta-data ,node) + (delq nil + (delq :region + (plist-put (undo-tree-node-meta-data ,node) + :region nil))))) + + +(defmacro undo-tree-node-undo-beginning (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-undo-beginning r)))) + +(defmacro undo-tree-node-undo-end (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-undo-end r)))) + +(defmacro undo-tree-node-redo-beginning (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-redo-beginning r)))) + +(defmacro undo-tree-node-redo-end (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-redo-end r)))) + + +(defsetf undo-tree-node-undo-beginning (node) (val) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (make-undo-tree-region-data))))) + (setf (undo-tree-region-data-undo-beginning r) ,val))) + +(defsetf undo-tree-node-undo-end (node) (val) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (make-undo-tree-region-data))))) + (setf (undo-tree-region-data-undo-end r) ,val))) + +(defsetf undo-tree-node-redo-beginning (node) (val) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (make-undo-tree-region-data))))) + (setf (undo-tree-region-data-redo-beginning r) ,val))) + +(defsetf undo-tree-node-redo-end (node) (val) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (make-undo-tree-region-data))))) + (setf (undo-tree-region-data-redo-end r) ,val))) + + + +(defstruct + (undo-tree-visualizer-data + (:type vector) ; create unnamed struct + (:constructor nil) + (:constructor make-undo-tree-visualizer-data + (&optional lwidth cwidth rwidth marker)) + (:copier nil)) + lwidth cwidth rwidth marker) + + +(defmacro undo-tree-visualizer-data-p (v) + (let ((len (length (make-undo-tree-visualizer-data)))) + `(and (vectorp ,v) (= (length ,v) ,len)))) + +(defmacro undo-tree-node-clear-visualizer-data (node) + `(setf (undo-tree-node-meta-data ,node) + (delq nil + (delq :visualizer + (plist-put (undo-tree-node-meta-data ,node) + :visualizer nil))))) + + +(defmacro undo-tree-node-lwidth (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-lwidth v)))) + +(defmacro undo-tree-node-cwidth (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-cwidth v)))) + +(defmacro undo-tree-node-rwidth (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-rwidth v)))) + +(defmacro undo-tree-node-marker (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-marker v)))) + + +(defsetf undo-tree-node-lwidth (node) (val) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (make-undo-tree-visualizer-data))))) + (setf (undo-tree-visualizer-data-lwidth v) ,val))) + +(defsetf undo-tree-node-cwidth (node) (val) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (make-undo-tree-visualizer-data))))) + (setf (undo-tree-visualizer-data-cwidth v) ,val))) + +(defsetf undo-tree-node-rwidth (node) (val) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (make-undo-tree-visualizer-data))))) + (setf (undo-tree-visualizer-data-rwidth v) ,val))) + +(defsetf undo-tree-node-marker (node) (val) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (make-undo-tree-visualizer-data))))) + (setf (undo-tree-visualizer-data-marker v) ,val))) + + + +(defmacro undo-tree-node-register (node) + `(plist-get (undo-tree-node-meta-data ,node) :register)) + +(defsetf undo-tree-node-register (node) (val) + `(setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :register ,val))) + + + + +;;; ===================================================================== +;;; Basic undo-tree data structure functions + +(defun undo-tree-grow (undo) + "Add an UNDO node to current branch of `buffer-undo-tree'." + (let* ((current (undo-tree-current buffer-undo-tree)) + (new (make-undo-tree-node current undo))) + (push new (undo-tree-node-next current)) + (setf (undo-tree-current buffer-undo-tree) new))) + + +(defun undo-tree-grow-backwards (node undo &optional redo) + "Add new node *above* undo-tree NODE, and return new node. +Note that this will overwrite NODE's \"previous\" link, so should +only be used on a detached NODE, never on nodes that are already +part of `buffer-undo-tree'." + (let ((new (make-undo-tree-node-backwards node undo redo))) + (setf (undo-tree-node-previous node) new) + new)) + + +(defun undo-tree-splice-node (node splice) + "Splice NODE into undo tree, below node SPLICE. +Note that this will overwrite NODE's \"next\" and \"previous\" +links, so should only be used on a detached NODE, never on nodes +that are already part of `buffer-undo-tree'." + (setf (undo-tree-node-next node) (undo-tree-node-next splice) + (undo-tree-node-branch node) (undo-tree-node-branch splice) + (undo-tree-node-previous node) splice + (undo-tree-node-next splice) (list node) + (undo-tree-node-branch splice) 0) + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) node))) + + +(defun undo-tree-snip-node (node) + "Snip NODE out of undo tree." + (let* ((parent (undo-tree-node-previous node)) + position p) + ;; if NODE is only child, replace parent's next links with NODE's + (if (= (length (undo-tree-node-next parent)) 0) + (setf (undo-tree-node-next parent) (undo-tree-node-next node) + (undo-tree-node-branch parent) (undo-tree-node-branch node)) + ;; otherwise... + (setq position (undo-tree-position node (undo-tree-node-next parent))) + (cond + ;; if active branch used do go via NODE, set parent's branch to active + ;; branch of NODE + ((= (undo-tree-node-branch parent) position) + (setf (undo-tree-node-branch parent) + (+ position (undo-tree-node-branch node)))) + ;; if active branch didn't go via NODE, update parent's branch to point + ;; to same node as before + ((> (undo-tree-node-branch parent) position) + (incf (undo-tree-node-branch parent) + (1- (length (undo-tree-node-next node)))))) + ;; replace NODE in parent's next list with NODE's entire next list + (if (= position 0) + (setf (undo-tree-node-next parent) + (nconc (undo-tree-node-next node) + (cdr (undo-tree-node-next parent)))) + (setq p (nthcdr (1- position) (undo-tree-node-next parent))) + (setcdr p (nconc (undo-tree-node-next node) (cddr p))))) + ;; update previous links of NODE's children + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) parent)))) + + +(defun undo-tree-mapc (--undo-tree-mapc-function-- undo-tree) + ;; Apply FUNCTION to each node in UNDO-TREE. + (let ((stack (list (undo-tree-root undo-tree))) + node) + (while stack + (setq node (pop stack)) + (funcall --undo-tree-mapc-function-- node) + (setq stack (append (undo-tree-node-next node) stack))))) + + +(defmacro undo-tree-num-branches () + "Return number of branches at current undo tree node." + '(length (undo-tree-node-next (undo-tree-current buffer-undo-tree)))) + + +(defun undo-tree-position (node list) + "Find the first occurrence of NODE in LIST. +Return the index of the matching item, or nil of not found. +Comparison is done with 'eq." + (let ((i 0)) + (catch 'found + (while (progn + (when (eq node (car list)) (throw 'found i)) + (incf i) + (setq list (cdr list)))) + nil))) + + +(defvar *undo-tree-id-counter* 0) +(make-variable-buffer-local '*undo-tree-id-counter*) + +(defmacro undo-tree-generate-id () + ;; Generate a new, unique id (uninterned symbol). + ;; The name is made by appending a number to "undo-tree-id". + ;; (Copied from CL package `gensym'.) + `(let ((num (prog1 *undo-tree-id-counter* (incf *undo-tree-id-counter*)))) + (make-symbol (format "undo-tree-id%d" num)))) + + + + +;;; ===================================================================== +;;; Utility functions for handling `buffer-undo-list' and changesets + +(defmacro undo-list-marker-elt-p (elt) + `(markerp (car-safe ,elt))) + +(defmacro undo-list-GCd-marker-elt-p (elt) + `(and (symbolp (car-safe ,elt)) (numberp (cdr-safe ,elt)))) + + +(defun undo-tree-move-GC-elts-to-pool (elt) + ;; Move elements that can be garbage-collected into `buffer-undo-tree' + ;; object pool, substituting a unique id that can be used to retrieve them + ;; later. (Only markers require this treatment currently.) + (when (undo-list-marker-elt-p elt) + (let ((id (undo-tree-generate-id))) + (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree)) + (setcar elt id)))) + + +(defun undo-tree-restore-GC-elts-from-pool (elt) + ;; Replace object id's in ELT with corresponding objects from + ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if + ;; any object in ELT has been garbage-collected. + (if (undo-list-GCd-marker-elt-p elt) + (when (setcar elt (gethash (car elt) + (undo-tree-object-pool buffer-undo-tree))) + elt) + elt)) + + +(defun undo-list-clean-GCd-elts (undo-list) + ;; Remove object id's from UNDO-LIST that refer to elements that have been + ;; garbage-collected. UNDO-LIST is modified by side-effect. + (while (undo-list-GCd-marker-elt-p (car undo-list)) + (unless (gethash (caar undo-list) + (undo-tree-object-pool buffer-undo-tree)) + (setq undo-list (cdr undo-list)))) + (let ((p undo-list)) + (while (cdr p) + (when (and (undo-list-GCd-marker-elt-p (cadr p)) + (null (gethash (car (cadr p)) + (undo-tree-object-pool buffer-undo-tree)))) + (setcdr p (cddr p))) + (setq p (cdr p)))) + undo-list) + + +(defun undo-list-pop-changeset () + ;; Pop changeset from `buffer-undo-list'. + ;; discard undo boundaries at head of list + (while (null (car buffer-undo-list)) + (setq buffer-undo-list (cdr buffer-undo-list))) + ;; pop elements up to next undo boundary + (unless (eq (car buffer-undo-list) 'undo-tree-canary) + (let* ((changeset (list (pop buffer-undo-list))) + (p changeset)) + (while (progn + (undo-tree-move-GC-elts-to-pool (car p)) + (car buffer-undo-list)) + (setcdr p (list (pop buffer-undo-list))) + (setq p (cdr p))) + changeset))) + + +(defun undo-tree-copy-list (undo-list) + ;; Return a deep copy of first changeset in `undo-list'. Object id's are + ;; replaced by corresponding objects from `buffer-undo-tree' object-pool. + (when undo-list + (let (copy p) + ;; if first element contains an object id, replace it with object from + ;; pool, discarding element entirely if it's been GC'd + (while (null copy) + (setq copy + (undo-tree-restore-GC-elts-from-pool (pop undo-list)))) + (setq copy (list copy) + p copy) + ;; copy remaining elements, replacing object id's with objects from + ;; pool, or discarding them entirely if they've been GC'd + (while undo-list + (when (setcdr p (undo-tree-restore-GC-elts-from-pool + (undo-copy-list-1 (pop undo-list)))) + (setcdr p (list (cdr p))) + (setq p (cdr p)))) + copy))) + + + +(defun undo-list-transfer-to-tree () + ;; Transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'. + + ;; if `buffer-undo-tree' is empty, create initial undo-tree + (when (null buffer-undo-tree) (setq buffer-undo-tree (make-undo-tree))) + ;; make sure there's a canary at end of `buffer-undo-list' + (if (null buffer-undo-list) + (setq buffer-undo-list '(nil undo-tree-canary)) + (let ((elt (last buffer-undo-list))) + (unless (eq (car elt) 'undo-tree-canary) + (setcdr elt '(nil undo-tree-canary))))) + + (unless (eq (cadr buffer-undo-list) 'undo-tree-canary) + ;; create new node from first changeset in `buffer-undo-list', save old + ;; `buffer-undo-tree' current node, and make new node the current node + (let* ((node (make-undo-tree-node nil (undo-list-pop-changeset))) + (splice (undo-tree-current buffer-undo-tree)) + (size (undo-list-byte-size (undo-tree-node-undo node)))) + (setf (undo-tree-current buffer-undo-tree) node) + ;; grow tree fragment backwards using `buffer-undo-list' changesets + (while (and buffer-undo-list + (not (eq (cadr buffer-undo-list) 'undo-tree-canary))) + (setq node + (undo-tree-grow-backwards node (undo-list-pop-changeset))) + (incf size (undo-list-byte-size (undo-tree-node-undo node)))) + ;; if no undo history has been discarded from `buffer-undo-list' since + ;; last transfer, splice new tree fragment onto end of old + ;; `buffer-undo-tree' current node + (if (eq (cadr buffer-undo-list) 'undo-tree-canary) + (progn + (setf (undo-tree-node-previous node) splice) + (push node (undo-tree-node-next splice)) + (setf (undo-tree-node-branch splice) 0) + (incf (undo-tree-size buffer-undo-tree) size)) + ;; if undo history has been discarded, replace entire + ;; `buffer-undo-tree' with new tree fragment + (setq node (undo-tree-grow-backwards node nil)) + (setf (undo-tree-root buffer-undo-tree) node) + (setq buffer-undo-list '(nil undo-tree-canary)) + (setf (undo-tree-size buffer-undo-tree) size))) + ;; discard undo history if necessary + (undo-tree-discard-history))) + + +(defun undo-list-byte-size (undo-list) + ;; Return size (in bytes) of UNDO-LIST + (let ((size 0) (p undo-list)) + (while p + (incf size 8) ; cons cells use up 8 bytes + (when (and (consp (car p)) (stringp (caar p))) + (incf size (string-bytes (caar p)))) + (setq p (cdr p))) + size)) + + + +(defun undo-list-rebuild-from-tree () + "Rebuild `buffer-undo-list' from information in `buffer-undo-tree'." + (unless (eq buffer-undo-list t) + (undo-list-transfer-to-tree) + (setq buffer-undo-list nil) + (when buffer-undo-tree + (let ((stack (list (list (undo-tree-root buffer-undo-tree))))) + (push (sort (mapcar 'identity (undo-tree-node-next (caar stack))) + (lambda (a b) + (time-less-p (undo-tree-node-timestamp a) + (undo-tree-node-timestamp b)))) + stack) + ;; Traverse tree in depth-and-oldest-first order, but add undo records + ;; on the way down, and redo records on the way up. + (while (or (car stack) + (not (eq (car (nth 1 stack)) + (undo-tree-current buffer-undo-tree)))) + (if (car stack) + (progn + (setq buffer-undo-list + (append (undo-tree-node-undo (caar stack)) + buffer-undo-list)) + (undo-boundary) + (push (sort (mapcar 'identity + (undo-tree-node-next (caar stack))) + (lambda (a b) + (time-less-p (undo-tree-node-timestamp a) + (undo-tree-node-timestamp b)))) + stack)) + (pop stack) + (setq buffer-undo-list + (append (undo-tree-node-redo (caar stack)) + buffer-undo-list)) + (undo-boundary) + (pop (car stack)))))))) + + + + +;;; ===================================================================== +;;; History discarding functions + +(defun undo-tree-oldest-leaf (node) + ;; Return oldest leaf node below NODE. + (while (undo-tree-node-next node) + (setq node + (car (sort (mapcar 'identity (undo-tree-node-next node)) + (lambda (a b) + (time-less-p (undo-tree-node-timestamp a) + (undo-tree-node-timestamp b))))))) + node) + + +(defun undo-tree-discard-node (node) + ;; Discard NODE from `buffer-undo-tree', and return next in line for + ;; discarding. + + ;; don't discard current node + (unless (eq node (undo-tree-current buffer-undo-tree)) + + ;; discarding root node... + (if (eq node (undo-tree-root buffer-undo-tree)) + (cond + ;; should always discard branches before root + ((> (length (undo-tree-node-next node)) 1) + (error "Trying to discard undo-tree root which still\ + has multiple branches")) + ;; don't discard root if current node is only child + ((eq (car (undo-tree-node-next node)) + (undo-tree-current buffer-undo-tree)) + nil) + ;; discard root + (t + ;; make child of root into new root + (setq node (setf (undo-tree-root buffer-undo-tree) + (car (undo-tree-node-next node)))) + ;; update undo-tree size + (decf (undo-tree-size buffer-undo-tree) + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node)))) + ;; discard new root's undo data + (setf (undo-tree-node-undo node) nil + (undo-tree-node-redo node) nil) + ;; if new root has branches, or new root is current node, next node + ;; to discard is oldest leaf, otherwise it's new root + (if (or (> (length (undo-tree-node-next node)) 1) + (eq (car (undo-tree-node-next node)) + (undo-tree-current buffer-undo-tree))) + (undo-tree-oldest-leaf node) + node))) + + ;; discarding leaf node... + (let* ((parent (undo-tree-node-previous node)) + (current (nth (undo-tree-node-branch parent) + (undo-tree-node-next parent)))) + ;; update undo-tree size + (decf (undo-tree-size buffer-undo-tree) + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node)))) + (setf (undo-tree-node-next parent) + (delq node (undo-tree-node-next parent)) + (undo-tree-node-branch parent) + (undo-tree-position current (undo-tree-node-next parent))) + ;; if parent has branches, or parent is current node, next node to + ;; discard is oldest leaf, otherwise it's parent + (if (or (eq parent (undo-tree-current buffer-undo-tree)) + (and (undo-tree-node-next parent) + (or (not (eq parent (undo-tree-root buffer-undo-tree))) + (> (length (undo-tree-node-next parent)) 1)))) + (undo-tree-oldest-leaf parent) + parent))))) + + + +(defun undo-tree-discard-history () + "Discard undo history until we're within memory usage limits +set by `undo-limit', `undo-strong-limit' and `undo-outer-limit'." + + (when (> (undo-tree-size buffer-undo-tree) undo-limit) + ;; if there are no branches off root, first node to discard is root; + ;; otherwise it's leaf node at botom of oldest branch + (let ((node (if (> (length (undo-tree-node-next + (undo-tree-root buffer-undo-tree))) 1) + (undo-tree-oldest-leaf (undo-tree-root buffer-undo-tree)) + (undo-tree-root buffer-undo-tree)))) + + ;; discard nodes until memory use is within `undo-strong-limit' + (while (and node + (> (undo-tree-size buffer-undo-tree) undo-strong-limit)) + (setq node (undo-tree-discard-node node))) + + ;; discard nodes until next node to discard would bring memory use + ;; within `undo-limit' + (while (and node + ;; check first if last discard has brought us within + ;; `undo-limit', in case we can avoid more expensive + ;; `undo-strong-limit' calculation + ;; Note: this assumes undo-strong-limit > undo-limit; + ;; if not, effectively undo-strong-limit = undo-limit + (> (undo-tree-size buffer-undo-tree) undo-limit) + (> (- (undo-tree-size buffer-undo-tree) + ;; if next node to discard is root, the memory we + ;; free-up comes from discarding changesets from its + ;; only child... + (if (eq node (undo-tree-root buffer-undo-tree)) + (+ (undo-list-byte-size + (undo-tree-node-undo + (car (undo-tree-node-next node)))) + (undo-list-byte-size + (undo-tree-node-redo + (car (undo-tree-node-next node))))) + ;; ...otherwise, it comes from discarding changesets + ;; from along with the node itself + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node))) + )) + undo-limit)) + (setq node (undo-tree-discard-node node))) + + ;; if we're still over the `undo-outer-limit', discard entire history + (when (> (undo-tree-size buffer-undo-tree) undo-outer-limit) + ;; query first if `undo-ask-before-discard' is set + (if undo-ask-before-discard + (when (yes-or-no-p + (format + "Buffer `%s' undo info is %d bytes long; discard it? " + (buffer-name) (undo-tree-size buffer-undo-tree))) + (setq buffer-undo-tree nil)) + ;; otherwise, discard and display warning + (display-warning + '(undo discard-info) + (concat + (format "Buffer `%s' undo info was %d bytes long.\n" + (buffer-name) (undo-tree-size buffer-undo-tree)) + "The undo info was discarded because it exceeded\ + `undo-outer-limit'. + +This is normal if you executed a command that made a huge change +to the buffer. In that case, to prevent similar problems in the +future, set `undo-outer-limit' to a value that is large enough to +cover the maximum size of normal changes you expect a single +command to make, but not so large that it might exceed the +maximum memory allotted to Emacs. + +If you did not execute any such command, the situation is +probably due to a bug and you should report it. + +You can disable the popping up of this buffer by adding the entry +\(undo discard-info) to the user option `warning-suppress-types', +which is defined in the `warnings' library.\n") + :warning) + (setq buffer-undo-tree nil))) + ))) + + + + +;;; ===================================================================== +;;; Visualizer-related functions + +(defun undo-tree-compute-widths (undo-tree) + "Recursively compute widths for all UNDO-TREE's nodes." + (let ((stack (list (undo-tree-root undo-tree))) + res) + (while stack + ;; try to compute widths for node at top of stack + (if (undo-tree-node-p + (setq res (undo-tree-node-compute-widths (car stack)))) + ;; if computation fails, it returns a node whose widths still need + ;; computing, which we push onto the stack + (push res stack) + ;; otherwise, store widths and remove it from stack + (setf (undo-tree-node-lwidth (car stack)) (aref res 0) + (undo-tree-node-cwidth (car stack)) (aref res 1) + (undo-tree-node-rwidth (car stack)) (aref res 2)) + (pop stack))))) + + +(defun undo-tree-node-compute-widths (node) + ;; Compute NODE's left-, centre-, and right-subtree widths. Returns widths + ;; (in a vector) if successful. Otherwise, returns a node whose widths need + ;; calculating before NODE's can be calculated. + (let ((num-children (length (undo-tree-node-next node))) + (lwidth 0) (cwidth 0) (rwidth 0) + p w) + (catch 'need-widths + (cond + ;; leaf nodes have 0 width + ((= 0 num-children) + (setf cwidth 1 + (undo-tree-node-lwidth node) 0 + (undo-tree-node-cwidth node) 1 + (undo-tree-node-rwidth node) 0)) + + ;; odd number of children + ((= (mod num-children 2) 1) + (setq p (undo-tree-node-next node)) + ;; compute left-width + (dotimes (i (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (incf lwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + ;; if child's widths haven't been computed, return that child + (throw 'need-widths (car p))) + (setq p (cdr p))) + (if (undo-tree-node-lwidth (car p)) + (incf lwidth (undo-tree-node-lwidth (car p))) + (throw 'need-widths (car p))) + ;; centre-width is inherited from middle child + (setf cwidth (undo-tree-node-cwidth (car p))) + ;; compute right-width + (incf rwidth (undo-tree-node-rwidth (car p))) + (setq p (cdr p)) + (dotimes (i (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (incf rwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + (throw 'need-widths (car p))) + (setq p (cdr p)))) + + ;; even number of children + (t + (setq p (undo-tree-node-next node)) + ;; compute left-width + (dotimes (i (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (incf lwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + (throw 'need-widths (car p))) + (setq p (cdr p))) + ;; centre-width is 0 when number of children is even + (setq cwidth 0) + ;; compute right-width + (dotimes (i (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (incf rwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + (throw 'need-widths (car p))) + (setq p (cdr p))))) + + ;; return left-, centre- and right-widths + (vector lwidth cwidth rwidth)))) + + +(defun undo-tree-clear-visualizer-data (undo-tree) + ;; Clear visualizer data from UNDO-TREE. + (undo-tree-mapc + (lambda (node) (undo-tree-node-clear-visualizer-data node)) + undo-tree)) + + + + +;;; ===================================================================== +;;; Undo-in-region functions + +(defun undo-tree-pull-undo-in-region-branch (start end) + ;; Pull out entries from undo changesets to create a new undo-in-region + ;; branch, which undoes changeset entries lying between START and END first, + ;; followed by remaining entries from the changesets, before rejoining the + ;; existing undo tree history. Repeated calls will, if appropriate, extend + ;; the current undo-in-region branch rather than creating a new one. + + ;; if we're just reverting the last redo-in-region, we don't need to + ;; manipulate the undo tree at all + (if (undo-tree-reverting-redo-in-region-p start end) + t ; return t to indicate success + + ;; We build the `region-changeset' and `delta-list' lists forwards, using + ;; pointers `r' and `d' to the penultimate element of the list. So that we + ;; don't have to treat the first element differently, we prepend a dummy + ;; leading nil to the lists, and have the pointers point to that + ;; initially. + ;; Note: using '(nil) instead of (list nil) in the `let*' results in + ;; bizarre errors when the code is byte-compiled, where parts of the + ;; lists appear to survive across different calls to this function. + ;; An obscure byte-compiler bug, perhaps? + (let* ((region-changeset (list nil)) + (r region-changeset) + (delta-list (list nil)) + (d delta-list) + (node (undo-tree-current buffer-undo-tree)) + (repeated-undo-in-region + (undo-tree-repeated-undo-in-region-p start end)) + undo-adjusted-markers ; `undo-elt-in-region' expects this + fragment splice original-fragment original-splice original-current + got-visible-elt undo-list elt) + + ;; --- initialisation --- + (cond + ;; if this is a repeated undo in the same region, start pulling changes + ;; from NODE at which undo-in-region branch iss attached, and detatch + ;; the branch, using it as initial FRAGMENT of branch being constructed + (repeated-undo-in-region + (setq original-current node + fragment (car (undo-tree-node-next node)) + splice node) + ;; undo up to node at which undo-in-region branch is attached + ;; (recognizable as first node with more than one branch) + (let ((mark-active nil)) + (while (= (length (undo-tree-node-next node)) 1) + (undo-tree-undo) + (setq fragment node + node (undo-tree-current buffer-undo-tree)))) + (when (eq splice node) (setq splice nil)) + ;; detatch undo-in-region branch + (setf (undo-tree-node-next node) + (delq fragment (undo-tree-node-next node)) + (undo-tree-node-previous fragment) nil + original-fragment fragment + original-splice node)) + + ;; if this is a new undo-in-region, initial FRAGMENT is a copy of all + ;; nodes below the current one in the active branch + ((undo-tree-node-next node) + (setq fragment (make-undo-tree-node nil nil) + splice fragment) + (while (setq node (nth (undo-tree-node-branch node) + (undo-tree-node-next node))) + (push (make-undo-tree-node + splice + (undo-copy-list (undo-tree-node-undo node)) + (undo-copy-list (undo-tree-node-redo node))) + (undo-tree-node-next splice)) + (setq splice (car (undo-tree-node-next splice)))) + (setq fragment (car (undo-tree-node-next fragment)) + splice nil + node (undo-tree-current buffer-undo-tree)))) + + + ;; --- pull undo-in-region elements into branch --- + ;; work backwards up tree, pulling out undo elements within region until + ;; we've got one that undoes a visible change (insertion or deletion) + (catch 'abort + (while (and (not got-visible-elt) node (undo-tree-node-undo node)) + ;; we cons a dummy nil element on the front of the changeset so that + ;; we can conveniently remove the first (real) element from the + ;; changeset if we need to; the leading nil is removed once we're + ;; done with this changeset + (setq undo-list (cons nil (undo-copy-list (undo-tree-node-undo node))) + elt (cadr undo-list)) + (if fragment + (progn + (setq fragment (undo-tree-grow-backwards fragment undo-list)) + (unless splice (setq splice fragment))) + (setq fragment (make-undo-tree-node nil undo-list)) + (setq splice fragment)) + + (while elt + (cond + ;; keep elements within region + ((undo-elt-in-region elt start end) + ;; set flag if kept element is visible (insertion or deletion) + (when (and (consp elt) + (or (stringp (car elt)) (integerp (car elt)))) + (setq got-visible-elt t)) + ;; adjust buffer positions in elements previously undone before + ;; kept element, as kept element will now be undone first + (undo-tree-adjust-elements-to-elt splice elt) + ;; move kept element to undo-in-region changeset, adjusting its + ;; buffer position as it will now be undone first + (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list)))) + (setq r (cdr r)) + (setcdr undo-list (cddr undo-list))) + + ;; discard "was unmodified" elements + ;; FIXME: deal properly with these + ((and (consp elt) (eq (car elt) t)) + (setcdr undo-list (cddr undo-list))) + + ;; if element crosses region, we can't pull any more elements + ((undo-elt-crosses-region elt start end) + ;; if we've found a visible element, it must be earlier in + ;; current node's changeset; stop pulling elements (null + ;; `undo-list' and non-nil `got-visible-elt' cause loop to exit) + (if got-visible-elt + (setq undo-list nil) + ;; if we haven't found a visible element yet, pulling + ;; undo-in-region branch has failed + (setq region-changeset nil) + (throw 'abort t))) + + ;; if rejecting element, add its delta (if any) to the list + (t + (let ((delta (undo-delta elt))) + (when (/= 0 (cdr delta)) + (setcdr d (list delta)) + (setq d (cdr d)))) + (setq undo-list (cdr undo-list)))) + + ;; process next element of current changeset + (setq elt (cadr undo-list))) + + ;; if there are remaining elements in changeset, remove dummy nil + ;; from front + (if (cadr (undo-tree-node-undo fragment)) + (pop (undo-tree-node-undo fragment)) + ;; otherwise, if we've kept all elements in changeset, discard + ;; empty changeset + (when (eq splice fragment) (setq splice nil)) + (setq fragment (car (undo-tree-node-next fragment)))) + ;; process changeset from next node up the tree + (setq node (undo-tree-node-previous node)))) + + ;; pop dummy nil from front of `region-changeset' + (pop region-changeset) + + + ;; --- integrate branch into tree --- + ;; if no undo-in-region elements were found, restore undo tree + (if (null region-changeset) + (when original-current + (push original-fragment (undo-tree-node-next original-splice)) + (setf (undo-tree-node-branch original-splice) 0 + (undo-tree-node-previous original-fragment) original-splice) + (let ((mark-active nil)) + (while (not (eq (undo-tree-current buffer-undo-tree) + original-current)) + (undo-tree-redo))) + nil) ; return nil to indicate failure + + ;; otherwise... + ;; need to undo up to node where new branch will be attached, to + ;; ensure redo entries are populated, and then redo back to where we + ;; started + (let ((mark-active nil) + (current (undo-tree-current buffer-undo-tree))) + (while (not (eq (undo-tree-current buffer-undo-tree) node)) + (undo-tree-undo)) + (while (not (eq (undo-tree-current buffer-undo-tree) current)) + (undo-tree-redo))) + + (cond + ;; if there's no remaining fragment, just create undo-in-region node + ;; and attach it to parent of last node from which elements were + ;; pulled + ((null fragment) + (setq fragment (make-undo-tree-node node region-changeset)) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0) + ;; set current node to undo-in-region node + (setf (undo-tree-current buffer-undo-tree) fragment)) + + ;; if no splice point has been set, add undo-in-region node to top of + ;; fragment and attach it to parent of last node from which elements + ;; were pulled + ((null splice) + (setq fragment (undo-tree-grow-backwards fragment region-changeset)) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0 + (undo-tree-node-previous fragment) node) + ;; set current node to undo-in-region node + (setf (undo-tree-current buffer-undo-tree) fragment)) + + ;; if fragment contains nodes, attach fragment to parent of last node + ;; from which elements were pulled, and splice in undo-in-region node + (t + (setf (undo-tree-node-previous fragment) node) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0) + ;; if this is a repeated undo-in-region, then we've left the current + ;; node at the original splice-point; we need to set the current + ;; node to the equivalent node on the undo-in-region branch and redo + ;; back to where we started + (when repeated-undo-in-region + (setf (undo-tree-current buffer-undo-tree) + (undo-tree-node-previous original-fragment)) + (let ((mark-active nil)) + (while (not (eq (undo-tree-current buffer-undo-tree) splice)) + (undo-tree-redo nil 'preserve-undo)))) + ;; splice new undo-in-region node into fragment + (setq node (make-undo-tree-node nil region-changeset)) + (undo-tree-splice-node node splice) + ;; set current node to undo-in-region node + (setf (undo-tree-current buffer-undo-tree) node))) + + ;; update undo-tree size + (setq node (undo-tree-node-previous fragment)) + (while (progn + (and (setq node (car (undo-tree-node-next node))) + (not (eq node original-fragment)) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo node))) + (when (undo-tree-node-redo node) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo node)))) + ))) + t) ; indicate undo-in-region branch was successfully pulled + ))) + + + +(defun undo-tree-pull-redo-in-region-branch (start end) + ;; Pull out entries from redo changesets to create a new redo-in-region + ;; branch, which redoes changeset entries lying between START and END first, + ;; followed by remaining entries from the changesets. Repeated calls will, + ;; if appropriate, extend the current redo-in-region branch rather than + ;; creating a new one. + + ;; if we're just reverting the last undo-in-region, we don't need to + ;; manipulate the undo tree at all + (if (undo-tree-reverting-undo-in-region-p start end) + t ; return t to indicate success + + ;; We build the `region-changeset' and `delta-list' lists forwards, using + ;; pointers `r' and `d' to the penultimate element of the list. So that we + ;; don't have to treat the first element differently, we prepend a dummy + ;; leading nil to the lists, and have the pointers point to that + ;; initially. + ;; Note: using '(nil) instead of (list nil) in the `let*' causes bizarre + ;; errors when the code is byte-compiled, where parts of the lists + ;; appear to survive across different calls to this function. An + ;; obscure byte-compiler bug, perhaps? + (let* ((region-changeset (list nil)) + (r region-changeset) + (delta-list (list nil)) + (d delta-list) + (node (undo-tree-current buffer-undo-tree)) + (repeated-redo-in-region + (undo-tree-repeated-redo-in-region-p start end)) + undo-adjusted-markers ; `undo-elt-in-region' expects this + fragment splice got-visible-elt redo-list elt) + + ;; --- inisitalisation --- + (cond + ;; if this is a repeated redo-in-region, detach fragment below current + ;; node + (repeated-redo-in-region + (when (setq fragment (car (undo-tree-node-next node))) + (setf (undo-tree-node-previous fragment) nil + (undo-tree-node-next node) + (delq fragment (undo-tree-node-next node))))) + ;; if this is a new redo-in-region, initial fragment is a copy of all + ;; nodes below the current one in the active branch + ((undo-tree-node-next node) + (setq fragment (make-undo-tree-node nil nil) + splice fragment) + (while (setq node (nth (undo-tree-node-branch node) + (undo-tree-node-next node))) + (push (make-undo-tree-node + splice nil + (undo-copy-list (undo-tree-node-redo node))) + (undo-tree-node-next splice)) + (setq splice (car (undo-tree-node-next splice)))) + (setq fragment (car (undo-tree-node-next fragment))))) + + + ;; --- pull redo-in-region elements into branch --- + ;; work down fragment, pulling out redo elements within region until + ;; we've got one that redoes a visible change (insertion or deletion) + (setq node fragment) + (catch 'abort + (while (and (not got-visible-elt) node (undo-tree-node-redo node)) + ;; we cons a dummy nil element on the front of the changeset so that + ;; we can conveniently remove the first (real) element from the + ;; changeset if we need to; the leading nil is removed once we're + ;; done with this changeset + (setq redo-list (push nil (undo-tree-node-redo node)) + elt (cadr redo-list)) + (while elt + (cond + ;; keep elements within region + ((undo-elt-in-region elt start end) + ;; set flag if kept element is visible (insertion or deletion) + (when (and (consp elt) + (or (stringp (car elt)) (integerp (car elt)))) + (setq got-visible-elt t)) + ;; adjust buffer positions in elements previously redone before + ;; kept element, as kept element will now be redone first + (undo-tree-adjust-elements-to-elt fragment elt t) + ;; move kept element to redo-in-region changeset, adjusting its + ;; buffer position as it will now be redone first + (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list) -1))) + (setq r (cdr r)) + (setcdr redo-list (cddr redo-list))) + + ;; discard "was unmodified" elements + ;; FIXME: deal properly with these + ((and (consp elt) (eq (car elt) t)) + (setcdr redo-list (cddr redo-list))) + + ;; if element crosses region, we can't pull any more elements + ((undo-elt-crosses-region elt start end) + ;; if we've found a visible element, it must be earlier in + ;; current node's changeset; stop pulling elements (null + ;; `redo-list' and non-nil `got-visible-elt' cause loop to exit) + (if got-visible-elt + (setq redo-list nil) + ;; if we haven't found a visible element yet, pulling + ;; redo-in-region branch has failed + (setq region-changeset nil) + (throw 'abort t))) + + ;; if rejecting element, add its delta (if any) to the list + (t + (let ((delta (undo-delta elt))) + (when (/= 0 (cdr delta)) + (setcdr d (list delta)) + (setq d (cdr d)))) + (setq redo-list (cdr redo-list)))) + + ;; process next element of current changeset + (setq elt (cadr redo-list))) + + ;; if there are remaining elements in changeset, remove dummy nil + ;; from front + (if (cadr (undo-tree-node-redo node)) + (pop (undo-tree-node-undo node)) + ;; otherwise, if we've kept all elements in changeset, discard + ;; empty changeset + (if (eq fragment node) + (setq fragment (car (undo-tree-node-next fragment))) + (undo-tree-snip-node node))) + ;; process changeset from next node in fragment + (setq node (car (undo-tree-node-next node))))) + + ;; pop dummy nil from front of `region-changeset' + (pop region-changeset) + + + ;; --- integrate branch into tree --- + (setq node (undo-tree-current buffer-undo-tree)) + ;; if no redo-in-region elements were found, restore undo tree + (if (null (car region-changeset)) + (when (and repeated-redo-in-region fragment) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0 + (undo-tree-node-previous fragment) node) + nil) ; return nil to indicate failure + + ;; otherwise, add redo-in-region node to top of fragment, and attach + ;; it below current node + (setq fragment + (if fragment + (undo-tree-grow-backwards fragment nil region-changeset) + (make-undo-tree-node nil nil region-changeset))) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0 + (undo-tree-node-previous fragment) node) + ;; update undo-tree size + (unless repeated-redo-in-region + (setq node fragment) + (while (progn + (and (setq node (car (undo-tree-node-next node))) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size + (undo-tree-node-redo node))))))) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo fragment))) + t) ; indicate undo-in-region branch was successfully pulled + ))) + + + +(defun undo-tree-adjust-elements-to-elt (node undo-elt &optional below) + "Adjust buffer positions of undo elements, starting at NODE's +and going up the tree (or down the active branch if BELOW is +non-nil) and through the nodes' undo elements until we reach +UNDO-ELT. UNDO-ELT must appear somewhere in the undo changeset +of either NODE itself or some node above it in the tree." + (let ((delta (list (undo-delta undo-elt))) + (undo-list (undo-tree-node-undo node))) + ;; adjust elements until we reach UNDO-ELT + (while (and (car undo-list) + (not (eq (car undo-list) undo-elt))) + (setcar undo-list + (undo-tree-apply-deltas (car undo-list) delta -1)) + ;; move to next undo element in list, or to next node if we've run out + ;; of elements + (unless (car (setq undo-list (cdr undo-list))) + (if below + (setq node (nth (undo-tree-node-branch node) + (undo-tree-node-next node))) + (setq node (undo-tree-node-previous node))) + (setq undo-list (undo-tree-node-undo node)))))) + + + +(defun undo-tree-apply-deltas (undo-elt deltas &optional sgn) + ;; Apply DELTAS in order to UNDO-ELT, multiplying deltas by SGN + ;; (only useful value for SGN is -1). + (let (position offset) + (dolist (delta deltas) + (setq position (car delta) + offset (* (cdr delta) (or sgn 1))) + (cond + ;; POSITION + ((integerp undo-elt) + (when (>= undo-elt position) + (setq undo-elt (- undo-elt offset)))) + ;; nil (or any other atom) + ((atom undo-elt)) + ;; (TEXT . POSITION) + ((stringp (car undo-elt)) + (let ((text-pos (abs (cdr undo-elt))) + (point-at-end (< (cdr undo-elt) 0))) + (if (>= text-pos position) + (setcdr undo-elt (* (if point-at-end -1 1) + (- text-pos offset)))))) + ;; (BEGIN . END) + ((integerp (car undo-elt)) + (when (>= (car undo-elt) position) + (setcar undo-elt (- (car undo-elt) offset)) + (setcdr undo-elt (- (cdr undo-elt) offset)))) + ;; (nil PROPERTY VALUE BEG . END) + ((null (car undo-elt)) + (let ((tail (nthcdr 3 undo-elt))) + (when (>= (car tail) position) + (setcar tail (- (car tail) offset)) + (setcdr tail (- (cdr tail) offset))))) + )) + undo-elt)) + + + +(defun undo-tree-repeated-undo-in-region-p (start end) + ;; Return non-nil if undo-in-region between START and END is a repeated + ;; undo-in-region + (let ((node (undo-tree-current buffer-undo-tree))) + (and (setq node + (nth (undo-tree-node-branch node) (undo-tree-node-next node))) + (eq (undo-tree-node-undo-beginning node) start) + (eq (undo-tree-node-undo-end node) end)))) + + +(defun undo-tree-repeated-redo-in-region-p (start end) + ;; Return non-nil if undo-in-region between START and END is a repeated + ;; undo-in-region + (let ((node (undo-tree-current buffer-undo-tree))) + (and (eq (undo-tree-node-redo-beginning node) start) + (eq (undo-tree-node-redo-end node) end)))) + + +;; Return non-nil if undo-in-region between START and END is simply +;; reverting the last redo-in-region +(defalias 'undo-tree-reverting-undo-in-region-p + 'undo-tree-repeated-undo-in-region-p) + + +;; Return non-nil if redo-in-region between START and END is simply +;; reverting the last undo-in-region +(defalias 'undo-tree-reverting-redo-in-region-p + 'undo-tree-repeated-redo-in-region-p) + + + + +;;; ===================================================================== +;;; Undo-tree commands + +(define-minor-mode undo-tree-mode + "Toggle undo-tree mode. +With no argument, this command toggles the mode. +A positive prefix argument turns the mode on. +A negative prefix argument turns it off. + +Undo-tree-mode replaces Emacs' standard undo feature with a more +powerful yet easier to use version, that treats the undo history +as what it is: a tree. + +The following keys are available in `undo-tree-mode': + + \\{undo-tree-map} + +Within the undo-tree visualizer, the following keys are available: + + \\{undo-tree-visualizer-map}" + + nil ; init value + undo-tree-mode-lighter ; lighter + undo-tree-map ; keymap + ;; if disabling `undo-tree-mode', rebuild `buffer-undo-list' from tree so + ;; Emacs undo can work + (unless undo-tree-mode + (undo-list-rebuild-from-tree) + (setq buffer-undo-tree nil))) + + +(defun turn-on-undo-tree-mode () + "Enable undo-tree-mode." + (undo-tree-mode 1)) + + +(define-globalized-minor-mode global-undo-tree-mode + undo-tree-mode turn-on-undo-tree-mode) + + + +(defun undo-tree-undo (&optional arg preserve-redo) + "Undo changes. +Repeat this command to undo more changes. +A numeric ARG serves as a repeat count. + +In Transient Mark mode when the mark is active, only undo changes +within the current region. Similarly, when not in Transient Mark +mode, just \\[universal-argument] as an argument limits undo to +changes within the current region. + +A non-nil PRESERVE-REDO causes the existing redo record to be +preserved, rather than replacing it with the new one generated by +undoing." + (interactive "*P") + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) (error "No undo information in this buffer")) + + (let ((undo-in-progress t) + (undo-in-region (or (region-active-p) (and arg (not (numberp arg))))) + pos current) + ;; transfer entries accumulated in `buffer-undo-list' to + ;; `buffer-undo-tree' + (undo-list-transfer-to-tree) + + (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1)) + ;; check if at top of undo tree + (unless (undo-tree-node-previous (undo-tree-current buffer-undo-tree)) + (error "No further undo information")) + + ;; if region is active, or a non-numeric prefix argument was supplied, + ;; try to pull out a new branch of changes affecting the region + (when (and undo-in-region + (not (undo-tree-pull-undo-in-region-branch + (region-beginning) (region-end)))) + (error "No further undo information for region")) + + ;; remove any GC'd elements from node's undo list + (setq current (undo-tree-current buffer-undo-tree)) + (decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + (setf (undo-tree-node-undo current) + (undo-list-clean-GCd-elts (undo-tree-node-undo current))) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + ;; undo one record from undo tree + (when undo-in-region + (setq pos (set-marker (make-marker) (point))) + (set-marker-insertion-type pos t)) + (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current))) + (undo-boundary) + + ;; if preserving old redo record, discard new redo entries that + ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd + ;; elements from node's redo list + (if preserve-redo + (progn + (undo-list-pop-changeset) + (decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + (setf (undo-tree-node-redo current) + (undo-list-clean-GCd-elts (undo-tree-node-redo current))) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current)))) + ;; otherwise, record redo entries that `primitive-undo' has added to + ;; `buffer-undo-list' in current node's redo record, replacing + ;; existing entry if one already exists + (when (undo-tree-node-redo current) + (decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current)))) + (setf (undo-tree-node-redo current) (undo-list-pop-changeset)) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current)))) + + ;; rewind current node and update timestamp + (setf (undo-tree-current buffer-undo-tree) + (undo-tree-node-previous (undo-tree-current buffer-undo-tree)) + (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree)) + (current-time)) + + ;; if undoing-in-region, record current node, region and direction so we + ;; can tell if undo-in-region is repeated, and re-activate mark if in + ;; `transient-mark-mode'; if not, erase any leftover data + (if (not undo-in-region) + (undo-tree-node-clear-region-data current) + (goto-char pos) + ;; note: we deliberately want to store the region information in the + ;; node *below* the now current one + (setf (undo-tree-node-undo-beginning current) (region-beginning) + (undo-tree-node-undo-end current) (region-end)) + (set-marker pos nil))) + + ;; undo deactivates mark unless undoing-in-region + (setq deactivate-mark (not undo-in-region)) + ;; inform user if at branch point + (when (> (undo-tree-num-branches) 1) (message "Undo branch point!")))) + + + +(defun undo-tree-redo (&optional arg preserve-undo) + "Redo changes. A numeric ARG serves as a repeat count. + +In Transient Mark mode when the mark is active, only redo changes +within the current region. Similarly, when not in Transient Mark +mode, just \\[universal-argument] as an argument limits redo to +changes within the current region. + +A non-nil PRESERVE-UNDO causes the existing undo record to be +preserved, rather than replacing it with the new one generated by +redoing." + (interactive "p") + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) (error "No undo information in this buffer")) + + (let ((undo-in-progress t) + (redo-in-region (or (region-active-p) (and arg (not (numberp arg))))) + pos current) + ;; transfer entries accumulated in `buffer-undo-list' to + ;; `buffer-undo-tree' + (undo-list-transfer-to-tree) + + (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1)) + ;; check if at bottom of undo tree + (when (null (undo-tree-node-next (undo-tree-current buffer-undo-tree))) + (error "No further redo information")) + + ;; if region is active, or a non-numeric prefix argument was supplied, + ;; try to pull out a new branch of changes affecting the region + (when (and redo-in-region + (not (undo-tree-pull-redo-in-region-branch + (region-beginning) (region-end)))) + (error "No further redo information for region")) + + ;; advance current node + (setq current (undo-tree-current buffer-undo-tree) + current (setf (undo-tree-current buffer-undo-tree) + (nth (undo-tree-node-branch current) + (undo-tree-node-next current)))) + ;; remove any GC'd elements from node's redo list + (decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + (setf (undo-tree-node-redo current) + (undo-list-clean-GCd-elts (undo-tree-node-redo current))) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + ;; redo one record from undo tree + (when redo-in-region + (setq pos (set-marker (make-marker) (point))) + (set-marker-insertion-type pos t)) + (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-redo current))) + (undo-boundary) + + ;; if preserving old undo record, discard new undo entries that + ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd + ;; elements from node's redo list + (if preserve-undo + (progn + (undo-list-pop-changeset) + (decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + (setf (undo-tree-node-undo current) + (undo-list-clean-GCd-elts (undo-tree-node-undo current))) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current)))) + ;; otherwise, record undo entries that `primitive-undo' has added to + ;; `buffer-undo-list' in current node's undo record, replacing + ;; existing entry if one already exists + (when (undo-tree-node-undo current) + (decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current)))) + (setf (undo-tree-node-undo current) (undo-list-pop-changeset)) + (incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current)))) + + ;; update timestamp + (setf (undo-tree-node-timestamp current) (current-time)) + + ;; if redoing-in-region, record current node, region and direction so we + ;; can tell if redo-in-region is repeated, and re-activate mark if in + ;; `transient-mark-mode' + (if (not redo-in-region) + (undo-tree-node-clear-region-data current) + (goto-char pos) + (setf (undo-tree-node-redo-beginning current) (region-beginning) + (undo-tree-node-redo-end current) (region-end)) + (set-marker pos nil))) + + ;; redo deactivates the mark unless redoing-in-region + (setq deactivate-mark (not redo-in-region)) + ;; inform user if at branch point + (when (> (undo-tree-num-branches) 1) (message "Undo branch point!")))) + + + +(defun undo-tree-switch-branch (branch) + "Switch to a different BRANCH of the undo tree. +This will affect which branch to descend when *redoing* changes +using `undo-tree-redo'." + (interactive (list (or (and prefix-arg (prefix-numeric-value prefix-arg)) + (and (not (eq buffer-undo-list t)) + (or (undo-list-transfer-to-tree) t) + (> (undo-tree-num-branches) 1) + (read-number + (format "Branch (0-%d): " + (1- (undo-tree-num-branches)))))))) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) (error "No undo information in this buffer")) + ;; sanity check branch number + (when (<= (undo-tree-num-branches) 1) (error "Not at undo branch point")) + (when (or (< branch 0) (> branch (1- (undo-tree-num-branches)))) + (error "Invalid branch number")) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; switch branch + (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) + branch)) + + +(defun undo-tree-set (node) + ;; Set buffer to state corresponding to NODE. Returns intersection point + ;; between path back from current node and path back from selected NODE. + (let ((path (make-hash-table :test 'eq)) + (n node)) + (puthash (undo-tree-root buffer-undo-tree) t path) + ;; build list of nodes leading back from selected node to root, updating + ;; branches as we go to point down to selected node + (while (progn + (puthash n t path) + (when (undo-tree-node-previous n) + (setf (undo-tree-node-branch (undo-tree-node-previous n)) + (undo-tree-position + n (undo-tree-node-next (undo-tree-node-previous n)))) + (setq n (undo-tree-node-previous n))))) + ;; work backwards from current node until we intersect path back from + ;; selected node + (setq n (undo-tree-current buffer-undo-tree)) + (while (not (gethash n path)) + (setq n (undo-tree-node-previous n))) + ;; ascend tree until intersection node + (while (not (eq (undo-tree-current buffer-undo-tree) n)) + (undo-tree-undo)) + ;; descend tree until selected node + (while (not (eq (undo-tree-current buffer-undo-tree) node)) + (undo-tree-redo)) + n)) ; return intersection node + + + +(defun undo-tree-save-state-to-register (register) + "Store current undo-tree state to REGISTER. +The saved state can be restored using +`undo-tree-restore-state-from-register'. +Argument is a character, naming the register." + (interactive "cUndo-tree state to register: ") + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) (error "No undo information in this buffer")) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; save current node to REGISTER + (set-register register (undo-tree-current buffer-undo-tree)) + ;; record REGISTER in current node, for visualizer + (setf (undo-tree-node-register (undo-tree-current buffer-undo-tree)) + register)) + + + +(defun undo-tree-restore-state-from-register (register) + "Restore undo-tree state from REGISTER. +The state must be saved using `undo-tree-save-state-to-register'. +Argument is a character, naming the register." + (interactive "cRestore undo-tree state from register: ") + ;; throw error if undo is disabled in buffer, or if register doesn't contain + ;; an undo-tree node + (let ((node (get-register register))) + (cond + ((eq buffer-undo-list t) + (error "No undo information in this buffer")) + ((not (undo-tree-node-p node)) + (error "Register doesn't contain undo-tree state"))) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; restore buffer state corresponding to saved node + (undo-tree-set node))) + + + + +;;; ===================================================================== +;;; Undo-tree visualizer + +(defun undo-tree-visualize () + "Visualize the current buffer's undo tree." + (interactive) + (deactivate-mark) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) (error "No undo information in this buffer")) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; add hook to kill visualizer buffer if original buffer is changed + (add-hook 'before-change-functions 'undo-tree-kill-visualizer nil t) + ;; prepare *undo-tree* buffer, then draw tree in it + (let ((undo-tree buffer-undo-tree) + (buff (current-buffer)) + (display-buffer-mark-dedicated 'soft)) + (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) + (undo-tree-visualizer-mode) + (setq undo-tree-visualizer-parent-buffer buff) + (setq buffer-undo-tree undo-tree) + (setq buffer-read-only nil) + (undo-tree-draw-tree undo-tree) + (setq buffer-read-only t))) + + +(defun undo-tree-kill-visualizer (&rest dummy) + ;; Kill visualizer. Added to `before-change-functions' hook of original + ;; buffer when visualizer is invoked. + (unless undo-in-progress + (unwind-protect + (with-current-buffer undo-tree-visualizer-buffer-name + (undo-tree-visualizer-quit))))) + + + +(defun undo-tree-draw-tree (undo-tree) + ;; Draw UNDO-TREE in current buffer. + (erase-buffer) + (undo-tree-move-down 1) ; top margin + (undo-tree-clear-visualizer-data undo-tree) + (undo-tree-compute-widths undo-tree) + (undo-tree-move-forward + (max (/ (window-width) 2) + (+ (undo-tree-node-char-lwidth (undo-tree-root undo-tree)) + ;; add space for left part of left-most time-stamp + (if undo-tree-visualizer-timestamps 4 0) + 2))) ; left margin + ;; draw undo-tree + (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face) + (stack (list (undo-tree-root undo-tree))) + (n (undo-tree-root undo-tree))) + ;; link root node to its representation in visualizer + (unless (markerp (undo-tree-node-marker n)) + (setf (undo-tree-node-marker n) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker n) nil)) + (move-marker (undo-tree-node-marker n) (point)) + ;; draw nodes from stack until stack is empty + (while stack + (setq n (pop stack)) + (goto-char (undo-tree-node-marker n)) + (setq n (undo-tree-draw-subtree n nil)) + (setq stack (append stack n)))) + ;; highlight active branch + (goto-char (undo-tree-node-marker (undo-tree-root undo-tree))) + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch (undo-tree-root undo-tree))) + ;; highlight current node + (undo-tree-draw-node (undo-tree-current undo-tree) 'current)) + + +(defun undo-tree-highlight-active-branch (node) + ;; Draw highlighted active branch below NODE in current buffer. + (let ((stack (list node))) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker node)) + (setf (undo-tree-node-marker node) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker node) nil)) + (move-marker (undo-tree-node-marker node) (point)) + ;; draw active branch + (while stack + (setq node (pop stack)) + (goto-char (undo-tree-node-marker node)) + (setq node (undo-tree-draw-subtree node 'active)) + (setq stack (append stack node))))) + + +(defun undo-tree-draw-node (node &optional current) + ;; Draw symbol representing NODE in visualizer. + (goto-char (undo-tree-node-marker node)) + ;; if displaying timestamps, represent node by timestamp + (if undo-tree-visualizer-timestamps + (progn + (backward-char 4) + (if current (undo-tree-insert ?*) (undo-tree-insert ? )) + (undo-tree-insert + (undo-tree-timestamp-to-string (undo-tree-node-timestamp node))) + (backward-char 5) + (move-marker (undo-tree-node-marker node) (point)) + (put-text-property (- (point) 3) (+ (point) 5) + 'undo-tree-node node)) + ;; represent node by differentl symbols, depending on whether it's the + ;; current node or is saved in a register + (let ((register (undo-tree-node-register node))) + (cond + (current + (let ((undo-tree-insert-face + (cons 'undo-tree-visualizer-current-face + (and (boundp 'undo-tree-insert-face) + (or (and (consp undo-tree-insert-face) + undo-tree-insert-face) + (list undo-tree-insert-face)))))) + (undo-tree-insert ?x))) + ((and register (eq node (get-register register))) + (let ((undo-tree-insert-face + (cons 'undo-tree-visualizer-register-face + (and (boundp 'undo-tree-insert-face) + (or (and (consp undo-tree-insert-face) + undo-tree-insert-face) + (list undo-tree-insert-face)))))) + (undo-tree-insert register))) + (t (undo-tree-insert ?o)))) + (backward-char 1) + (put-text-property (point) (1+ (point)) 'undo-tree-node node))) + + +(defun undo-tree-draw-subtree (node &optional active-branch) + ;; Draw subtree rooted at NODE. The subtree will start from point. + ;; If ACTIVE-BRANCH is non-nil, just draw active branch below NODE. + ;; If TIMESTAP is non-nil, draw time-stamps instead of "o" at nodes. + (let ((num-children (length (undo-tree-node-next node))) + node-list pos trunk-pos n) + ;; draw node itself + (undo-tree-draw-node node) + + (cond + ;; if we're at a leaf node, we're done + ((= num-children 0)) + + ;; if node has only one child, draw it (not strictly necessary to deal + ;; with this case separately, but as it's by far the most common case + ;; this makes the code clearer and more efficient) + ((= num-children 1) + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (backward-char 1) + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (backward-char 1) + (undo-tree-move-down 1) + (setq n (car (undo-tree-node-next node))) + ;; link next node to its representation in visualizer + (unless (markerp (undo-tree-node-marker n)) + (setf (undo-tree-node-marker n) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker n) nil)) + (move-marker (undo-tree-node-marker n) (point)) + ;; add next node to list of nodes to draw next + (push n node-list)) + + ;; if node had multiple children, draw branches + (t + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (backward-char 1) + (setq trunk-pos (point)) + ;; left subtrees + (backward-char + (- (undo-tree-node-char-lwidth node) + (undo-tree-node-char-lwidth + (car (undo-tree-node-next node))))) + (setq pos (point)) + (setq n (cons nil (undo-tree-node-next node))) + (dotimes (i (/ num-children 2)) + (setq n (cdr n)) + (when (or (null active-branch) + (eq (car n) + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (undo-tree-move-forward 2) + (undo-tree-insert ?_ (- trunk-pos pos 2)) + (goto-char pos) + (undo-tree-move-forward 1) + (undo-tree-move-down 1) + (undo-tree-insert ?/) + (backward-char 2) + (undo-tree-move-down 1) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker (car n))) + (setf (undo-tree-node-marker (car n)) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) + (move-marker (undo-tree-node-marker (car n)) (point)) + ;; add node to list of nodes to draw next + (push (car n) node-list)) + (goto-char pos) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (undo-tree-node-char-lwidth (cadr n)) + undo-tree-visualizer-spacing 1)) + (setq pos (point))) + ;; middle subtree (only when number of children is odd) + (when (= (mod num-children 2) 1) + (setq n (cdr n)) + (when (or (null active-branch) + (eq (car n) + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (backward-char 1) + (undo-tree-move-down 1) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker (car n))) + (setf (undo-tree-node-marker (car n)) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) + (move-marker (undo-tree-node-marker (car n)) (point)) + ;; add node to list of nodes to draw next + (push (car n) node-list)) + (goto-char pos) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0) + undo-tree-visualizer-spacing 1)) + (setq pos (point))) + ;; right subtrees + (incf trunk-pos) + (dotimes (i (/ num-children 2)) + (setq n (cdr n)) + (when (or (null active-branch) + (eq (car n) + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (goto-char trunk-pos) + (undo-tree-insert ?_ (- pos trunk-pos 1)) + (goto-char pos) + (backward-char 1) + (undo-tree-move-down 1) + (undo-tree-insert ?\\) + (undo-tree-move-down 1) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker (car n))) + (setf (undo-tree-node-marker (car n)) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) + (move-marker (undo-tree-node-marker (car n)) (point)) + ;; add node to list of nodes to draw next + (push (car n) node-list)) + (when (cdr n) + (goto-char pos) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0) + undo-tree-visualizer-spacing 1)) + (setq pos (point)))) + )) + ;; return list of nodes to draw next + (nreverse node-list))) + + + +(defun undo-tree-node-char-lwidth (node) + ;; Return left-width of NODE measured in characters. + (if (= (length (undo-tree-node-next node)) 0) 0 + (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-lwidth node)) + (if (= (undo-tree-node-cwidth node) 0) + (1+ (/ undo-tree-visualizer-spacing 2)) 0)))) + + +(defun undo-tree-node-char-rwidth (node) + ;; Return right-width of NODE measured in characters. + (if (= (length (undo-tree-node-next node)) 0) 0 + (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-rwidth node)) + (if (= (undo-tree-node-cwidth node) 0) + (1+ (/ undo-tree-visualizer-spacing 2)) 0)))) + + +(defun undo-tree-insert (str &optional arg) + ;; Insert character or string STR ARG times, overwriting, and using + ;; `undo-tree-insert-face'. + (unless arg (setq arg 1)) + (when (characterp str) + (setq str (make-string arg str)) + (setq arg 1)) + (dotimes (i arg) (insert str)) + (setq arg (* arg (length str))) + (undo-tree-move-forward arg) + ;; make sure mark isn't active, otherwise `backward-delete-char' might + ;; delete region instead of single char if transient-mark-mode is enabled + (setq mark-active nil) + (backward-delete-char arg) + (when (boundp 'undo-tree-insert-face) + (put-text-property (- (point) arg) (point) 'face undo-tree-insert-face))) + + +(defun undo-tree-move-down (&optional arg) + ;; Move down, extending buffer if necessary. + (let ((row (line-number-at-pos)) + (col (current-column)) + line) + (unless arg (setq arg 1)) + (forward-line arg) + (setq line (line-number-at-pos)) + ;; if buffer doesn't have enough lines, add some + (when (/= line (+ row arg)) + (insert (make-string (- arg (- line row)) ?\n))) + (undo-tree-move-forward col))) + + +(defun undo-tree-move-forward (&optional arg) + ;; Move forward, extending buffer if necessary. + (unless arg (setq arg 1)) + (let ((n (- (line-end-position) (point)))) + (if (> n arg) + (forward-char arg) + (end-of-line) + (insert (make-string (- arg n) ? ))))) + + +(defun undo-tree-timestamp-to-string (timestamp) + ;; Convert TIMESTAMP to hh:mm:ss string. + (let ((time (decode-time timestamp))) + (format "%02d:%02d:%02d" (nth 2 time) (nth 1 time) (nth 0 time)))) + + + + +;;; ===================================================================== +;;; Visualizer mode commands + +(defun undo-tree-visualizer-mode () + "Major mode used in undo-tree visualizer. + +The undo-tree visualizer can only be invoked from a buffer in +which `undo-tree-mode' is enabled. The visualizer displays the +undo history tree graphically, and allows you to browse around +the undo history, undoing or redoing the corresponding changes in +the parent buffer. + +Within the undo-tree visualizer, the following keys are available: + + \\{undo-tree-visualizer-map}" + (interactive) + (setq major-mode 'undo-tree-visualizer-mode) + (setq mode-name "undo-tree-visualizer-mode") + (use-local-map undo-tree-visualizer-map) + (setq truncate-lines t) + (setq cursor-type nil) + (setq buffer-read-only t)) + + + +(defun undo-tree-visualize-undo (&optional arg) + "Undo changes. A numeric ARG serves as a repeat count." + (interactive "p") + (setq buffer-read-only nil) + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) + (undo-tree-draw-node (undo-tree-current buffer-undo-tree))) + (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) + (deactivate-mark) + (unwind-protect + (undo-tree-undo arg) + (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) + (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current) + (setq buffer-read-only t))) + + +(defun undo-tree-visualize-redo (&optional arg) + "Redo changes. A numeric ARG serves as a repeat count." + (interactive "p") + (setq buffer-read-only nil) + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) + (undo-tree-draw-node (undo-tree-current buffer-undo-tree))) + (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) + (deactivate-mark) + (unwind-protect + (undo-tree-redo arg) + (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) + (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) + (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current) + (setq buffer-read-only t))) + + +(defun undo-tree-visualize-switch-branch-right (arg) + "Switch to next branch of the undo tree. +This will affect which branch to descend when *redoing* changes +using `undo-tree-redo' or `undo-tree-visualizer-redo'." + (interactive "p") + ;; un-highlight old active branch below current node + (setq buffer-read-only nil) + (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) + (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face)) + (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree))) + ;; increment branch + (let ((branch (undo-tree-node-branch (undo-tree-current buffer-undo-tree)))) + (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) + (cond + ((>= (+ branch arg) (undo-tree-num-branches)) + (1- (undo-tree-num-branches))) + ((<= (+ branch arg) 0) 0) + (t (+ branch arg)))) + ;; highlight new active branch below current node + (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree))) + ;; re-highlight current node + (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current) + (setq buffer-read-only t))) + + +(defun undo-tree-visualize-switch-branch-left (arg) + "Switch to previous branch of the undo tree. +This will affect which branch to descend when *redoing* changes +using `undo-tree-redo' or `undo-tree-visualizer-redo'." + (interactive "p") + (undo-tree-visualize-switch-branch-right (- arg))) + + +(defun undo-tree-visualizer-quit () + "Quit the undo-tree visualizer." + (interactive) + (undo-tree-clear-visualizer-data buffer-undo-tree) + ;; remove kill visualizer hook from parent buffer + (unwind-protect + (with-current-buffer undo-tree-visualizer-parent-buffer + (remove-hook 'before-change-functions 'undo-tree-kill-visualizer t)) + (let ((parent undo-tree-visualizer-parent-buffer) + window) + (kill-buffer nil) + (if (setq window (get-buffer-window parent)) + (select-window window) + (switch-to-buffer parent))))) + + +(defun undo-tree-visualizer-set (&optional pos) + "Set buffer to state corresponding to undo tree node +at POS, or point if POS is nil." + (interactive) + (unless pos (setq pos (point))) + (let ((node (get-text-property pos 'undo-tree-node))) + (when node + ;; set parent buffer to state corresponding to node at POS + (set-buffer undo-tree-visualizer-parent-buffer) + (undo-tree-set node) + (set-buffer undo-tree-visualizer-buffer-name) + (setq buffer-read-only nil) + ;; re-draw undo tree + (undo-tree-draw-tree buffer-undo-tree) + (setq buffer-read-only t)))) + + +(defun undo-tree-visualizer-mouse-set (pos) + "Set buffer to state corresponding to undo tree node +at mouse event POS." + (interactive "@e") + (undo-tree-visualizer-set (event-start (nth 1 pos)))) + + +(defun undo-tree-visualizer-toggle-timestamps () + "Toggle display of time-stamps." + (interactive) + (setq undo-tree-visualizer-spacing + (if (setq undo-tree-visualizer-timestamps + (not undo-tree-visualizer-timestamps)) + ;; need sufficient space if TIMESTAMP is set + (max 9 (default-value 'undo-tree-visualizer-spacing)) + (default-value 'undo-tree-visualizer-spacing))) + ;; redraw tree + (setq buffer-read-only nil) + (undo-tree-draw-tree buffer-undo-tree) + (setq buffer-read-only t)) + + +(defun undo-tree-visualizer-scroll-left (&optional arg) + (interactive "p") + (scroll-right (or arg 1) t)) + + +(defun undo-tree-visualizer-scroll-right (&optional arg) + (interactive "p") + (scroll-left (or arg 1) t)) + + + + +;;; ===================================================================== +;;; Visualizer selection mode + +(defun undo-tree-visualizer-selection-mode () + "Major mode used to select nodes in undo-tree visualizer." + (interactive) + (setq major-mode 'undo-tree-visualizer-selection-mode) + (setq mode-name "undo-tree-visualizer-selection-mode") + (use-local-map undo-tree-visualizer-selection-map) + (setq cursor-type 'box)) + + +(defun undo-tree-visualizer-select-previous (&optional arg) + "Move to previous node." + (interactive "p") + (let ((node (get-text-property (point) 'undo-tree-node))) + (catch 'top + (dotimes (i arg) + (unless (undo-tree-node-previous node) (throw 'top t)) + (setq node (undo-tree-node-previous node)))) + (goto-char (undo-tree-node-marker node)))) + + +(defun undo-tree-visualizer-select-next (&optional arg) + "Move to next node." + (interactive "p") + (let ((node (get-text-property (point) 'undo-tree-node))) + (catch 'bottom + (dotimes (i arg) + (unless (nth (undo-tree-node-branch node) (undo-tree-node-next node)) + (throw 'bottom t)) + (setq node + (nth (undo-tree-node-branch node) (undo-tree-node-next node))))) + (goto-char (undo-tree-node-marker node)))) + + +(defun undo-tree-visualizer-select-right (&optional arg) + "Move right to a sibling node." + (interactive "p") + (let ((pos (point)) + (end (line-end-position)) + node) + (catch 'end + (dotimes (i arg) + (while (not node) + (forward-char) + (setq node (get-text-property (point) 'undo-tree-node)) + (when (= (point) end) (throw 'end t))))) + (goto-char (if node (undo-tree-node-marker node) pos)))) + + +(defun undo-tree-visualizer-select-left (&optional arg) + "Move left to a sibling node." + (interactive "p") + (let ((pos (point)) + (beg (line-beginning-position)) + node) + (catch 'beg + (dotimes (i arg) + (while (not node) + (backward-char) + (setq node (get-text-property (point) 'undo-tree-node)) + (when (= (point) beg) (throw 'beg t))))) + (goto-char (if node (undo-tree-node-marker node) pos)))) + + + +(provide 'undo-tree) + +;;; undo-tree.el ends here diff --git a/undo-tree.el b/undo-tree.el deleted file mode 100644 index 4edfa9d..0000000 --- a/undo-tree.el +++ /dev/null @@ -1,3075 +0,0 @@ - -;;; undo-tree.el --- Treat undo history as a tree - - -;; Copyright (C) 2009-2011 Toby Cubitt - -;; Author: Toby Cubitt -;; Version: 0.3 -;; Keywords: undo, redo, history, tree -;; URL: http://www.dr-qubit.org/emacs.php -;; Git Repository: http://www.dr-qubit.org/git/undo-tree.git - -;; This file is NOT part of Emacs. -;; -;; 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 3 of the License, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. -;; -;; You should have received a copy of the GNU General Public License along -;; with GNU Emacs. If not, see . - - -;;; Commentary: -;; -;; Emacs has a powerful undo system. Unlike the standard undo/redo system in -;; most software, it allows you to recover *any* past state of a buffer -;; (whereas the standard undo/redo system can lose past states as soon as you -;; redo). However, this power comes at a price: many people find Emacs' undo -;; system confusing and difficult to use, spawning a number of packages that -;; replace it with the less powerful but more intuitive undo/redo system. -;; -;; Both the loss of data with standard undo/redo, and the confusion of Emacs' -;; undo, stem from trying to treat undo history as a linear sequence of -;; changes. It's not. The `undo-tree-mode' provided by this package replaces -;; Emacs' undo system with a system that treats undo history as what it is: a -;; branching tree of changes. This simple idea allows the more intuitive -;; behaviour of the standard undo/redo system to be combined with the power of -;; never losing any history. An added side bonus is that undo history can in -;; some cases be stored more efficiently, allowing more changes to accumulate -;; before Emacs starts discarding history. -;; -;; The only downside to this more advanced yet simpler undo system is that it -;; was inspired by Vim. But, after all, most successful religions steal the -;; best ideas from their competitors! -;; -;; -;; Installation -;; ============ -;; -;; This package has only been tested with Emacs versions 22, 23 and CVS. It -;; will not work without modifications in earlier versions of Emacs. -;; -;; To install `undo-tree-mode', make sure this file is saved in a directory in -;; your `load-path', and add the line: -;; -;; (require 'undo-tree) -;; -;; to your .emacs file. Byte-compiling undo-tree.el is recommended (e.g. using -;; "M-x byte-compile-file" from within emacs). -;; -;; If you want to replace the standard Emacs' undo system with the -;; `undo-tree-mode' system in all buffers, you can enable it globally by -;; adding: -;; -;; (global-undo-tree-mode) -;; -;; to your .emacs file. -;; -;; -;; Quick-Start -;; =========== -;; -;; If you're the kind of person who likes jump in the car and drive, without -;; bothering to first figure out whether the button on the left dips the -;; headlights or operates the ejector seat (after all, you'll soon figure it -;; out when you push it), then here's the minimum you need to know: -;; -;; `undo-tree-mode' and `global-undo-tree-mode' -;; Enable undo-tree mode (either in the current buffer or globally). -;; -;; C-_ C-/ (`undo-tree-undo') -;; Undo changes. -;; -;; M-_ C-? (`undo-tree-redo') -;; Redo changes. -;; -;; `undo-tree-switch-branch' -;; Switch undo-tree branch. -;; (What does this mean? Better press the button and see!) -;; -;; C-x u (`undo-tree-visualize') -;; Visualize the undo tree. -;; (Better try pressing this button too!) -;; -;; C-x r u (`undo-tree-save-state-to-register') -;; Save current buffer state to register. -;; -;; C-x r U (`undo-tree-restore-state-from-register') -;; Restore buffer state from register. -;; -;; -;; In the undo-tree visualizer: -;; -;; p C-p (`undo-tree-visualize-undo') -;; Undo changes. -;; -;; n C-n (`undo-tree-visualize-redo') -;; Redo changes. -;; -;; b C-b (`undo-tree-visualize-switch-branch-left') -;; Switch to previous undo-tree branch. -;; -;; f C-f (`undo-tree-visualize-switch-branch-right') -;; Switch to next undo-tree branch. -;; -;; t (`undo-tree-visualizer-toggle-timestamps') -;; Toggle display of time-stamps. -;; -;; q C-q (`undo-tree-visualizer-quit') -;; Quit undo-tree-visualizer. -;; -;; , < -;; Scroll left. -;; -;; . > -;; Scroll right. -;; -;; -;; Scroll up. -;; -;; -;; Scroll down. -;; -;; -;; -;; Undo Systems -;; ============ -;; -;; To understand the different undo systems, it's easiest to consider an -;; example. Imagine you make a few edits in a buffer. As you edit, you -;; accumulate a history of changes, which we might visualize as a string of -;; past buffer states, growing downwards: -;; -;; o (initial buffer state) -;; | -;; | -;; o (first edit) -;; | -;; | -;; o (second edit) -;; | -;; | -;; x (current buffer state) -;; -;; -;; Now imagine that you undo the last two changes. We can visualize this as -;; rewinding the current state back two steps: -;; -;; o (initial buffer state) -;; | -;; | -;; x (current buffer state) -;; | -;; | -;; o -;; | -;; | -;; o -;; -;; -;; However, this isn't a good representation of what Emacs' undo system -;; does. Instead, it treats the undos as *new* changes to the buffer, and adds -;; them to the history: -;; -;; o (initial buffer state) -;; | -;; | -;; o (first edit) -;; | -;; | -;; o (second edit) -;; | -;; | -;; x (buffer state before undo) -;; | -;; | -;; o (first undo) -;; | -;; | -;; x (second undo) -;; -;; -;; Actually, since the buffer returns to a previous state after an undo, -;; perhaps a better way to visualize it is to imagine the string of changes -;; turning back on itself: -;; -;; (initial buffer state) o -;; | -;; | -;; (first edit) o x (second undo) -;; | | -;; | | -;; (second edit) o o (first undo) -;; | / -;; |/ -;; o (buffer state before undo) -;; -;; Treating undos as new changes might seem a strange thing to do. But the -;; advantage becomes clear as soon as we imagine what happens when you edit -;; the buffer again. Since you've undone a couple of changes, new edits will -;; branch off from the buffer state that you've rewound to. Conceptually, it -;; looks like this: -;; -;; o (initial buffer state) -;; | -;; | -;; o -;; |\ -;; | \ -;; o x (new edit) -;; | -;; | -;; o -;; -;; The standard undo/redo system only lets you go backwards and forwards -;; linearly. So as soon as you make that new edit, it discards the old -;; branch. Emacs' undo just keeps adding changes to the end of the string. So -;; the undo history in the two systems now looks like this: -;; -;; Undo/Redo: Emacs' undo -;; -;; o o -;; | | -;; | | -;; o o o -;; .\ | |\ -;; . \ | | \ -;; . x (new edit) o o | -;; (discarded . | / | -;; branch) . |/ | -;; . o | -;; | -;; | -;; x (new edit) -;; -;; Now, what if you change your mind about those undos, and decide you did -;; like those other changes you'd made after all? With the standard undo/redo -;; system, you're lost. There's no way to recover them, because that branch -;; was discarded when you made the new edit. -;; -;; However, in Emacs' undo system, those old buffer states are still there in -;; the undo history. You just have to rewind back through the new edit, and -;; back through the changes made by the undos, until you reach them. Of -;; course, since Emacs treats undos (even undos of undos!) as new changes, -;; you're really weaving backwards and forwards through the history, all the -;; time adding new changes to the end of the string as you go: -;; -;; o -;; | -;; | -;; o o o (undo new edit) -;; | |\ |\ -;; | | \ | \ -;; o o | | o (undo the undo) -;; | / | | | -;; |/ | | | -;; (trying to get o | | x (undo the undo) -;; to this state) | / -;; |/ -;; o -;; -;; So far, this is still reasonably intuitive to use. It doesn't behave so -;; differently to standard undo/redo, except that by going back far enough you -;; can access changes that would be lost in standard undo/redo. -;; -;; However, imagine that after undoing as just described, you decide you -;; actually want to rewind right back to the initial state. If you're lucky, -;; and haven't invoked any command since the last undo, you can just keep on -;; undoing until you get back to the start: -;; -;; (trying to get o x (got there!) -;; to this state) | | -;; | | -;; o o o o (keep undoing) -;; | |\ |\ | -;; | | \ | \ | -;; o o | | o o (keep undoing) -;; | / | | | / -;; |/ | | |/ -;; (already undid o | | o (got this far) -;; to this state) | / -;; |/ -;; o -;; -;; But if you're unlucky, and you happen to have moved the point (say) after -;; getting to the state labelled "got this far", then you've "broken the undo -;; chain". Hold on to something solid, because things are about to get -;; hairy. If you try to undo now, Emacs thinks you're trying to undo the -;; undos! So to get back to the initial state you now have to rewind through -;; *all* the changes, including the undos you just did: -;; -;; (trying to get o x (finally got there!) -;; to this state) | | -;; | | -;; o o o o o o -;; | |\ |\ |\ |\ | -;; | | \ | \ | \ | \ | -;; o o | | o o o | o o -;; | / | | | / | | | / -;; |/ | | |/ | | |/ -;; (already undid o | | o<. | | o -;; to this state) | / : | / -;; |/ : |/ -;; o : o -;; : -;; (got this far, but -;; broke the undo chain) -;; -;; Confused? -;; -;; In practice you can just hold down the undo key until you reach the buffer -;; state that you want. But whatever you do, don't move around in the buffer -;; to *check* that you've got back to where you want! Because you'll break the -;; undo chain, and then you'll have to traverse the entire string of undos -;; again, just to get back to the point at which you broke the -;; chain. Undo-in-region and commands such as `undo-only' help to make using -;; Emacs' undo a little easier, but nonetheless it remains confusing for many -;; people. -;; -;; -;; So what does `undo-tree-mode' do? Remember the diagram we drew to represent -;; the history we've been discussing (make a few edits, undo a couple of them, -;; and edit again)? The diagram that conceptually represented our undo -;; history, before we started discussing specific undo systems? It looked like -;; this: -;; -;; o (initial buffer state) -;; | -;; | -;; o -;; |\ -;; | \ -;; o x (current state) -;; | -;; | -;; o -;; -;; Well, that's *exactly* what the undo history looks like to -;; `undo-tree-mode'. It doesn't discard the old branch (as standard undo/redo -;; does), nor does it treat undos as new changes to be added to the end of a -;; linear string of buffer states (as Emacs' undo does). It just keeps track -;; of the tree of branching changes that make up the entire undo history. -;; -;; If you undo from this point, you'll rewind back up the tree to the previous -;; state: -;; -;; o -;; | -;; | -;; x (undo) -;; |\ -;; | \ -;; o o -;; | -;; | -;; o -;; -;; If you were to undo again, you'd rewind back to the initial state. If on -;; the other hand you redo the change, you'll end up back at the bottom of the -;; most recent branch: -;; -;; o (undo takes you here) -;; | -;; | -;; o (start here) -;; |\ -;; | \ -;; o x (redo takes you here) -;; | -;; | -;; o -;; -;; So far, this is just like the standard undo/redo system. But what if you -;; want to return to a buffer state located on a previous branch of the -;; history? Since `undo-tree-mode' keeps the entire history, you simply need -;; to tell it to switch to a different branch, and then redo the changes you -;; want: -;; -;; o -;; | -;; | -;; o (start here, but switch -;; |\ to the other branch) -;; | \ -;; (redo) o o -;; | -;; | -;; (redo) x -;; -;; Now you're on the other branch, if you undo and redo changes you'll stay on -;; that branch, moving up and down through the buffer states located on that -;; branch. Until you decide to switch branches again, of course. -;; -;; Real undo trees might have multiple branches and sub-branches: -;; -;; o -;; ____|______ -;; / \ -;; o o -;; ____|__ __| -;; / | \ / \ -;; o o o o x -;; | | -;; / \ / \ -;; o o o o -;; -;; Trying to imagine what Emacs' undo would do as you move about such a tree -;; will likely frazzle your brain circuits! But in `undo-tree-mode', you're -;; just moving around this undo history tree. Most of the time, you'll -;; probably only need to stay on the most recent branch, in which case it -;; behaves like standard undo/redo, and is just as simple to understand. But -;; if you ever need to recover a buffer state on a different branch, the -;; possibility of switching between branches and accessing the full undo -;; history is still there. -;; -;; -;; -;; The Undo-Tree Visualizer -;; ======================== -;; -;; Actually, it gets better. You don't have to imagine all these tree -;; diagrams, because `undo-tree-mode' includes an undo-tree visualizer which -;; draws them for you! In fact, it draws even better diagrams: it highlights -;; the node representing the current buffer state, it highlights the current -;; branch, and (by hitting "t") you can toggle the display of -;; time-stamps. (There's one other tiny difference: the visualizer puts the -;; most recent branch on the left rather than the right.) -;; -;; In the visualizer, the usual keys for moving up and down a buffer instead -;; move up and down the undo history tree (e.g. the up and down arrow keys, or -;; "C-n" and "C-p"). The state of the "parent" buffer (the buffer whose undo -;; history you are visualizing) is updated as you move around the undo tree in -;; the visualizer. If you reach a branch point in the visualizer, the usual -;; keys for moving forward and backward in a buffer instead switch branch -;; (e.g. the left and right arrow keys, or "C-f" and "C-b"). And clicking with -;; the mouse on any node in the visualizer will take you directly to that -;; node, resetting the state of the parent buffer to the state represented by -;; that node. -;; -;; It can be useful to see how long ago the parent buffer was in the state -;; represented by a particular node in the visualizer. Hitting "t" in the -;; visualizer toggles the display of time-stamps for all the nodes. (Note -;; that, because of the way `undo-tree-mode' works, these time-stamps may be -;; somewhat later than the true times, especially if it's been a long time -;; since you last undid any changes.) -;; -;; Finally, hitting "q" will quit the visualizer, leaving the parent buffer in -;; whatever state you ended at. -;; -;; -;; -;; Undo-in-Region -;; ============== -;; -;; Emacs allows a very useful and powerful method of undoing only selected -;; changes: when a region is active, only changes that affect the text within -;; that region will are undone. With the standard Emacs undo system, changes -;; produced by undoing-in-region naturally get added onto the end of the -;; linear undo history: -;; -;; o -;; | -;; | x (second undo-in-region) -;; o | -;; | | -;; | o (first undo-in-region) -;; o | -;; | / -;; |/ -;; o -;; -;; You can of course redo these undos-in-region as usual, by undoing the -;; undos: -;; -;; o -;; | -;; | o_ -;; o | \ -;; | | | -;; | o o (undo the undo-in-region) -;; o | | -;; | / | -;; |/ | -;; o x (undo the undo-in-region) -;; -;; -;; In `undo-tree-mode', undo-in-region works similarly: when there's an active -;; region, undoing only undoes changes that affect that region. However, the -;; way these undos-in-region are recorded in the undo history is quite -;; different. In `undo-tree-mode', undo-in-region creates a new branch in the -;; undo history. The new branch consists of an undo step that undoes some of -;; the changes that affect the current region, and another step that undoes -;; the remaining changes needed to rejoin the previous undo history. -;; -;; Previous undo history Undo-in-region -;; -;; o o -;; | | -;; | | -;; o o -;; | |\ -;; | | \ -;; o o x (undo-in-region) -;; | | | -;; | | | -;; x o o -;; -;; As long as you don't change the active region after undoing-in-region, -;; continuing to undo-in-region extends the new branch, pulling more changes -;; that affect the current region into an undo step immediately above your -;; current location in the undo tree, and pushing the point at which the new -;; branch is attached further up the tree: -;; -;; First undo-in-region Second undo-in-region -;; -;; o o -;; | |\ -;; | | \ -;; o o x (undo-in-region) -;; |\ | | -;; | \ | | -;; o x o o -;; | | | | -;; | | | | -;; o o o o -;; -;; Redoing takes you back down the undo tree, as usual (as long as you haven't -;; changed the active region after undoing-in-region, it doesn't matter if it -;; is still active): -;; -;; o -;; |\ -;; | \ -;; o o -;; | | -;; | | -;; o o (redo) -;; | | -;; | | -;; o x (redo) -;; -;; -;; What about redo-in-region? Obviously, this only makes sense if you have -;; already undone some changes, so that there are some changes to redo! -;; Redoing-in-region splits off a new branch of the undo history below your -;; current location in the undo tree. This time, the new branch consists of a -;; redo step that redoes some of the redo changes that affect the current -;; region, followed by all the remaining redo changes. -;; -;; Previous undo history Redo-in-region -;; -;; o o -;; | | -;; | | -;; x o -;; | |\ -;; | | \ -;; o o x (redo-in-region) -;; | | | -;; | | | -;; o o o -;; -;; As long as you don't change the active region after redoing-in-region, -;; continuing to redo-in-region extends the new branch, pulling more redo -;; changes into a redo step immediately below your current location in the -;; undo tree. -;; -;; First redo-in-region Second redo-in-region -;; -;; o o -;; | | -;; | | -;; o o -;; |\ |\ -;; | \ | \ -;; o x (redo-in-region) o o -;; | | | | -;; | | | | -;; o o o x (redo-in-region) -;; | -;; | -;; o -;; -;; Note that undo-in-region and redo-in-region only ever add new changes to -;; the undo tree, they *never* modify existing undo history. So you can always -;; return to previous buffer states by switching to a previous branch of the -;; tree. - - - -;;; Change Log: -;; -;; Version 0.3 -;; * implemented undo-in-region -;; * fixed bugs in `undo-list-transfer-to-tree' and -;; `undo-list-rebuild-from-tree' which caused errors when undo history was -;; empty or disabled -;; * defun `region-active-p' if not already defined, for compatibility with -;; older Emacsen -;; -;; Version 0.2.1 -;; * modified `undo-tree-node' defstruct and macros to allow arbitrary -;; meta-data to be stored in a plist associated with a node, and -;; reimplemented storage of visualizer data on top of this -;; * display registers storing undo-tree state in visualizer -;; * implemented keyboard selection in visualizer -;; * rebuild `buffer-undo-list' from tree when disabling `undo-tree-mode' -;; -;; Version 0.2 -;; * added support for marker undo entries -;; -;; Version 0.1.7 -;; * pass null argument to `kill-buffer' call in `undo-tree-visualizer-quit', -;; since the argument's not optional in earlier Emacs versions -;; * added match for "No further redo information" to -;; `debug-ignored-errors' to prevent debugger being called on this error -;; * made `undo-tree-visualizer-quit' select the window displaying the -;; visualizer's parent buffer, or switch to the parent buffer if no window -;; is displaying it -;; * fixed bug in `undo-tree-switch-branch' -;; * general code tidying and reorganisation -;; * fixed bugs in history-discarding logic -;; * fixed bug in `undo-tree-insert' triggered by `undo-tree-visualizer-set' -;; by ensuring mark is deactivated -;; -;; Version 0.1.6 -;; * added `undo-tree-mode-lighter' customization option to allow the -;; mode-line lighter to be changed -;; * bug-fix in `undo-tree-discard-node' -;; * added `undo-tree-save-state-to-register' and -;; `undo-tree-restore-state-from-register' commands and keybindings for -;; saving/restoring undo-tree states using registers -;; -;; Version 0.1.5 -;; * modified `undo-tree-visualize' to mark the visualizer window as -;; soft-dedicated, and changed `undo-tree-visualizer-quit' to use -;; `kill-buffer', so that the visualizer window is deleted along with its -;; buffer if the visualizer buffer was displayed in a new window, but not if -;; it was displayed in an existing window. -;; -;; Version 0.1.4 -;; * modified `undo-tree-undo' and `undo-tree-redo' to always replace -;; redo/undo entries with new ones generated by `primitive-undo', as the new -;; changesets will restore the point more reliably -;; -;; Version 0.1.3 -;; * fixed `undo-tree-visualizer-quit' to remove `after-change-functions' -;; hook there, rather than in `undo-tree-kill-visualizer' -;; -;; Version 0.1.2 -;; * fixed keybindings -;; * renamed `undo-tree-visualizer-switch-previous-branch' and -;; `undo-tree-visualizer-switch-next-branch' to -;; `undo-tree-visualizer-switch-branch-left' and -;; `undo-tree-visualizer-switch-branch-right' -;; -;; Version 0.1.1 -;; * prevented `undo-tree-kill-visualizer' from killing visualizer when -;; undoing/redoing from the visualizer, which completely broke the -;; visualizer! -;; * changed one redo binding, so that at least one set of undo/redo bindings -;; works in a terminal -;; * bound vertical scrolling commands in `undo-tree-visualizer-map', in case -;; they aren't bound globally -;; * added missing :group argument to `defface's -;; -;; Version 0.1 -;; * initial release - - - -;;; Code: - -(eval-when-compile (require 'cl)) - -;; `characterp' isn't defined in Emacs versions <= 22 -(unless (fboundp 'characterp) - (defalias 'characterp 'char-valid-p)) - -;; `region-active-p' isn't defined in Emacs versions <= 22 -(unless (fboundp 'region-active-p) - (defun region-active-p () (and transient-mark-mode mark-active))) - - - -;;; ===================================================================== -;;; Global variables and customization options - -(defvar buffer-undo-tree nil - "Tree of undo entries in current buffer.") -(make-variable-buffer-local 'buffer-undo-tree) - - -(defgroup undo-tree nil - "Tree undo/redo." - :group 'undo) - -(defcustom undo-tree-mode-lighter " Undo-Tree" - "Lighter displayed in mode line -when `undo-tree-mode' is enabled." - :group 'undo-tree - :type 'string) - -(defcustom undo-tree-visualizer-spacing 3 - "Horizontal spacing in undo-tree visualization. -Must be a postivie odd integer." - :group 'undo-tree - :type '(integer - :match (lambda (w n) (and (integerp n) (> n 0) (= (mod n 2) 1))))) -(make-variable-buffer-local 'undo-tree-visualizer-spacing) - -(defvar undo-tree-map nil - "Keymap used in undo-tree-mode.") - - -(defface undo-tree-visualizer-default-face - '((((class color)) :foreground "gray")) - "*Face used to draw undo-tree in visualizer." - :group 'undo-tree) - -(defface undo-tree-visualizer-current-face - '((((class color)) :foreground "red")) - "*Face used to highlight current undo-tree node in visualizer." - :group 'undo-tree) - -(defface undo-tree-visualizer-active-branch-face - '((((class color) (background dark)) - (:foreground "white" :weight bold)) - (((class color) (background light)) - (:foreground "black" :weight bold))) - "*Face used to highlight active undo-tree branch -in visualizer." - :group 'undo-tree) - -(defface undo-tree-visualizer-register-face - '((((class color)) :foreground "yellow")) - "*Face used to highlight undo-tree nodes saved to a register -in visualizer." - :group 'undo-tree) - -(defvar undo-tree-visualizer-map nil - "Keymap used in undo-tree visualizer.") - -(defvar undo-tree-visualizer-selection-map nil - "Keymap used in undo-tree visualizer selection mode.") - - -(defvar undo-tree-visualizer-parent-buffer nil - "Parent buffer in visualizer.") -(make-variable-buffer-local 'undo-tree-visualizer-parent-buffer) - -(defvar undo-tree-visualizer-timestamps nil - "Non-nil when visualizer is displaying time-stamps.") -(make-variable-buffer-local 'undo-tree-visualizer-timestamps) - -(defconst undo-tree-visualizer-buffer-name " *undo-tree*") - -;; prevent debugger being called on "No further redo information" -(add-to-list 'debug-ignored-errors "^No further redo information") - - - - -;;; ================================================================= -;;; Setup default keymaps - -(unless undo-tree-map - (setq undo-tree-map (make-sparse-keymap)) - ;; remap `undo' and `undo-only' to `undo-tree-undo' - (define-key undo-tree-map [remap undo] 'undo-tree-undo) - (define-key undo-tree-map [remap undo-only] 'undo-tree-undo) - ;; bind standard undo bindings (since these match redo counterparts) - (define-key undo-tree-map (kbd "C-/") 'undo-tree-undo) - (define-key undo-tree-map "\C-_" 'undo-tree-undo) - ;; redo doesn't exist normally, so define our own keybindings - (define-key undo-tree-map (kbd "C-?") 'undo-tree-redo) - (define-key undo-tree-map (kbd "M-_") 'undo-tree-redo) - ;; just in case something has defined `redo'... - (define-key undo-tree-map [remap redo] 'undo-tree-redo) - ;; we use "C-x u" for the undo-tree visualizer - (define-key undo-tree-map (kbd "\C-x u") 'undo-tree-visualize) - ;; bind register commands - (define-key undo-tree-map (kbd "C-x r u") - 'undo-tree-save-state-to-register) - (define-key undo-tree-map (kbd "C-x r U") - 'undo-tree-restore-state-from-register)) - - -(unless undo-tree-visualizer-map - (setq undo-tree-visualizer-map (make-keymap)) - ;; vertical motion keys undo/redo - (define-key undo-tree-visualizer-map [remap previous-line] - 'undo-tree-visualize-undo) - (define-key undo-tree-visualizer-map [remap next-line] - 'undo-tree-visualize-redo) - (define-key undo-tree-visualizer-map [up] - 'undo-tree-visualize-undo) - (define-key undo-tree-visualizer-map "p" - 'undo-tree-visualize-undo) - (define-key undo-tree-visualizer-map "\C-p" - 'undo-tree-visualize-undo) - (define-key undo-tree-visualizer-map [down] - 'undo-tree-visualize-redo) - (define-key undo-tree-visualizer-map "n" - 'undo-tree-visualize-redo) - (define-key undo-tree-visualizer-map "\C-n" - 'undo-tree-visualize-redo) - ;; horizontal motion keys switch branch - (define-key undo-tree-visualizer-map [remap forward-char] - 'undo-tree-visualize-switch-branch-right) - (define-key undo-tree-visualizer-map [remap backward-char] - 'undo-tree-visualize-switch-branch-left) - (define-key undo-tree-visualizer-map [right] - 'undo-tree-visualize-switch-branch-right) - (define-key undo-tree-visualizer-map "f" - 'undo-tree-visualize-switch-branch-right) - (define-key undo-tree-visualizer-map "\C-f" - 'undo-tree-visualize-switch-branch-right) - (define-key undo-tree-visualizer-map [left] - 'undo-tree-visualize-switch-branch-left) - (define-key undo-tree-visualizer-map "b" - 'undo-tree-visualize-switch-branch-left) - (define-key undo-tree-visualizer-map "\C-b" - 'undo-tree-visualize-switch-branch-left) - ;; mouse sets buffer state to node at click - (define-key undo-tree-visualizer-map [mouse-1] - 'undo-tree-visualizer-mouse-set) - ;; toggle timestamps - (define-key undo-tree-visualizer-map "t" - 'undo-tree-visualizer-toggle-timestamps) - ;; selection mode - (define-key undo-tree-visualizer-map "s" - 'undo-tree-visualizer-selection-mode) - ;; horizontal scrolling may be needed if the tree is very wide - (define-key undo-tree-visualizer-map "," - 'undo-tree-visualizer-scroll-left) - (define-key undo-tree-visualizer-map "." - 'undo-tree-visualizer-scroll-right) - (define-key undo-tree-visualizer-map "<" - 'undo-tree-visualizer-scroll-left) - (define-key undo-tree-visualizer-map ">" - 'undo-tree-visualizer-scroll-right) - ;; vertical scrolling may be needed if the tree is very tall - (define-key undo-tree-visualizer-map [next] 'scroll-up) - (define-key undo-tree-visualizer-map [prior] 'scroll-down) - ;; quit visualizer - (define-key undo-tree-visualizer-map "q" - 'undo-tree-visualizer-quit) - (define-key undo-tree-visualizer-map "\C-q" - 'undo-tree-visualizer-quit)) - - -(unless undo-tree-visualizer-selection-map - (setq undo-tree-visualizer-selection-map (make-keymap)) - ;; vertical motion keys move up and down tree - (define-key undo-tree-visualizer-selection-map [remap previous-line] - 'undo-tree-visualizer-select-previous) - (define-key undo-tree-visualizer-selection-map [remap next-line] - 'undo-tree-visualizer-select-next) - (define-key undo-tree-visualizer-selection-map [up] - 'undo-tree-visualizer-select-previous) - (define-key undo-tree-visualizer-selection-map "p" - 'undo-tree-visualizer-select-previous) - (define-key undo-tree-visualizer-selection-map "\C-p" - 'undo-tree-visualizer-select-previous) - (define-key undo-tree-visualizer-selection-map [down] - 'undo-tree-visualizer-select-next) - (define-key undo-tree-visualizer-selection-map "n" - 'undo-tree-visualizer-select-next) - (define-key undo-tree-visualizer-selection-map "\C-n" - 'undo-tree-visualizer-select-next) - ;; vertical scroll keys move up and down quickly - (define-key undo-tree-visualizer-selection-map [next] - (lambda () (interactive) (undo-tree-visualizer-select-next 10))) - (define-key undo-tree-visualizer-selection-map [prior] - (lambda () (interactive) (undo-tree-visualizer-select-previous 10))) - ;; horizontal motion keys move to left and right siblings - (define-key undo-tree-visualizer-selection-map [remap forward-char] - 'undo-tree-visualizer-select-right) - (define-key undo-tree-visualizer-selection-map [remap backward-char] - 'undo-tree-visualizer-select-left) - (define-key undo-tree-visualizer-selection-map [right] - 'undo-tree-visualizer-select-right) - (define-key undo-tree-visualizer-selection-map "f" - 'undo-tree-visualizer-select-right) - (define-key undo-tree-visualizer-selection-map "\C-f" - 'undo-tree-visualizer-select-right) - (define-key undo-tree-visualizer-selection-map [left] - 'undo-tree-visualizer-select-left) - (define-key undo-tree-visualizer-selection-map "b" - 'undo-tree-visualizer-select-left) - (define-key undo-tree-visualizer-selection-map "\C-b" - 'undo-tree-visualizer-select-left) - ;; horizontal scroll keys move left or right quickly - (define-key undo-tree-visualizer-selection-map "," - (lambda () (interactive) (undo-tree-visualizer-select-left 10))) - (define-key undo-tree-visualizer-selection-map "." - (lambda () (interactive) (undo-tree-visualizer-select-right 10))) - (define-key undo-tree-visualizer-selection-map "<" - (lambda () (interactive) (undo-tree-visualizer-select-left 10))) - (define-key undo-tree-visualizer-selection-map ">" - (lambda () (interactive) (undo-tree-visualizer-select-right 10))) - ;; mouse or sets buffer state to node at point/click - (define-key undo-tree-visualizer-selection-map "\r" - 'undo-tree-visualizer-set) - (define-key undo-tree-visualizer-selection-map [mouse-1] - 'undo-tree-visualizer-mouse-set) - ;; toggle timestamps - (define-key undo-tree-visualizer-selection-map "t" - 'undo-tree-visualizer-toggle-timestamps) - ;; quit visualizer selection mode - (define-key undo-tree-visualizer-selection-map "s" - 'undo-tree-visualizer-mode) - ;; quit visualizer - (define-key undo-tree-visualizer-selection-map "q" - 'undo-tree-visualizer-quit) - (define-key undo-tree-visualizer-selection-map "\C-q" - 'undo-tree-visualizer-quit)) - - - - -;;; ===================================================================== -;;; Undo-tree data structure - -(defstruct - (undo-tree - :named - (:constructor nil) - (:constructor make-undo-tree - (&aux - (root (make-undo-tree-node nil nil)) - (current root) - (size 0) - (object-pool (make-hash-table :test 'eq :weakness 'value)))) - (:copier nil)) - root current size object-pool) - - - -(defstruct - (undo-tree-node - (:type vector) ; create unnamed struct - (:constructor nil) - (:constructor make-undo-tree-node - (previous undo - &optional redo - &aux - (timestamp (current-time)) - (branch 0))) - (:constructor make-undo-tree-node-backwards - (next-node undo - &optional redo - &aux - (next (list next-node)) - (timestamp (current-time)) - (branch 0))) - (:copier nil)) - previous next undo redo timestamp branch meta-data) - - -(defmacro undo-tree-node-p (n) - (let ((len (length (make-undo-tree-node nil nil)))) - `(and (vectorp ,n) (= (length ,n) ,len)))) - - - -(defstruct - (undo-tree-region-data - (:type vector) ; create unnamed struct - (:constructor nil) - (:constructor make-undo-tree-region-data - (&optional undo-beginning undo-end - redo-beginning redo-end)) - (:constructor make-undo-tree-undo-region-data - (undo-beginning undo-end)) - (:constructor make-undo-tree-redo-region-data - (redo-beginning redo-end)) - (:copier nil)) - undo-beginning undo-end redo-beginning redo-end) - - -(defmacro undo-tree-region-data-p (r) - (let ((len (length (make-undo-tree-region-data)))) - `(and (vectorp ,r) (= (length ,r) ,len)))) - -(defmacro undo-tree-node-clear-region-data (node) - `(setf (undo-tree-node-meta-data ,node) - (delq nil - (delq :region - (plist-put (undo-tree-node-meta-data ,node) - :region nil))))) - - -(defmacro undo-tree-node-undo-beginning (node) - `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) - (when (undo-tree-region-data-p r) - (undo-tree-region-data-undo-beginning r)))) - -(defmacro undo-tree-node-undo-end (node) - `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) - (when (undo-tree-region-data-p r) - (undo-tree-region-data-undo-end r)))) - -(defmacro undo-tree-node-redo-beginning (node) - `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) - (when (undo-tree-region-data-p r) - (undo-tree-region-data-redo-beginning r)))) - -(defmacro undo-tree-node-redo-end (node) - `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) - (when (undo-tree-region-data-p r) - (undo-tree-region-data-redo-end r)))) - - -(defsetf undo-tree-node-undo-beginning (node) (val) - `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) - (unless (undo-tree-region-data-p r) - (setf (undo-tree-node-meta-data ,node) - (plist-put (undo-tree-node-meta-data ,node) :region - (setq r (make-undo-tree-region-data))))) - (setf (undo-tree-region-data-undo-beginning r) ,val))) - -(defsetf undo-tree-node-undo-end (node) (val) - `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) - (unless (undo-tree-region-data-p r) - (setf (undo-tree-node-meta-data ,node) - (plist-put (undo-tree-node-meta-data ,node) :region - (setq r (make-undo-tree-region-data))))) - (setf (undo-tree-region-data-undo-end r) ,val))) - -(defsetf undo-tree-node-redo-beginning (node) (val) - `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) - (unless (undo-tree-region-data-p r) - (setf (undo-tree-node-meta-data ,node) - (plist-put (undo-tree-node-meta-data ,node) :region - (setq r (make-undo-tree-region-data))))) - (setf (undo-tree-region-data-redo-beginning r) ,val))) - -(defsetf undo-tree-node-redo-end (node) (val) - `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) - (unless (undo-tree-region-data-p r) - (setf (undo-tree-node-meta-data ,node) - (plist-put (undo-tree-node-meta-data ,node) :region - (setq r (make-undo-tree-region-data))))) - (setf (undo-tree-region-data-redo-end r) ,val))) - - - -(defstruct - (undo-tree-visualizer-data - (:type vector) ; create unnamed struct - (:constructor nil) - (:constructor make-undo-tree-visualizer-data - (&optional lwidth cwidth rwidth marker)) - (:copier nil)) - lwidth cwidth rwidth marker) - - -(defmacro undo-tree-visualizer-data-p (v) - (let ((len (length (make-undo-tree-visualizer-data)))) - `(and (vectorp ,v) (= (length ,v) ,len)))) - -(defmacro undo-tree-node-clear-visualizer-data (node) - `(setf (undo-tree-node-meta-data ,node) - (delq nil - (delq :visualizer - (plist-put (undo-tree-node-meta-data ,node) - :visualizer nil))))) - - -(defmacro undo-tree-node-lwidth (node) - `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) - (when (undo-tree-visualizer-data-p v) - (undo-tree-visualizer-data-lwidth v)))) - -(defmacro undo-tree-node-cwidth (node) - `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) - (when (undo-tree-visualizer-data-p v) - (undo-tree-visualizer-data-cwidth v)))) - -(defmacro undo-tree-node-rwidth (node) - `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) - (when (undo-tree-visualizer-data-p v) - (undo-tree-visualizer-data-rwidth v)))) - -(defmacro undo-tree-node-marker (node) - `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) - (when (undo-tree-visualizer-data-p v) - (undo-tree-visualizer-data-marker v)))) - - -(defsetf undo-tree-node-lwidth (node) (val) - `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) - (unless (undo-tree-visualizer-data-p v) - (setf (undo-tree-node-meta-data ,node) - (plist-put (undo-tree-node-meta-data ,node) :visualizer - (setq v (make-undo-tree-visualizer-data))))) - (setf (undo-tree-visualizer-data-lwidth v) ,val))) - -(defsetf undo-tree-node-cwidth (node) (val) - `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) - (unless (undo-tree-visualizer-data-p v) - (setf (undo-tree-node-meta-data ,node) - (plist-put (undo-tree-node-meta-data ,node) :visualizer - (setq v (make-undo-tree-visualizer-data))))) - (setf (undo-tree-visualizer-data-cwidth v) ,val))) - -(defsetf undo-tree-node-rwidth (node) (val) - `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) - (unless (undo-tree-visualizer-data-p v) - (setf (undo-tree-node-meta-data ,node) - (plist-put (undo-tree-node-meta-data ,node) :visualizer - (setq v (make-undo-tree-visualizer-data))))) - (setf (undo-tree-visualizer-data-rwidth v) ,val))) - -(defsetf undo-tree-node-marker (node) (val) - `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) - (unless (undo-tree-visualizer-data-p v) - (setf (undo-tree-node-meta-data ,node) - (plist-put (undo-tree-node-meta-data ,node) :visualizer - (setq v (make-undo-tree-visualizer-data))))) - (setf (undo-tree-visualizer-data-marker v) ,val))) - - - -(defmacro undo-tree-node-register (node) - `(plist-get (undo-tree-node-meta-data ,node) :register)) - -(defsetf undo-tree-node-register (node) (val) - `(setf (undo-tree-node-meta-data ,node) - (plist-put (undo-tree-node-meta-data ,node) :register ,val))) - - - - -;;; ===================================================================== -;;; Basic undo-tree data structure functions - -(defun undo-tree-grow (undo) - "Add an UNDO node to current branch of `buffer-undo-tree'." - (let* ((current (undo-tree-current buffer-undo-tree)) - (new (make-undo-tree-node current undo))) - (push new (undo-tree-node-next current)) - (setf (undo-tree-current buffer-undo-tree) new))) - - -(defun undo-tree-grow-backwards (node undo &optional redo) - "Add new node *above* undo-tree NODE, and return new node. -Note that this will overwrite NODE's \"previous\" link, so should -only be used on a detached NODE, never on nodes that are already -part of `buffer-undo-tree'." - (let ((new (make-undo-tree-node-backwards node undo redo))) - (setf (undo-tree-node-previous node) new) - new)) - - -(defun undo-tree-splice-node (node splice) - "Splice NODE into undo tree, below node SPLICE. -Note that this will overwrite NODE's \"next\" and \"previous\" -links, so should only be used on a detached NODE, never on nodes -that are already part of `buffer-undo-tree'." - (setf (undo-tree-node-next node) (undo-tree-node-next splice) - (undo-tree-node-branch node) (undo-tree-node-branch splice) - (undo-tree-node-previous node) splice - (undo-tree-node-next splice) (list node) - (undo-tree-node-branch splice) 0) - (dolist (n (undo-tree-node-next node)) - (setf (undo-tree-node-previous n) node))) - - -(defun undo-tree-snip-node (node) - "Snip NODE out of undo tree." - (let* ((parent (undo-tree-node-previous node)) - position p) - ;; if NODE is only child, replace parent's next links with NODE's - (if (= (length (undo-tree-node-next parent)) 0) - (setf (undo-tree-node-next parent) (undo-tree-node-next node) - (undo-tree-node-branch parent) (undo-tree-node-branch node)) - ;; otherwise... - (setq position (undo-tree-position node (undo-tree-node-next parent))) - (cond - ;; if active branch used do go via NODE, set parent's branch to active - ;; branch of NODE - ((= (undo-tree-node-branch parent) position) - (setf (undo-tree-node-branch parent) - (+ position (undo-tree-node-branch node)))) - ;; if active branch didn't go via NODE, update parent's branch to point - ;; to same node as before - ((> (undo-tree-node-branch parent) position) - (incf (undo-tree-node-branch parent) - (1- (length (undo-tree-node-next node)))))) - ;; replace NODE in parent's next list with NODE's entire next list - (if (= position 0) - (setf (undo-tree-node-next parent) - (nconc (undo-tree-node-next node) - (cdr (undo-tree-node-next parent)))) - (setq p (nthcdr (1- position) (undo-tree-node-next parent))) - (setcdr p (nconc (undo-tree-node-next node) (cddr p))))) - ;; update previous links of NODE's children - (dolist (n (undo-tree-node-next node)) - (setf (undo-tree-node-previous n) parent)))) - - -(defun undo-tree-mapc (--undo-tree-mapc-function-- undo-tree) - ;; Apply FUNCTION to each node in UNDO-TREE. - (let ((stack (list (undo-tree-root undo-tree))) - node) - (while stack - (setq node (pop stack)) - (funcall --undo-tree-mapc-function-- node) - (setq stack (append (undo-tree-node-next node) stack))))) - - -(defmacro undo-tree-num-branches () - "Return number of branches at current undo tree node." - '(length (undo-tree-node-next (undo-tree-current buffer-undo-tree)))) - - -(defun undo-tree-position (node list) - "Find the first occurrence of NODE in LIST. -Return the index of the matching item, or nil of not found. -Comparison is done with 'eq." - (let ((i 0)) - (catch 'found - (while (progn - (when (eq node (car list)) (throw 'found i)) - (incf i) - (setq list (cdr list)))) - nil))) - - -(defvar *undo-tree-id-counter* 0) -(make-variable-buffer-local '*undo-tree-id-counter*) - -(defmacro undo-tree-generate-id () - ;; Generate a new, unique id (uninterned symbol). - ;; The name is made by appending a number to "undo-tree-id". - ;; (Copied from CL package `gensym'.) - `(let ((num (prog1 *undo-tree-id-counter* (incf *undo-tree-id-counter*)))) - (make-symbol (format "undo-tree-id%d" num)))) - - - - -;;; ===================================================================== -;;; Utility functions for handling `buffer-undo-list' and changesets - -(defmacro undo-list-marker-elt-p (elt) - `(markerp (car-safe ,elt))) - -(defmacro undo-list-GCd-marker-elt-p (elt) - `(and (symbolp (car-safe ,elt)) (numberp (cdr-safe ,elt)))) - - -(defun undo-tree-move-GC-elts-to-pool (elt) - ;; Move elements that can be garbage-collected into `buffer-undo-tree' - ;; object pool, substituting a unique id that can be used to retrieve them - ;; later. (Only markers require this treatment currently.) - (when (undo-list-marker-elt-p elt) - (let ((id (undo-tree-generate-id))) - (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree)) - (setcar elt id)))) - - -(defun undo-tree-restore-GC-elts-from-pool (elt) - ;; Replace object id's in ELT with corresponding objects from - ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if - ;; any object in ELT has been garbage-collected. - (if (undo-list-GCd-marker-elt-p elt) - (when (setcar elt (gethash (car elt) - (undo-tree-object-pool buffer-undo-tree))) - elt) - elt)) - - -(defun undo-list-clean-GCd-elts (undo-list) - ;; Remove object id's from UNDO-LIST that refer to elements that have been - ;; garbage-collected. UNDO-LIST is modified by side-effect. - (while (undo-list-GCd-marker-elt-p (car undo-list)) - (unless (gethash (caar undo-list) - (undo-tree-object-pool buffer-undo-tree)) - (setq undo-list (cdr undo-list)))) - (let ((p undo-list)) - (while (cdr p) - (when (and (undo-list-GCd-marker-elt-p (cadr p)) - (null (gethash (car (cadr p)) - (undo-tree-object-pool buffer-undo-tree)))) - (setcdr p (cddr p))) - (setq p (cdr p)))) - undo-list) - - -(defun undo-list-pop-changeset () - ;; Pop changeset from `buffer-undo-list'. - ;; discard undo boundaries at head of list - (while (null (car buffer-undo-list)) - (setq buffer-undo-list (cdr buffer-undo-list))) - ;; pop elements up to next undo boundary - (unless (eq (car buffer-undo-list) 'undo-tree-canary) - (let* ((changeset (list (pop buffer-undo-list))) - (p changeset)) - (while (progn - (undo-tree-move-GC-elts-to-pool (car p)) - (car buffer-undo-list)) - (setcdr p (list (pop buffer-undo-list))) - (setq p (cdr p))) - changeset))) - - -(defun undo-tree-copy-list (undo-list) - ;; Return a deep copy of first changeset in `undo-list'. Object id's are - ;; replaced by corresponding objects from `buffer-undo-tree' object-pool. - (when undo-list - (let (copy p) - ;; if first element contains an object id, replace it with object from - ;; pool, discarding element entirely if it's been GC'd - (while (null copy) - (setq copy - (undo-tree-restore-GC-elts-from-pool (pop undo-list)))) - (setq copy (list copy) - p copy) - ;; copy remaining elements, replacing object id's with objects from - ;; pool, or discarding them entirely if they've been GC'd - (while undo-list - (when (setcdr p (undo-tree-restore-GC-elts-from-pool - (undo-copy-list-1 (pop undo-list)))) - (setcdr p (list (cdr p))) - (setq p (cdr p)))) - copy))) - - - -(defun undo-list-transfer-to-tree () - ;; Transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'. - - ;; if `buffer-undo-tree' is empty, create initial undo-tree - (when (null buffer-undo-tree) (setq buffer-undo-tree (make-undo-tree))) - ;; make sure there's a canary at end of `buffer-undo-list' - (if (null buffer-undo-list) - (setq buffer-undo-list '(nil undo-tree-canary)) - (let ((elt (last buffer-undo-list))) - (unless (eq (car elt) 'undo-tree-canary) - (setcdr elt '(nil undo-tree-canary))))) - - (unless (eq (cadr buffer-undo-list) 'undo-tree-canary) - ;; create new node from first changeset in `buffer-undo-list', save old - ;; `buffer-undo-tree' current node, and make new node the current node - (let* ((node (make-undo-tree-node nil (undo-list-pop-changeset))) - (splice (undo-tree-current buffer-undo-tree)) - (size (undo-list-byte-size (undo-tree-node-undo node)))) - (setf (undo-tree-current buffer-undo-tree) node) - ;; grow tree fragment backwards using `buffer-undo-list' changesets - (while (and buffer-undo-list - (not (eq (cadr buffer-undo-list) 'undo-tree-canary))) - (setq node - (undo-tree-grow-backwards node (undo-list-pop-changeset))) - (incf size (undo-list-byte-size (undo-tree-node-undo node)))) - ;; if no undo history has been discarded from `buffer-undo-list' since - ;; last transfer, splice new tree fragment onto end of old - ;; `buffer-undo-tree' current node - (if (eq (cadr buffer-undo-list) 'undo-tree-canary) - (progn - (setf (undo-tree-node-previous node) splice) - (push node (undo-tree-node-next splice)) - (setf (undo-tree-node-branch splice) 0) - (incf (undo-tree-size buffer-undo-tree) size)) - ;; if undo history has been discarded, replace entire - ;; `buffer-undo-tree' with new tree fragment - (setq node (undo-tree-grow-backwards node nil)) - (setf (undo-tree-root buffer-undo-tree) node) - (setq buffer-undo-list '(nil undo-tree-canary)) - (setf (undo-tree-size buffer-undo-tree) size))) - ;; discard undo history if necessary - (undo-tree-discard-history))) - - -(defun undo-list-byte-size (undo-list) - ;; Return size (in bytes) of UNDO-LIST - (let ((size 0) (p undo-list)) - (while p - (incf size 8) ; cons cells use up 8 bytes - (when (and (consp (car p)) (stringp (caar p))) - (incf size (string-bytes (caar p)))) - (setq p (cdr p))) - size)) - - - -(defun undo-list-rebuild-from-tree () - "Rebuild `buffer-undo-list' from information in `buffer-undo-tree'." - (unless (eq buffer-undo-list t) - (undo-list-transfer-to-tree) - (setq buffer-undo-list nil) - (when buffer-undo-tree - (let ((stack (list (list (undo-tree-root buffer-undo-tree))))) - (push (sort (mapcar 'identity (undo-tree-node-next (caar stack))) - (lambda (a b) - (time-less-p (undo-tree-node-timestamp a) - (undo-tree-node-timestamp b)))) - stack) - ;; Traverse tree in depth-and-oldest-first order, but add undo records - ;; on the way down, and redo records on the way up. - (while (or (car stack) - (not (eq (car (nth 1 stack)) - (undo-tree-current buffer-undo-tree)))) - (if (car stack) - (progn - (setq buffer-undo-list - (append (undo-tree-node-undo (caar stack)) - buffer-undo-list)) - (undo-boundary) - (push (sort (mapcar 'identity - (undo-tree-node-next (caar stack))) - (lambda (a b) - (time-less-p (undo-tree-node-timestamp a) - (undo-tree-node-timestamp b)))) - stack)) - (pop stack) - (setq buffer-undo-list - (append (undo-tree-node-redo (caar stack)) - buffer-undo-list)) - (undo-boundary) - (pop (car stack)))))))) - - - - -;;; ===================================================================== -;;; History discarding functions - -(defun undo-tree-oldest-leaf (node) - ;; Return oldest leaf node below NODE. - (while (undo-tree-node-next node) - (setq node - (car (sort (mapcar 'identity (undo-tree-node-next node)) - (lambda (a b) - (time-less-p (undo-tree-node-timestamp a) - (undo-tree-node-timestamp b))))))) - node) - - -(defun undo-tree-discard-node (node) - ;; Discard NODE from `buffer-undo-tree', and return next in line for - ;; discarding. - - ;; don't discard current node - (unless (eq node (undo-tree-current buffer-undo-tree)) - - ;; discarding root node... - (if (eq node (undo-tree-root buffer-undo-tree)) - (cond - ;; should always discard branches before root - ((> (length (undo-tree-node-next node)) 1) - (error "Trying to discard undo-tree root which still\ - has multiple branches")) - ;; don't discard root if current node is only child - ((eq (car (undo-tree-node-next node)) - (undo-tree-current buffer-undo-tree)) - nil) - ;; discard root - (t - ;; make child of root into new root - (setq node (setf (undo-tree-root buffer-undo-tree) - (car (undo-tree-node-next node)))) - ;; update undo-tree size - (decf (undo-tree-size buffer-undo-tree) - (+ (undo-list-byte-size (undo-tree-node-undo node)) - (undo-list-byte-size (undo-tree-node-redo node)))) - ;; discard new root's undo data - (setf (undo-tree-node-undo node) nil - (undo-tree-node-redo node) nil) - ;; if new root has branches, or new root is current node, next node - ;; to discard is oldest leaf, otherwise it's new root - (if (or (> (length (undo-tree-node-next node)) 1) - (eq (car (undo-tree-node-next node)) - (undo-tree-current buffer-undo-tree))) - (undo-tree-oldest-leaf node) - node))) - - ;; discarding leaf node... - (let* ((parent (undo-tree-node-previous node)) - (current (nth (undo-tree-node-branch parent) - (undo-tree-node-next parent)))) - ;; update undo-tree size - (decf (undo-tree-size buffer-undo-tree) - (+ (undo-list-byte-size (undo-tree-node-undo node)) - (undo-list-byte-size (undo-tree-node-redo node)))) - (setf (undo-tree-node-next parent) - (delq node (undo-tree-node-next parent)) - (undo-tree-node-branch parent) - (undo-tree-position current (undo-tree-node-next parent))) - ;; if parent has branches, or parent is current node, next node to - ;; discard is oldest leaf, otherwise it's parent - (if (or (eq parent (undo-tree-current buffer-undo-tree)) - (and (undo-tree-node-next parent) - (or (not (eq parent (undo-tree-root buffer-undo-tree))) - (> (length (undo-tree-node-next parent)) 1)))) - (undo-tree-oldest-leaf parent) - parent))))) - - - -(defun undo-tree-discard-history () - "Discard undo history until we're within memory usage limits -set by `undo-limit', `undo-strong-limit' and `undo-outer-limit'." - - (when (> (undo-tree-size buffer-undo-tree) undo-limit) - ;; if there are no branches off root, first node to discard is root; - ;; otherwise it's leaf node at botom of oldest branch - (let ((node (if (> (length (undo-tree-node-next - (undo-tree-root buffer-undo-tree))) 1) - (undo-tree-oldest-leaf (undo-tree-root buffer-undo-tree)) - (undo-tree-root buffer-undo-tree)))) - - ;; discard nodes until memory use is within `undo-strong-limit' - (while (and node - (> (undo-tree-size buffer-undo-tree) undo-strong-limit)) - (setq node (undo-tree-discard-node node))) - - ;; discard nodes until next node to discard would bring memory use - ;; within `undo-limit' - (while (and node - ;; check first if last discard has brought us within - ;; `undo-limit', in case we can avoid more expensive - ;; `undo-strong-limit' calculation - ;; Note: this assumes undo-strong-limit > undo-limit; - ;; if not, effectively undo-strong-limit = undo-limit - (> (undo-tree-size buffer-undo-tree) undo-limit) - (> (- (undo-tree-size buffer-undo-tree) - ;; if next node to discard is root, the memory we - ;; free-up comes from discarding changesets from its - ;; only child... - (if (eq node (undo-tree-root buffer-undo-tree)) - (+ (undo-list-byte-size - (undo-tree-node-undo - (car (undo-tree-node-next node)))) - (undo-list-byte-size - (undo-tree-node-redo - (car (undo-tree-node-next node))))) - ;; ...otherwise, it comes from discarding changesets - ;; from along with the node itself - (+ (undo-list-byte-size (undo-tree-node-undo node)) - (undo-list-byte-size (undo-tree-node-redo node))) - )) - undo-limit)) - (setq node (undo-tree-discard-node node))) - - ;; if we're still over the `undo-outer-limit', discard entire history - (when (> (undo-tree-size buffer-undo-tree) undo-outer-limit) - ;; query first if `undo-ask-before-discard' is set - (if undo-ask-before-discard - (when (yes-or-no-p - (format - "Buffer `%s' undo info is %d bytes long; discard it? " - (buffer-name) (undo-tree-size buffer-undo-tree))) - (setq buffer-undo-tree nil)) - ;; otherwise, discard and display warning - (display-warning - '(undo discard-info) - (concat - (format "Buffer `%s' undo info was %d bytes long.\n" - (buffer-name) (undo-tree-size buffer-undo-tree)) - "The undo info was discarded because it exceeded\ - `undo-outer-limit'. - -This is normal if you executed a command that made a huge change -to the buffer. In that case, to prevent similar problems in the -future, set `undo-outer-limit' to a value that is large enough to -cover the maximum size of normal changes you expect a single -command to make, but not so large that it might exceed the -maximum memory allotted to Emacs. - -If you did not execute any such command, the situation is -probably due to a bug and you should report it. - -You can disable the popping up of this buffer by adding the entry -\(undo discard-info) to the user option `warning-suppress-types', -which is defined in the `warnings' library.\n") - :warning) - (setq buffer-undo-tree nil))) - ))) - - - - -;;; ===================================================================== -;;; Visualizer-related functions - -(defun undo-tree-compute-widths (undo-tree) - "Recursively compute widths for all UNDO-TREE's nodes." - (let ((stack (list (undo-tree-root undo-tree))) - res) - (while stack - ;; try to compute widths for node at top of stack - (if (undo-tree-node-p - (setq res (undo-tree-node-compute-widths (car stack)))) - ;; if computation fails, it returns a node whose widths still need - ;; computing, which we push onto the stack - (push res stack) - ;; otherwise, store widths and remove it from stack - (setf (undo-tree-node-lwidth (car stack)) (aref res 0) - (undo-tree-node-cwidth (car stack)) (aref res 1) - (undo-tree-node-rwidth (car stack)) (aref res 2)) - (pop stack))))) - - -(defun undo-tree-node-compute-widths (node) - ;; Compute NODE's left-, centre-, and right-subtree widths. Returns widths - ;; (in a vector) if successful. Otherwise, returns a node whose widths need - ;; calculating before NODE's can be calculated. - (let ((num-children (length (undo-tree-node-next node))) - (lwidth 0) (cwidth 0) (rwidth 0) - p w) - (catch 'need-widths - (cond - ;; leaf nodes have 0 width - ((= 0 num-children) - (setf cwidth 1 - (undo-tree-node-lwidth node) 0 - (undo-tree-node-cwidth node) 1 - (undo-tree-node-rwidth node) 0)) - - ;; odd number of children - ((= (mod num-children 2) 1) - (setq p (undo-tree-node-next node)) - ;; compute left-width - (dotimes (i (/ num-children 2)) - (if (undo-tree-node-lwidth (car p)) - (incf lwidth (+ (undo-tree-node-lwidth (car p)) - (undo-tree-node-cwidth (car p)) - (undo-tree-node-rwidth (car p)))) - ;; if child's widths haven't been computed, return that child - (throw 'need-widths (car p))) - (setq p (cdr p))) - (if (undo-tree-node-lwidth (car p)) - (incf lwidth (undo-tree-node-lwidth (car p))) - (throw 'need-widths (car p))) - ;; centre-width is inherited from middle child - (setf cwidth (undo-tree-node-cwidth (car p))) - ;; compute right-width - (incf rwidth (undo-tree-node-rwidth (car p))) - (setq p (cdr p)) - (dotimes (i (/ num-children 2)) - (if (undo-tree-node-lwidth (car p)) - (incf rwidth (+ (undo-tree-node-lwidth (car p)) - (undo-tree-node-cwidth (car p)) - (undo-tree-node-rwidth (car p)))) - (throw 'need-widths (car p))) - (setq p (cdr p)))) - - ;; even number of children - (t - (setq p (undo-tree-node-next node)) - ;; compute left-width - (dotimes (i (/ num-children 2)) - (if (undo-tree-node-lwidth (car p)) - (incf lwidth (+ (undo-tree-node-lwidth (car p)) - (undo-tree-node-cwidth (car p)) - (undo-tree-node-rwidth (car p)))) - (throw 'need-widths (car p))) - (setq p (cdr p))) - ;; centre-width is 0 when number of children is even - (setq cwidth 0) - ;; compute right-width - (dotimes (i (/ num-children 2)) - (if (undo-tree-node-lwidth (car p)) - (incf rwidth (+ (undo-tree-node-lwidth (car p)) - (undo-tree-node-cwidth (car p)) - (undo-tree-node-rwidth (car p)))) - (throw 'need-widths (car p))) - (setq p (cdr p))))) - - ;; return left-, centre- and right-widths - (vector lwidth cwidth rwidth)))) - - -(defun undo-tree-clear-visualizer-data (undo-tree) - ;; Clear visualizer data from UNDO-TREE. - (undo-tree-mapc - (lambda (node) (undo-tree-node-clear-visualizer-data node)) - undo-tree)) - - - - -;;; ===================================================================== -;;; Undo-in-region functions - -(defun undo-tree-pull-undo-in-region-branch (start end) - ;; Pull out entries from undo changesets to create a new undo-in-region - ;; branch, which undoes changeset entries lying between START and END first, - ;; followed by remaining entries from the changesets, before rejoining the - ;; existing undo tree history. Repeated calls will, if appropriate, extend - ;; the current undo-in-region branch rather than creating a new one. - - ;; if we're just reverting the last redo-in-region, we don't need to - ;; manipulate the undo tree at all - (if (undo-tree-reverting-redo-in-region-p start end) - t ; return t to indicate success - - ;; We build the `region-changeset' and `delta-list' lists forwards, using - ;; pointers `r' and `d' to the penultimate element of the list. So that we - ;; don't have to treat the first element differently, we prepend a dummy - ;; leading nil to the lists, and have the pointers point to that - ;; initially. - ;; Note: using '(nil) instead of (list nil) in the `let*' results in - ;; bizarre errors when the code is byte-compiled, where parts of the - ;; lists appear to survive across different calls to this function. - ;; An obscure byte-compiler bug, perhaps? - (let* ((region-changeset (list nil)) - (r region-changeset) - (delta-list (list nil)) - (d delta-list) - (node (undo-tree-current buffer-undo-tree)) - (repeated-undo-in-region - (undo-tree-repeated-undo-in-region-p start end)) - undo-adjusted-markers ; `undo-elt-in-region' expects this - fragment splice original-fragment original-splice original-current - got-visible-elt undo-list elt) - - ;; --- initialisation --- - (cond - ;; if this is a repeated undo in the same region, start pulling changes - ;; from NODE at which undo-in-region branch iss attached, and detatch - ;; the branch, using it as initial FRAGMENT of branch being constructed - (repeated-undo-in-region - (setq original-current node - fragment (car (undo-tree-node-next node)) - splice node) - ;; undo up to node at which undo-in-region branch is attached - ;; (recognizable as first node with more than one branch) - (let ((mark-active nil)) - (while (= (length (undo-tree-node-next node)) 1) - (undo-tree-undo) - (setq fragment node - node (undo-tree-current buffer-undo-tree)))) - (when (eq splice node) (setq splice nil)) - ;; detatch undo-in-region branch - (setf (undo-tree-node-next node) - (delq fragment (undo-tree-node-next node)) - (undo-tree-node-previous fragment) nil - original-fragment fragment - original-splice node)) - - ;; if this is a new undo-in-region, initial FRAGMENT is a copy of all - ;; nodes below the current one in the active branch - ((undo-tree-node-next node) - (setq fragment (make-undo-tree-node nil nil) - splice fragment) - (while (setq node (nth (undo-tree-node-branch node) - (undo-tree-node-next node))) - (push (make-undo-tree-node - splice - (undo-copy-list (undo-tree-node-undo node)) - (undo-copy-list (undo-tree-node-redo node))) - (undo-tree-node-next splice)) - (setq splice (car (undo-tree-node-next splice)))) - (setq fragment (car (undo-tree-node-next fragment)) - splice nil - node (undo-tree-current buffer-undo-tree)))) - - - ;; --- pull undo-in-region elements into branch --- - ;; work backwards up tree, pulling out undo elements within region until - ;; we've got one that undoes a visible change (insertion or deletion) - (catch 'abort - (while (and (not got-visible-elt) node (undo-tree-node-undo node)) - ;; we cons a dummy nil element on the front of the changeset so that - ;; we can conveniently remove the first (real) element from the - ;; changeset if we need to; the leading nil is removed once we're - ;; done with this changeset - (setq undo-list (cons nil (undo-copy-list (undo-tree-node-undo node))) - elt (cadr undo-list)) - (if fragment - (progn - (setq fragment (undo-tree-grow-backwards fragment undo-list)) - (unless splice (setq splice fragment))) - (setq fragment (make-undo-tree-node nil undo-list)) - (setq splice fragment)) - - (while elt - (cond - ;; keep elements within region - ((undo-elt-in-region elt start end) - ;; set flag if kept element is visible (insertion or deletion) - (when (and (consp elt) - (or (stringp (car elt)) (integerp (car elt)))) - (setq got-visible-elt t)) - ;; adjust buffer positions in elements previously undone before - ;; kept element, as kept element will now be undone first - (undo-tree-adjust-elements-to-elt splice elt) - ;; move kept element to undo-in-region changeset, adjusting its - ;; buffer position as it will now be undone first - (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list)))) - (setq r (cdr r)) - (setcdr undo-list (cddr undo-list))) - - ;; discard "was unmodified" elements - ;; FIXME: deal properly with these - ((and (consp elt) (eq (car elt) t)) - (setcdr undo-list (cddr undo-list))) - - ;; if element crosses region, we can't pull any more elements - ((undo-elt-crosses-region elt start end) - ;; if we've found a visible element, it must be earlier in - ;; current node's changeset; stop pulling elements (null - ;; `undo-list' and non-nil `got-visible-elt' cause loop to exit) - (if got-visible-elt - (setq undo-list nil) - ;; if we haven't found a visible element yet, pulling - ;; undo-in-region branch has failed - (setq region-changeset nil) - (throw 'abort t))) - - ;; if rejecting element, add its delta (if any) to the list - (t - (let ((delta (undo-delta elt))) - (when (/= 0 (cdr delta)) - (setcdr d (list delta)) - (setq d (cdr d)))) - (setq undo-list (cdr undo-list)))) - - ;; process next element of current changeset - (setq elt (cadr undo-list))) - - ;; if there are remaining elements in changeset, remove dummy nil - ;; from front - (if (cadr (undo-tree-node-undo fragment)) - (pop (undo-tree-node-undo fragment)) - ;; otherwise, if we've kept all elements in changeset, discard - ;; empty changeset - (when (eq splice fragment) (setq splice nil)) - (setq fragment (car (undo-tree-node-next fragment)))) - ;; process changeset from next node up the tree - (setq node (undo-tree-node-previous node)))) - - ;; pop dummy nil from front of `region-changeset' - (pop region-changeset) - - - ;; --- integrate branch into tree --- - ;; if no undo-in-region elements were found, restore undo tree - (if (null region-changeset) - (when original-current - (push original-fragment (undo-tree-node-next original-splice)) - (setf (undo-tree-node-branch original-splice) 0 - (undo-tree-node-previous original-fragment) original-splice) - (let ((mark-active nil)) - (while (not (eq (undo-tree-current buffer-undo-tree) - original-current)) - (undo-tree-redo))) - nil) ; return nil to indicate failure - - ;; otherwise... - ;; need to undo up to node where new branch will be attached, to - ;; ensure redo entries are populated, and then redo back to where we - ;; started - (let ((mark-active nil) - (current (undo-tree-current buffer-undo-tree))) - (while (not (eq (undo-tree-current buffer-undo-tree) node)) - (undo-tree-undo)) - (while (not (eq (undo-tree-current buffer-undo-tree) current)) - (undo-tree-redo))) - - (cond - ;; if there's no remaining fragment, just create undo-in-region node - ;; and attach it to parent of last node from which elements were - ;; pulled - ((null fragment) - (setq fragment (make-undo-tree-node node region-changeset)) - (push fragment (undo-tree-node-next node)) - (setf (undo-tree-node-branch node) 0) - ;; set current node to undo-in-region node - (setf (undo-tree-current buffer-undo-tree) fragment)) - - ;; if no splice point has been set, add undo-in-region node to top of - ;; fragment and attach it to parent of last node from which elements - ;; were pulled - ((null splice) - (setq fragment (undo-tree-grow-backwards fragment region-changeset)) - (push fragment (undo-tree-node-next node)) - (setf (undo-tree-node-branch node) 0 - (undo-tree-node-previous fragment) node) - ;; set current node to undo-in-region node - (setf (undo-tree-current buffer-undo-tree) fragment)) - - ;; if fragment contains nodes, attach fragment to parent of last node - ;; from which elements were pulled, and splice in undo-in-region node - (t - (setf (undo-tree-node-previous fragment) node) - (push fragment (undo-tree-node-next node)) - (setf (undo-tree-node-branch node) 0) - ;; if this is a repeated undo-in-region, then we've left the current - ;; node at the original splice-point; we need to set the current - ;; node to the equivalent node on the undo-in-region branch and redo - ;; back to where we started - (when repeated-undo-in-region - (setf (undo-tree-current buffer-undo-tree) - (undo-tree-node-previous original-fragment)) - (let ((mark-active nil)) - (while (not (eq (undo-tree-current buffer-undo-tree) splice)) - (undo-tree-redo nil 'preserve-undo)))) - ;; splice new undo-in-region node into fragment - (setq node (make-undo-tree-node nil region-changeset)) - (undo-tree-splice-node node splice) - ;; set current node to undo-in-region node - (setf (undo-tree-current buffer-undo-tree) node))) - - ;; update undo-tree size - (setq node (undo-tree-node-previous fragment)) - (while (progn - (and (setq node (car (undo-tree-node-next node))) - (not (eq node original-fragment)) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-undo node))) - (when (undo-tree-node-redo node) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-redo node)))) - ))) - t) ; indicate undo-in-region branch was successfully pulled - ))) - - - -(defun undo-tree-pull-redo-in-region-branch (start end) - ;; Pull out entries from redo changesets to create a new redo-in-region - ;; branch, which redoes changeset entries lying between START and END first, - ;; followed by remaining entries from the changesets. Repeated calls will, - ;; if appropriate, extend the current redo-in-region branch rather than - ;; creating a new one. - - ;; if we're just reverting the last undo-in-region, we don't need to - ;; manipulate the undo tree at all - (if (undo-tree-reverting-undo-in-region-p start end) - t ; return t to indicate success - - ;; We build the `region-changeset' and `delta-list' lists forwards, using - ;; pointers `r' and `d' to the penultimate element of the list. So that we - ;; don't have to treat the first element differently, we prepend a dummy - ;; leading nil to the lists, and have the pointers point to that - ;; initially. - ;; Note: using '(nil) instead of (list nil) in the `let*' causes bizarre - ;; errors when the code is byte-compiled, where parts of the lists - ;; appear to survive across different calls to this function. An - ;; obscure byte-compiler bug, perhaps? - (let* ((region-changeset (list nil)) - (r region-changeset) - (delta-list (list nil)) - (d delta-list) - (node (undo-tree-current buffer-undo-tree)) - (repeated-redo-in-region - (undo-tree-repeated-redo-in-region-p start end)) - undo-adjusted-markers ; `undo-elt-in-region' expects this - fragment splice got-visible-elt redo-list elt) - - ;; --- inisitalisation --- - (cond - ;; if this is a repeated redo-in-region, detach fragment below current - ;; node - (repeated-redo-in-region - (when (setq fragment (car (undo-tree-node-next node))) - (setf (undo-tree-node-previous fragment) nil - (undo-tree-node-next node) - (delq fragment (undo-tree-node-next node))))) - ;; if this is a new redo-in-region, initial fragment is a copy of all - ;; nodes below the current one in the active branch - ((undo-tree-node-next node) - (setq fragment (make-undo-tree-node nil nil) - splice fragment) - (while (setq node (nth (undo-tree-node-branch node) - (undo-tree-node-next node))) - (push (make-undo-tree-node - splice nil - (undo-copy-list (undo-tree-node-redo node))) - (undo-tree-node-next splice)) - (setq splice (car (undo-tree-node-next splice)))) - (setq fragment (car (undo-tree-node-next fragment))))) - - - ;; --- pull redo-in-region elements into branch --- - ;; work down fragment, pulling out redo elements within region until - ;; we've got one that redoes a visible change (insertion or deletion) - (setq node fragment) - (catch 'abort - (while (and (not got-visible-elt) node (undo-tree-node-redo node)) - ;; we cons a dummy nil element on the front of the changeset so that - ;; we can conveniently remove the first (real) element from the - ;; changeset if we need to; the leading nil is removed once we're - ;; done with this changeset - (setq redo-list (push nil (undo-tree-node-redo node)) - elt (cadr redo-list)) - (while elt - (cond - ;; keep elements within region - ((undo-elt-in-region elt start end) - ;; set flag if kept element is visible (insertion or deletion) - (when (and (consp elt) - (or (stringp (car elt)) (integerp (car elt)))) - (setq got-visible-elt t)) - ;; adjust buffer positions in elements previously redone before - ;; kept element, as kept element will now be redone first - (undo-tree-adjust-elements-to-elt fragment elt t) - ;; move kept element to redo-in-region changeset, adjusting its - ;; buffer position as it will now be redone first - (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list) -1))) - (setq r (cdr r)) - (setcdr redo-list (cddr redo-list))) - - ;; discard "was unmodified" elements - ;; FIXME: deal properly with these - ((and (consp elt) (eq (car elt) t)) - (setcdr redo-list (cddr redo-list))) - - ;; if element crosses region, we can't pull any more elements - ((undo-elt-crosses-region elt start end) - ;; if we've found a visible element, it must be earlier in - ;; current node's changeset; stop pulling elements (null - ;; `redo-list' and non-nil `got-visible-elt' cause loop to exit) - (if got-visible-elt - (setq redo-list nil) - ;; if we haven't found a visible element yet, pulling - ;; redo-in-region branch has failed - (setq region-changeset nil) - (throw 'abort t))) - - ;; if rejecting element, add its delta (if any) to the list - (t - (let ((delta (undo-delta elt))) - (when (/= 0 (cdr delta)) - (setcdr d (list delta)) - (setq d (cdr d)))) - (setq redo-list (cdr redo-list)))) - - ;; process next element of current changeset - (setq elt (cadr redo-list))) - - ;; if there are remaining elements in changeset, remove dummy nil - ;; from front - (if (cadr (undo-tree-node-redo node)) - (pop (undo-tree-node-undo node)) - ;; otherwise, if we've kept all elements in changeset, discard - ;; empty changeset - (if (eq fragment node) - (setq fragment (car (undo-tree-node-next fragment))) - (undo-tree-snip-node node))) - ;; process changeset from next node in fragment - (setq node (car (undo-tree-node-next node))))) - - ;; pop dummy nil from front of `region-changeset' - (pop region-changeset) - - - ;; --- integrate branch into tree --- - (setq node (undo-tree-current buffer-undo-tree)) - ;; if no redo-in-region elements were found, restore undo tree - (if (null (car region-changeset)) - (when (and repeated-redo-in-region fragment) - (push fragment (undo-tree-node-next node)) - (setf (undo-tree-node-branch node) 0 - (undo-tree-node-previous fragment) node) - nil) ; return nil to indicate failure - - ;; otherwise, add redo-in-region node to top of fragment, and attach - ;; it below current node - (setq fragment - (if fragment - (undo-tree-grow-backwards fragment nil region-changeset) - (make-undo-tree-node nil nil region-changeset))) - (push fragment (undo-tree-node-next node)) - (setf (undo-tree-node-branch node) 0 - (undo-tree-node-previous fragment) node) - ;; update undo-tree size - (unless repeated-redo-in-region - (setq node fragment) - (while (progn - (and (setq node (car (undo-tree-node-next node))) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size - (undo-tree-node-redo node))))))) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-redo fragment))) - t) ; indicate undo-in-region branch was successfully pulled - ))) - - - -(defun undo-tree-adjust-elements-to-elt (node undo-elt &optional below) - "Adjust buffer positions of undo elements, starting at NODE's -and going up the tree (or down the active branch if BELOW is -non-nil) and through the nodes' undo elements until we reach -UNDO-ELT. UNDO-ELT must appear somewhere in the undo changeset -of either NODE itself or some node above it in the tree." - (let ((delta (list (undo-delta undo-elt))) - (undo-list (undo-tree-node-undo node))) - ;; adjust elements until we reach UNDO-ELT - (while (and (car undo-list) - (not (eq (car undo-list) undo-elt))) - (setcar undo-list - (undo-tree-apply-deltas (car undo-list) delta -1)) - ;; move to next undo element in list, or to next node if we've run out - ;; of elements - (unless (car (setq undo-list (cdr undo-list))) - (if below - (setq node (nth (undo-tree-node-branch node) - (undo-tree-node-next node))) - (setq node (undo-tree-node-previous node))) - (setq undo-list (undo-tree-node-undo node)))))) - - - -(defun undo-tree-apply-deltas (undo-elt deltas &optional sgn) - ;; Apply DELTAS in order to UNDO-ELT, multiplying deltas by SGN - ;; (only useful value for SGN is -1). - (let (position offset) - (dolist (delta deltas) - (setq position (car delta) - offset (* (cdr delta) (or sgn 1))) - (cond - ;; POSITION - ((integerp undo-elt) - (when (>= undo-elt position) - (setq undo-elt (- undo-elt offset)))) - ;; nil (or any other atom) - ((atom undo-elt)) - ;; (TEXT . POSITION) - ((stringp (car undo-elt)) - (let ((text-pos (abs (cdr undo-elt))) - (point-at-end (< (cdr undo-elt) 0))) - (if (>= text-pos position) - (setcdr undo-elt (* (if point-at-end -1 1) - (- text-pos offset)))))) - ;; (BEGIN . END) - ((integerp (car undo-elt)) - (when (>= (car undo-elt) position) - (setcar undo-elt (- (car undo-elt) offset)) - (setcdr undo-elt (- (cdr undo-elt) offset)))) - ;; (nil PROPERTY VALUE BEG . END) - ((null (car undo-elt)) - (let ((tail (nthcdr 3 undo-elt))) - (when (>= (car tail) position) - (setcar tail (- (car tail) offset)) - (setcdr tail (- (cdr tail) offset))))) - )) - undo-elt)) - - - -(defun undo-tree-repeated-undo-in-region-p (start end) - ;; Return non-nil if undo-in-region between START and END is a repeated - ;; undo-in-region - (let ((node (undo-tree-current buffer-undo-tree))) - (and (setq node - (nth (undo-tree-node-branch node) (undo-tree-node-next node))) - (eq (undo-tree-node-undo-beginning node) start) - (eq (undo-tree-node-undo-end node) end)))) - - -(defun undo-tree-repeated-redo-in-region-p (start end) - ;; Return non-nil if undo-in-region between START and END is a repeated - ;; undo-in-region - (let ((node (undo-tree-current buffer-undo-tree))) - (and (eq (undo-tree-node-redo-beginning node) start) - (eq (undo-tree-node-redo-end node) end)))) - - -;; Return non-nil if undo-in-region between START and END is simply -;; reverting the last redo-in-region -(defalias 'undo-tree-reverting-undo-in-region-p - 'undo-tree-repeated-undo-in-region-p) - - -;; Return non-nil if redo-in-region between START and END is simply -;; reverting the last undo-in-region -(defalias 'undo-tree-reverting-redo-in-region-p - 'undo-tree-repeated-redo-in-region-p) - - - - -;;; ===================================================================== -;;; Undo-tree commands - -(define-minor-mode undo-tree-mode - "Toggle undo-tree mode. -With no argument, this command toggles the mode. -A positive prefix argument turns the mode on. -A negative prefix argument turns it off. - -Undo-tree-mode replaces Emacs' standard undo feature with a more -powerful yet easier to use version, that treats the undo history -as what it is: a tree. - -The following keys are available in `undo-tree-mode': - - \\{undo-tree-map} - -Within the undo-tree visualizer, the following keys are available: - - \\{undo-tree-visualizer-map}" - - nil ; init value - undo-tree-mode-lighter ; lighter - undo-tree-map ; keymap - ;; if disabling `undo-tree-mode', rebuild `buffer-undo-list' from tree so - ;; Emacs undo can work - (unless undo-tree-mode - (undo-list-rebuild-from-tree) - (setq buffer-undo-tree nil))) - - -(defun turn-on-undo-tree-mode () - "Enable undo-tree-mode." - (undo-tree-mode 1)) - - -(define-globalized-minor-mode global-undo-tree-mode - undo-tree-mode turn-on-undo-tree-mode) - - - -(defun undo-tree-undo (&optional arg preserve-redo) - "Undo changes. -Repeat this command to undo more changes. -A numeric ARG serves as a repeat count. - -In Transient Mark mode when the mark is active, only undo changes -within the current region. Similarly, when not in Transient Mark -mode, just \\[universal-argument] as an argument limits undo to -changes within the current region. - -A non-nil PRESERVE-REDO causes the existing redo record to be -preserved, rather than replacing it with the new one generated by -undoing." - (interactive "*P") - ;; throw error if undo is disabled in buffer - (when (eq buffer-undo-list t) (error "No undo information in this buffer")) - - (let ((undo-in-progress t) - (undo-in-region (or (region-active-p) (and arg (not (numberp arg))))) - pos current) - ;; transfer entries accumulated in `buffer-undo-list' to - ;; `buffer-undo-tree' - (undo-list-transfer-to-tree) - - (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1)) - ;; check if at top of undo tree - (unless (undo-tree-node-previous (undo-tree-current buffer-undo-tree)) - (error "No further undo information")) - - ;; if region is active, or a non-numeric prefix argument was supplied, - ;; try to pull out a new branch of changes affecting the region - (when (and undo-in-region - (not (undo-tree-pull-undo-in-region-branch - (region-beginning) (region-end)))) - (error "No further undo information for region")) - - ;; remove any GC'd elements from node's undo list - (setq current (undo-tree-current buffer-undo-tree)) - (decf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-undo current))) - (setf (undo-tree-node-undo current) - (undo-list-clean-GCd-elts (undo-tree-node-undo current))) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-undo current))) - ;; undo one record from undo tree - (when undo-in-region - (setq pos (set-marker (make-marker) (point))) - (set-marker-insertion-type pos t)) - (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current))) - (undo-boundary) - - ;; if preserving old redo record, discard new redo entries that - ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd - ;; elements from node's redo list - (if preserve-redo - (progn - (undo-list-pop-changeset) - (decf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-redo current))) - (setf (undo-tree-node-redo current) - (undo-list-clean-GCd-elts (undo-tree-node-redo current))) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-redo current)))) - ;; otherwise, record redo entries that `primitive-undo' has added to - ;; `buffer-undo-list' in current node's redo record, replacing - ;; existing entry if one already exists - (when (undo-tree-node-redo current) - (decf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-redo current)))) - (setf (undo-tree-node-redo current) (undo-list-pop-changeset)) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-redo current)))) - - ;; rewind current node and update timestamp - (setf (undo-tree-current buffer-undo-tree) - (undo-tree-node-previous (undo-tree-current buffer-undo-tree)) - (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree)) - (current-time)) - - ;; if undoing-in-region, record current node, region and direction so we - ;; can tell if undo-in-region is repeated, and re-activate mark if in - ;; `transient-mark-mode'; if not, erase any leftover data - (if (not undo-in-region) - (undo-tree-node-clear-region-data current) - (goto-char pos) - ;; note: we deliberately want to store the region information in the - ;; node *below* the now current one - (setf (undo-tree-node-undo-beginning current) (region-beginning) - (undo-tree-node-undo-end current) (region-end)) - (set-marker pos nil))) - - ;; undo deactivates mark unless undoing-in-region - (setq deactivate-mark (not undo-in-region)) - ;; inform user if at branch point - (when (> (undo-tree-num-branches) 1) (message "Undo branch point!")))) - - - -(defun undo-tree-redo (&optional arg preserve-undo) - "Redo changes. A numeric ARG serves as a repeat count. - -In Transient Mark mode when the mark is active, only redo changes -within the current region. Similarly, when not in Transient Mark -mode, just \\[universal-argument] as an argument limits redo to -changes within the current region. - -A non-nil PRESERVE-UNDO causes the existing undo record to be -preserved, rather than replacing it with the new one generated by -redoing." - (interactive "p") - ;; throw error if undo is disabled in buffer - (when (eq buffer-undo-list t) (error "No undo information in this buffer")) - - (let ((undo-in-progress t) - (redo-in-region (or (region-active-p) (and arg (not (numberp arg))))) - pos current) - ;; transfer entries accumulated in `buffer-undo-list' to - ;; `buffer-undo-tree' - (undo-list-transfer-to-tree) - - (dotimes (i (or (and (numberp arg) (prefix-numeric-value arg)) 1)) - ;; check if at bottom of undo tree - (when (null (undo-tree-node-next (undo-tree-current buffer-undo-tree))) - (error "No further redo information")) - - ;; if region is active, or a non-numeric prefix argument was supplied, - ;; try to pull out a new branch of changes affecting the region - (when (and redo-in-region - (not (undo-tree-pull-redo-in-region-branch - (region-beginning) (region-end)))) - (error "No further redo information for region")) - - ;; advance current node - (setq current (undo-tree-current buffer-undo-tree) - current (setf (undo-tree-current buffer-undo-tree) - (nth (undo-tree-node-branch current) - (undo-tree-node-next current)))) - ;; remove any GC'd elements from node's redo list - (decf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-redo current))) - (setf (undo-tree-node-redo current) - (undo-list-clean-GCd-elts (undo-tree-node-redo current))) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-redo current))) - ;; redo one record from undo tree - (when redo-in-region - (setq pos (set-marker (make-marker) (point))) - (set-marker-insertion-type pos t)) - (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-redo current))) - (undo-boundary) - - ;; if preserving old undo record, discard new undo entries that - ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd - ;; elements from node's redo list - (if preserve-undo - (progn - (undo-list-pop-changeset) - (decf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-undo current))) - (setf (undo-tree-node-undo current) - (undo-list-clean-GCd-elts (undo-tree-node-undo current))) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-undo current)))) - ;; otherwise, record undo entries that `primitive-undo' has added to - ;; `buffer-undo-list' in current node's undo record, replacing - ;; existing entry if one already exists - (when (undo-tree-node-undo current) - (decf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-undo current)))) - (setf (undo-tree-node-undo current) (undo-list-pop-changeset)) - (incf (undo-tree-size buffer-undo-tree) - (undo-list-byte-size (undo-tree-node-undo current)))) - - ;; update timestamp - (setf (undo-tree-node-timestamp current) (current-time)) - - ;; if redoing-in-region, record current node, region and direction so we - ;; can tell if redo-in-region is repeated, and re-activate mark if in - ;; `transient-mark-mode' - (if (not redo-in-region) - (undo-tree-node-clear-region-data current) - (goto-char pos) - (setf (undo-tree-node-redo-beginning current) (region-beginning) - (undo-tree-node-redo-end current) (region-end)) - (set-marker pos nil))) - - ;; redo deactivates the mark unless redoing-in-region - (setq deactivate-mark (not redo-in-region)) - ;; inform user if at branch point - (when (> (undo-tree-num-branches) 1) (message "Undo branch point!")))) - - - -(defun undo-tree-switch-branch (branch) - "Switch to a different BRANCH of the undo tree. -This will affect which branch to descend when *redoing* changes -using `undo-tree-redo'." - (interactive (list (or (and prefix-arg (prefix-numeric-value prefix-arg)) - (and (not (eq buffer-undo-list t)) - (or (undo-list-transfer-to-tree) t) - (> (undo-tree-num-branches) 1) - (read-number - (format "Branch (0-%d): " - (1- (undo-tree-num-branches)))))))) - ;; throw error if undo is disabled in buffer - (when (eq buffer-undo-list t) (error "No undo information in this buffer")) - ;; sanity check branch number - (when (<= (undo-tree-num-branches) 1) (error "Not at undo branch point")) - (when (or (< branch 0) (> branch (1- (undo-tree-num-branches)))) - (error "Invalid branch number")) - ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' - (undo-list-transfer-to-tree) - ;; switch branch - (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) - branch)) - - -(defun undo-tree-set (node) - ;; Set buffer to state corresponding to NODE. Returns intersection point - ;; between path back from current node and path back from selected NODE. - (let ((path (make-hash-table :test 'eq)) - (n node)) - (puthash (undo-tree-root buffer-undo-tree) t path) - ;; build list of nodes leading back from selected node to root, updating - ;; branches as we go to point down to selected node - (while (progn - (puthash n t path) - (when (undo-tree-node-previous n) - (setf (undo-tree-node-branch (undo-tree-node-previous n)) - (undo-tree-position - n (undo-tree-node-next (undo-tree-node-previous n)))) - (setq n (undo-tree-node-previous n))))) - ;; work backwards from current node until we intersect path back from - ;; selected node - (setq n (undo-tree-current buffer-undo-tree)) - (while (not (gethash n path)) - (setq n (undo-tree-node-previous n))) - ;; ascend tree until intersection node - (while (not (eq (undo-tree-current buffer-undo-tree) n)) - (undo-tree-undo)) - ;; descend tree until selected node - (while (not (eq (undo-tree-current buffer-undo-tree) node)) - (undo-tree-redo)) - n)) ; return intersection node - - - -(defun undo-tree-save-state-to-register (register) - "Store current undo-tree state to REGISTER. -The saved state can be restored using -`undo-tree-restore-state-from-register'. -Argument is a character, naming the register." - (interactive "cUndo-tree state to register: ") - ;; throw error if undo is disabled in buffer - (when (eq buffer-undo-list t) (error "No undo information in this buffer")) - ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' - (undo-list-transfer-to-tree) - ;; save current node to REGISTER - (set-register register (undo-tree-current buffer-undo-tree)) - ;; record REGISTER in current node, for visualizer - (setf (undo-tree-node-register (undo-tree-current buffer-undo-tree)) - register)) - - - -(defun undo-tree-restore-state-from-register (register) - "Restore undo-tree state from REGISTER. -The state must be saved using `undo-tree-save-state-to-register'. -Argument is a character, naming the register." - (interactive "cRestore undo-tree state from register: ") - ;; throw error if undo is disabled in buffer, or if register doesn't contain - ;; an undo-tree node - (let ((node (get-register register))) - (cond - ((eq buffer-undo-list t) - (error "No undo information in this buffer")) - ((not (undo-tree-node-p node)) - (error "Register doesn't contain undo-tree state"))) - ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' - (undo-list-transfer-to-tree) - ;; restore buffer state corresponding to saved node - (undo-tree-set node))) - - - - -;;; ===================================================================== -;;; Undo-tree visualizer - -(defun undo-tree-visualize () - "Visualize the current buffer's undo tree." - (interactive) - (deactivate-mark) - ;; throw error if undo is disabled in buffer - (when (eq buffer-undo-list t) (error "No undo information in this buffer")) - ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' - (undo-list-transfer-to-tree) - ;; add hook to kill visualizer buffer if original buffer is changed - (add-hook 'before-change-functions 'undo-tree-kill-visualizer nil t) - ;; prepare *undo-tree* buffer, then draw tree in it - (let ((undo-tree buffer-undo-tree) - (buff (current-buffer)) - (display-buffer-mark-dedicated 'soft)) - (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) - (undo-tree-visualizer-mode) - (setq undo-tree-visualizer-parent-buffer buff) - (setq buffer-undo-tree undo-tree) - (setq buffer-read-only nil) - (undo-tree-draw-tree undo-tree) - (setq buffer-read-only t))) - - -(defun undo-tree-kill-visualizer (&rest dummy) - ;; Kill visualizer. Added to `before-change-functions' hook of original - ;; buffer when visualizer is invoked. - (unless undo-in-progress - (unwind-protect - (with-current-buffer undo-tree-visualizer-buffer-name - (undo-tree-visualizer-quit))))) - - - -(defun undo-tree-draw-tree (undo-tree) - ;; Draw UNDO-TREE in current buffer. - (erase-buffer) - (undo-tree-move-down 1) ; top margin - (undo-tree-clear-visualizer-data undo-tree) - (undo-tree-compute-widths undo-tree) - (undo-tree-move-forward - (max (/ (window-width) 2) - (+ (undo-tree-node-char-lwidth (undo-tree-root undo-tree)) - ;; add space for left part of left-most time-stamp - (if undo-tree-visualizer-timestamps 4 0) - 2))) ; left margin - ;; draw undo-tree - (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face) - (stack (list (undo-tree-root undo-tree))) - (n (undo-tree-root undo-tree))) - ;; link root node to its representation in visualizer - (unless (markerp (undo-tree-node-marker n)) - (setf (undo-tree-node-marker n) (make-marker)) - (set-marker-insertion-type (undo-tree-node-marker n) nil)) - (move-marker (undo-tree-node-marker n) (point)) - ;; draw nodes from stack until stack is empty - (while stack - (setq n (pop stack)) - (goto-char (undo-tree-node-marker n)) - (setq n (undo-tree-draw-subtree n nil)) - (setq stack (append stack n)))) - ;; highlight active branch - (goto-char (undo-tree-node-marker (undo-tree-root undo-tree))) - (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) - (undo-tree-highlight-active-branch (undo-tree-root undo-tree))) - ;; highlight current node - (undo-tree-draw-node (undo-tree-current undo-tree) 'current)) - - -(defun undo-tree-highlight-active-branch (node) - ;; Draw highlighted active branch below NODE in current buffer. - (let ((stack (list node))) - ;; link node to its representation in visualizer - (unless (markerp (undo-tree-node-marker node)) - (setf (undo-tree-node-marker node) (make-marker)) - (set-marker-insertion-type (undo-tree-node-marker node) nil)) - (move-marker (undo-tree-node-marker node) (point)) - ;; draw active branch - (while stack - (setq node (pop stack)) - (goto-char (undo-tree-node-marker node)) - (setq node (undo-tree-draw-subtree node 'active)) - (setq stack (append stack node))))) - - -(defun undo-tree-draw-node (node &optional current) - ;; Draw symbol representing NODE in visualizer. - (goto-char (undo-tree-node-marker node)) - ;; if displaying timestamps, represent node by timestamp - (if undo-tree-visualizer-timestamps - (progn - (backward-char 4) - (if current (undo-tree-insert ?*) (undo-tree-insert ? )) - (undo-tree-insert - (undo-tree-timestamp-to-string (undo-tree-node-timestamp node))) - (backward-char 5) - (move-marker (undo-tree-node-marker node) (point)) - (put-text-property (- (point) 3) (+ (point) 5) - 'undo-tree-node node)) - ;; represent node by differentl symbols, depending on whether it's the - ;; current node or is saved in a register - (let ((register (undo-tree-node-register node))) - (cond - (current - (let ((undo-tree-insert-face - (cons 'undo-tree-visualizer-current-face - (and (boundp 'undo-tree-insert-face) - (or (and (consp undo-tree-insert-face) - undo-tree-insert-face) - (list undo-tree-insert-face)))))) - (undo-tree-insert ?x))) - ((and register (eq node (get-register register))) - (let ((undo-tree-insert-face - (cons 'undo-tree-visualizer-register-face - (and (boundp 'undo-tree-insert-face) - (or (and (consp undo-tree-insert-face) - undo-tree-insert-face) - (list undo-tree-insert-face)))))) - (undo-tree-insert register))) - (t (undo-tree-insert ?o)))) - (backward-char 1) - (put-text-property (point) (1+ (point)) 'undo-tree-node node))) - - -(defun undo-tree-draw-subtree (node &optional active-branch) - ;; Draw subtree rooted at NODE. The subtree will start from point. - ;; If ACTIVE-BRANCH is non-nil, just draw active branch below NODE. - ;; If TIMESTAP is non-nil, draw time-stamps instead of "o" at nodes. - (let ((num-children (length (undo-tree-node-next node))) - node-list pos trunk-pos n) - ;; draw node itself - (undo-tree-draw-node node) - - (cond - ;; if we're at a leaf node, we're done - ((= num-children 0)) - - ;; if node has only one child, draw it (not strictly necessary to deal - ;; with this case separately, but as it's by far the most common case - ;; this makes the code clearer and more efficient) - ((= num-children 1) - (undo-tree-move-down 1) - (undo-tree-insert ?|) - (backward-char 1) - (undo-tree-move-down 1) - (undo-tree-insert ?|) - (backward-char 1) - (undo-tree-move-down 1) - (setq n (car (undo-tree-node-next node))) - ;; link next node to its representation in visualizer - (unless (markerp (undo-tree-node-marker n)) - (setf (undo-tree-node-marker n) (make-marker)) - (set-marker-insertion-type (undo-tree-node-marker n) nil)) - (move-marker (undo-tree-node-marker n) (point)) - ;; add next node to list of nodes to draw next - (push n node-list)) - - ;; if node had multiple children, draw branches - (t - (undo-tree-move-down 1) - (undo-tree-insert ?|) - (backward-char 1) - (setq trunk-pos (point)) - ;; left subtrees - (backward-char - (- (undo-tree-node-char-lwidth node) - (undo-tree-node-char-lwidth - (car (undo-tree-node-next node))))) - (setq pos (point)) - (setq n (cons nil (undo-tree-node-next node))) - (dotimes (i (/ num-children 2)) - (setq n (cdr n)) - (when (or (null active-branch) - (eq (car n) - (nth (undo-tree-node-branch node) - (undo-tree-node-next node)))) - (undo-tree-move-forward 2) - (undo-tree-insert ?_ (- trunk-pos pos 2)) - (goto-char pos) - (undo-tree-move-forward 1) - (undo-tree-move-down 1) - (undo-tree-insert ?/) - (backward-char 2) - (undo-tree-move-down 1) - ;; link node to its representation in visualizer - (unless (markerp (undo-tree-node-marker (car n))) - (setf (undo-tree-node-marker (car n)) (make-marker)) - (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) - (move-marker (undo-tree-node-marker (car n)) (point)) - ;; add node to list of nodes to draw next - (push (car n) node-list)) - (goto-char pos) - (undo-tree-move-forward - (+ (undo-tree-node-char-rwidth (car n)) - (undo-tree-node-char-lwidth (cadr n)) - undo-tree-visualizer-spacing 1)) - (setq pos (point))) - ;; middle subtree (only when number of children is odd) - (when (= (mod num-children 2) 1) - (setq n (cdr n)) - (when (or (null active-branch) - (eq (car n) - (nth (undo-tree-node-branch node) - (undo-tree-node-next node)))) - (undo-tree-move-down 1) - (undo-tree-insert ?|) - (backward-char 1) - (undo-tree-move-down 1) - ;; link node to its representation in visualizer - (unless (markerp (undo-tree-node-marker (car n))) - (setf (undo-tree-node-marker (car n)) (make-marker)) - (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) - (move-marker (undo-tree-node-marker (car n)) (point)) - ;; add node to list of nodes to draw next - (push (car n) node-list)) - (goto-char pos) - (undo-tree-move-forward - (+ (undo-tree-node-char-rwidth (car n)) - (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0) - undo-tree-visualizer-spacing 1)) - (setq pos (point))) - ;; right subtrees - (incf trunk-pos) - (dotimes (i (/ num-children 2)) - (setq n (cdr n)) - (when (or (null active-branch) - (eq (car n) - (nth (undo-tree-node-branch node) - (undo-tree-node-next node)))) - (goto-char trunk-pos) - (undo-tree-insert ?_ (- pos trunk-pos 1)) - (goto-char pos) - (backward-char 1) - (undo-tree-move-down 1) - (undo-tree-insert ?\\) - (undo-tree-move-down 1) - ;; link node to its representation in visualizer - (unless (markerp (undo-tree-node-marker (car n))) - (setf (undo-tree-node-marker (car n)) (make-marker)) - (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) - (move-marker (undo-tree-node-marker (car n)) (point)) - ;; add node to list of nodes to draw next - (push (car n) node-list)) - (when (cdr n) - (goto-char pos) - (undo-tree-move-forward - (+ (undo-tree-node-char-rwidth (car n)) - (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0) - undo-tree-visualizer-spacing 1)) - (setq pos (point)))) - )) - ;; return list of nodes to draw next - (nreverse node-list))) - - - -(defun undo-tree-node-char-lwidth (node) - ;; Return left-width of NODE measured in characters. - (if (= (length (undo-tree-node-next node)) 0) 0 - (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-lwidth node)) - (if (= (undo-tree-node-cwidth node) 0) - (1+ (/ undo-tree-visualizer-spacing 2)) 0)))) - - -(defun undo-tree-node-char-rwidth (node) - ;; Return right-width of NODE measured in characters. - (if (= (length (undo-tree-node-next node)) 0) 0 - (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-rwidth node)) - (if (= (undo-tree-node-cwidth node) 0) - (1+ (/ undo-tree-visualizer-spacing 2)) 0)))) - - -(defun undo-tree-insert (str &optional arg) - ;; Insert character or string STR ARG times, overwriting, and using - ;; `undo-tree-insert-face'. - (unless arg (setq arg 1)) - (when (characterp str) - (setq str (make-string arg str)) - (setq arg 1)) - (dotimes (i arg) (insert str)) - (setq arg (* arg (length str))) - (undo-tree-move-forward arg) - ;; make sure mark isn't active, otherwise `backward-delete-char' might - ;; delete region instead of single char if transient-mark-mode is enabled - (setq mark-active nil) - (backward-delete-char arg) - (when (boundp 'undo-tree-insert-face) - (put-text-property (- (point) arg) (point) 'face undo-tree-insert-face))) - - -(defun undo-tree-move-down (&optional arg) - ;; Move down, extending buffer if necessary. - (let ((row (line-number-at-pos)) - (col (current-column)) - line) - (unless arg (setq arg 1)) - (forward-line arg) - (setq line (line-number-at-pos)) - ;; if buffer doesn't have enough lines, add some - (when (/= line (+ row arg)) - (insert (make-string (- arg (- line row)) ?\n))) - (undo-tree-move-forward col))) - - -(defun undo-tree-move-forward (&optional arg) - ;; Move forward, extending buffer if necessary. - (unless arg (setq arg 1)) - (let ((n (- (line-end-position) (point)))) - (if (> n arg) - (forward-char arg) - (end-of-line) - (insert (make-string (- arg n) ? ))))) - - -(defun undo-tree-timestamp-to-string (timestamp) - ;; Convert TIMESTAMP to hh:mm:ss string. - (let ((time (decode-time timestamp))) - (format "%02d:%02d:%02d" (nth 2 time) (nth 1 time) (nth 0 time)))) - - - - -;;; ===================================================================== -;;; Visualizer mode commands - -(defun undo-tree-visualizer-mode () - "Major mode used in undo-tree visualizer. - -The undo-tree visualizer can only be invoked from a buffer in -which `undo-tree-mode' is enabled. The visualizer displays the -undo history tree graphically, and allows you to browse around -the undo history, undoing or redoing the corresponding changes in -the parent buffer. - -Within the undo-tree visualizer, the following keys are available: - - \\{undo-tree-visualizer-map}" - (interactive) - (setq major-mode 'undo-tree-visualizer-mode) - (setq mode-name "undo-tree-visualizer-mode") - (use-local-map undo-tree-visualizer-map) - (setq truncate-lines t) - (setq cursor-type nil) - (setq buffer-read-only t)) - - - -(defun undo-tree-visualize-undo (&optional arg) - "Undo changes. A numeric ARG serves as a repeat count." - (interactive "p") - (setq buffer-read-only nil) - (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) - (undo-tree-draw-node (undo-tree-current buffer-undo-tree))) - (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) - (deactivate-mark) - (unwind-protect - (undo-tree-undo arg) - (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) - (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current) - (setq buffer-read-only t))) - - -(defun undo-tree-visualize-redo (&optional arg) - "Redo changes. A numeric ARG serves as a repeat count." - (interactive "p") - (setq buffer-read-only nil) - (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) - (undo-tree-draw-node (undo-tree-current buffer-undo-tree))) - (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) - (deactivate-mark) - (unwind-protect - (undo-tree-redo arg) - (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) - (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) - (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current) - (setq buffer-read-only t))) - - -(defun undo-tree-visualize-switch-branch-right (arg) - "Switch to next branch of the undo tree. -This will affect which branch to descend when *redoing* changes -using `undo-tree-redo' or `undo-tree-visualizer-redo'." - (interactive "p") - ;; un-highlight old active branch below current node - (setq buffer-read-only nil) - (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) - (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face)) - (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree))) - ;; increment branch - (let ((branch (undo-tree-node-branch (undo-tree-current buffer-undo-tree)))) - (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) - (cond - ((>= (+ branch arg) (undo-tree-num-branches)) - (1- (undo-tree-num-branches))) - ((<= (+ branch arg) 0) 0) - (t (+ branch arg)))) - ;; highlight new active branch below current node - (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) - (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) - (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree))) - ;; re-highlight current node - (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current) - (setq buffer-read-only t))) - - -(defun undo-tree-visualize-switch-branch-left (arg) - "Switch to previous branch of the undo tree. -This will affect which branch to descend when *redoing* changes -using `undo-tree-redo' or `undo-tree-visualizer-redo'." - (interactive "p") - (undo-tree-visualize-switch-branch-right (- arg))) - - -(defun undo-tree-visualizer-quit () - "Quit the undo-tree visualizer." - (interactive) - (undo-tree-clear-visualizer-data buffer-undo-tree) - ;; remove kill visualizer hook from parent buffer - (unwind-protect - (with-current-buffer undo-tree-visualizer-parent-buffer - (remove-hook 'before-change-functions 'undo-tree-kill-visualizer t)) - (let ((parent undo-tree-visualizer-parent-buffer) - window) - (kill-buffer nil) - (if (setq window (get-buffer-window parent)) - (select-window window) - (switch-to-buffer parent))))) - - -(defun undo-tree-visualizer-set (&optional pos) - "Set buffer to state corresponding to undo tree node -at POS, or point if POS is nil." - (interactive) - (unless pos (setq pos (point))) - (let ((node (get-text-property pos 'undo-tree-node))) - (when node - ;; set parent buffer to state corresponding to node at POS - (set-buffer undo-tree-visualizer-parent-buffer) - (undo-tree-set node) - (set-buffer undo-tree-visualizer-buffer-name) - (setq buffer-read-only nil) - ;; re-draw undo tree - (undo-tree-draw-tree buffer-undo-tree) - (setq buffer-read-only t)))) - - -(defun undo-tree-visualizer-mouse-set (pos) - "Set buffer to state corresponding to undo tree node -at mouse event POS." - (interactive "@e") - (undo-tree-visualizer-set (event-start (nth 1 pos)))) - - -(defun undo-tree-visualizer-toggle-timestamps () - "Toggle display of time-stamps." - (interactive) - (setq undo-tree-visualizer-spacing - (if (setq undo-tree-visualizer-timestamps - (not undo-tree-visualizer-timestamps)) - ;; need sufficient space if TIMESTAMP is set - (max 9 (default-value 'undo-tree-visualizer-spacing)) - (default-value 'undo-tree-visualizer-spacing))) - ;; redraw tree - (setq buffer-read-only nil) - (undo-tree-draw-tree buffer-undo-tree) - (setq buffer-read-only t)) - - -(defun undo-tree-visualizer-scroll-left (&optional arg) - (interactive "p") - (scroll-right (or arg 1) t)) - - -(defun undo-tree-visualizer-scroll-right (&optional arg) - (interactive "p") - (scroll-left (or arg 1) t)) - - - - -;;; ===================================================================== -;;; Visualizer selection mode - -(defun undo-tree-visualizer-selection-mode () - "Major mode used to select nodes in undo-tree visualizer." - (interactive) - (setq major-mode 'undo-tree-visualizer-selection-mode) - (setq mode-name "undo-tree-visualizer-selection-mode") - (use-local-map undo-tree-visualizer-selection-map) - (setq cursor-type 'box)) - - -(defun undo-tree-visualizer-select-previous (&optional arg) - "Move to previous node." - (interactive "p") - (let ((node (get-text-property (point) 'undo-tree-node))) - (catch 'top - (dotimes (i arg) - (unless (undo-tree-node-previous node) (throw 'top t)) - (setq node (undo-tree-node-previous node)))) - (goto-char (undo-tree-node-marker node)))) - - -(defun undo-tree-visualizer-select-next (&optional arg) - "Move to next node." - (interactive "p") - (let ((node (get-text-property (point) 'undo-tree-node))) - (catch 'bottom - (dotimes (i arg) - (unless (nth (undo-tree-node-branch node) (undo-tree-node-next node)) - (throw 'bottom t)) - (setq node - (nth (undo-tree-node-branch node) (undo-tree-node-next node))))) - (goto-char (undo-tree-node-marker node)))) - - -(defun undo-tree-visualizer-select-right (&optional arg) - "Move right to a sibling node." - (interactive "p") - (let ((pos (point)) - (end (line-end-position)) - node) - (catch 'end - (dotimes (i arg) - (while (not node) - (forward-char) - (setq node (get-text-property (point) 'undo-tree-node)) - (when (= (point) end) (throw 'end t))))) - (goto-char (if node (undo-tree-node-marker node) pos)))) - - -(defun undo-tree-visualizer-select-left (&optional arg) - "Move left to a sibling node." - (interactive "p") - (let ((pos (point)) - (beg (line-beginning-position)) - node) - (catch 'beg - (dotimes (i arg) - (while (not node) - (backward-char) - (setq node (get-text-property (point) 'undo-tree-node)) - (when (= (point) beg) (throw 'beg t))))) - (goto-char (if node (undo-tree-node-marker node) pos)))) - - - -(provide 'undo-tree) - -;;; undo-tree.el ends here -- cgit v1.0