From 1f5d3b70abe61bb50e846cde5eb1f9b25effc6e2 Mon Sep 17 00:00:00 2001 From: Phillip Lord Date: Sat, 6 May 2017 21:58:52 +0100 Subject: [PATCH] Add test framework --- lisp/emacs-lisp/assess/assess-call.el | 115 ++ lisp/emacs-lisp/assess/assess-discover.el | 87 ++ lisp/emacs-lisp/assess/assess-robot.el | 111 ++ lisp/emacs-lisp/assess/assess.el | 1176 ++++++++++++++++++++ lisp/emacs-lisp/m-buffer/m-buffer-at.el | 89 ++ lisp/emacs-lisp/m-buffer/m-buffer-macro.el | 123 ++ lisp/emacs-lisp/m-buffer/m-buffer-pkg.el | 2 + lisp/emacs-lisp/m-buffer/m-buffer.el | 984 ++++++++++++++++ test/lisp/tutorial-tests.el | 43 + 9 files changed, 2730 insertions(+) create mode 100644 lisp/emacs-lisp/assess/assess-call.el create mode 100644 lisp/emacs-lisp/assess/assess-discover.el create mode 100644 lisp/emacs-lisp/assess/assess-robot.el create mode 100644 lisp/emacs-lisp/assess/assess.el create mode 100644 lisp/emacs-lisp/m-buffer/m-buffer-at.el create mode 100644 lisp/emacs-lisp/m-buffer/m-buffer-macro.el create mode 100644 lisp/emacs-lisp/m-buffer/m-buffer-pkg.el create mode 100644 lisp/emacs-lisp/m-buffer/m-buffer.el create mode 100644 test/lisp/tutorial-tests.el diff --git a/lisp/emacs-lisp/assess/assess-call.el b/lisp/emacs-lisp/assess/assess-call.el new file mode 100644 index 00000000000..78d61740a74 --- /dev/null +++ b/lisp/emacs-lisp/assess/assess-call.el @@ -0,0 +1,115 @@ +;;; assess-call.el --- Call and Return -*- lexical-binding: t -*- + +;;; Header: + +;; This file is not part of Emacs + +;; Author: Phillip Lord +;; Maintainer: Phillip Lord + +;; The contents of this file are subject to the GPL License, Version 3.0. + +;; Copyright (C) 2016, Phillip Lord + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Capture calls to functions, checking parameters and return values. + +;;; Code: + +;; ** Call Capture + +;; Here we provide a function for tracing calls to a particular function. This +;; can be a direct or indirect call; parameters and return values are available +;; for inspection afterwards. For example: + +;; #+begin_src elisp +;; (assess-call-capture +;; '+ +;; (lambda() +;; (+ 1 1))) +;; ;; => (((1 1) . 2)) +;; #+end_src + +;; The return value is a list of cons cells, one for each invocation, of the +;; parameters and return values. + + +;; #+begin_src emacs-lisp +(defun assess-call--capture-lambda () + "Return function which captures args and returns of another. + +The returned function takes FN the function to call, and any +number of ARGS to call the function with. In the special case, +that FN is equal to `:return`, then all previous args and return +values of FN are returned instead." + (let ((capture-store nil)) + (lambda (fn &rest args) + (if (eq fn :return) + capture-store + (let ((rtn (apply fn args))) + (setq capture-store + (cons (cons args rtn) + capture-store)) + rtn))))) + +(defun assess-call-capture (sym-fn fn) + "Trace all calls to SYM-FN when FN is called with no args. + +The return value is a list of cons cells, with car being the +parameters of the calls, and the cdr being the return value." + (let ((capture-lambda + (assess-call--capture-lambda))) + (unwind-protect + (progn (advice-add sym-fn :around capture-lambda) + (funcall fn) + (funcall capture-lambda :return)) + (advice-remove sym-fn capture-lambda)))) + +(defun assess-call--hook-capture-lambda () + "Returns a function which captures all of its args. + +The returned function takes any number of ARGS. In the special +case that the first arg is `:return` then it returns all previous +args." + (let ((capture-store nil)) + (lambda (&rest args) + (if (eq (car-safe args) :return) + capture-store + (setq capture-store + (cons + args + capture-store)))))) + +(defun assess-call-capture-hook (hook-var fn &optional append local) + "Trace all calls to HOOK-VAR when FN is called with no args. +APPEND and LOCAL are passed to `add-hook` and documented there." + (let ((capture-lambda + (assess-call--hook-capture-lambda))) + (unwind-protect + (progn + (add-hook hook-var + capture-lambda + append local) + (funcall fn) + (funcall capture-lambda :return)) + (remove-hook hook-var + capture-lambda + local)))) + +(provide 'assess-call) +;;; assess-call.el ends here +;; #+end_src diff --git a/lisp/emacs-lisp/assess/assess-discover.el b/lisp/emacs-lisp/assess/assess-discover.el new file mode 100644 index 00000000000..51cabb2bbea --- /dev/null +++ b/lisp/emacs-lisp/assess/assess-discover.el @@ -0,0 +1,87 @@ +;;; assess-discover.el --- Test support functions -*- lexical-binding: t -*- + +;;; Header: + +;; This file is not part of Emacs + +;; Author: Phillip Lord +;; Maintainer: Phillip Lord + +;; The contents of this file are subject to the GPL License, Version 3.0. + +;; Copyright (C) 2015, 2016, Phillip Lord + +;; 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 . + +;;; Code: + + +;; #+begin_src emacs-lisp +(defun assess-discover-tests (directory) + "Discover tests in directory. + +Tests must conform to one (and only one!) of several naming +schemes. + + - End with -test.el + - End with -tests.el + - Start with test- + - Any .el file in a directory called test + - Any .el file in a directory called tests + +Each of these is tried until one matches. So, a top-level file +called \"blah-test.el\" will prevent discovery of files in a +tests directory." + (or + ;; files with + (directory-files directory nil ".*-test.el$") + (directory-files directory nil ".*-tests.el$") + (directory-files directory nil "test-.*.el$") + (let ((dir-test + (concat directory "test/"))) + (when (file-exists-p dir-test) + (mapcar + (lambda (file) + (concat dir-test file)) + (directory-files dir-test nil ".*.el")))) + (let ((dir-tests + (concat directory "tests/"))) + (when (file-exists-p dir-tests) + (mapcar + (lambda (file) + (concat dir-tests file)) + (directory-files dir-tests nil ".*.el")))))) + +(defun assess-discover--load-all-tests (directory) + (mapc + 'load + (assess-discover-tests directory))) + +(defun assess-discover-load-tests () + (interactive) + (assess-discover--load-all-tests default-directory)) + +;;;###autoload +(defun assess-discover-run-batch (&optional selector) + (assess-discover--load-all-tests default-directory) + (ert-run-tests-batch selector)) + +;;;###autoload +(defun assess-discover-run-and-exit-batch (&optional selector) + (assess-discover--load-all-tests default-directory) + (ert-run-tests-batch-and-exit selector)) + +(provide 'assess-discover) +;;; assess-discover.el ends here +;; #+end_src diff --git a/lisp/emacs-lisp/assess/assess-robot.el b/lisp/emacs-lisp/assess/assess-robot.el new file mode 100644 index 00000000000..45ff0e2cbae --- /dev/null +++ b/lisp/emacs-lisp/assess/assess-robot.el @@ -0,0 +1,111 @@ +;;; assess-robot.el --- Test support functions -*- lexical-binding: t -*- + +;;; Header: + +;; This file is not part of Emacs + +;; Author: Phillip Lord +;; Maintainer: Phillip Lord +;; Version: 0.2 + +;; The contents of this file are subject to the GPL License, Version 3.0. + +;; Copyright (C) 2016, Phillip Lord + +;; 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 . + +;;; Code: +(defmacro assess-robot-with-switched-buffer (buffer &rest body) + "With BUFFER, evaluate BODY. + +This macro is rather like `with-current-buffer', except that it +uses `switch-to-buffer'. This is generally a bad idea when used +programmatically. But, it is necessary, for example, when using +keyboard macros." + (declare (indent 1) (debug t)) + (let ((before-buffer (make-symbol "before-buffer"))) + `(let ((,before-buffer (current-buffer))) + (unwind-protect + (progn + (switch-to-buffer ,buffer) + ,@body) + (switch-to-buffer ,before-buffer))))) + +(defmacro assess-robot-with-temp-switched-buffer (&rest body) + "Evaluate BODY in temporary buffer. + +As with `assess-robot-with-switched-buffer', `switch-to-buffer' +is used." + (declare (indent 0) (debug t)) + (let ((temp-buffer (make-symbol "temp-buffer"))) + `(let ((,temp-buffer (generate-new-buffer " *temp*"))) + (assess-robot-with-switched-buffer ,temp-buffer + (unwind-protect + (progn + ;; Enable the undo list because we want it for most robot + ;; situations. + (setq buffer-undo-list nil) + ,@body) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer))))))) + +(defmacro assess-robot-with-switched-buffer-string (&rest body) + "Evalate BODY in a temporary buffer and return buffer string. + +See also `assess-robot-with-temp-switched-buffer'." + (declare (debug t)) + `(assess-robot-with-temp-switched-buffer + (progn + ,@body + (buffer-substring-no-properties + (point-min) (point-max))))) + +(defun assess-robot-execute-kmacro (macro) + "Execute the MACRO. + +In this case, MACRO is the \"long form\" accepted by +`edit-kdb-macro'." + (let ((macro (read-kbd-macro macro))) + ;; I wanted to add a nice way to edit the macro, but sadly + ;; edit-kdb-macro provides no nice entry point. So, we take the nasty step + ;; of setting the last-kbd-macro instead. + (setq last-kbd-macro macro) + (execute-kbd-macro + (read-kbd-macro macro)))) + +(defun assess-robot-copy-and-finish () + "Copy the macro in edmacro to the kill-ring." + (interactive) + (save-excursion + (goto-char (point-min)) + (search-forward "Macro:") + (forward-line) + (let ((string + (buffer-substring-no-properties + (point) + (point-max)))) + (with-temp-buffer + (insert "\"") + (insert string) + (insert "\"") + (kill-ring-save (point-min) + (point-max)))) + (edmacro-finish-edit))) + +(eval-after-load + 'edmacro + '(define-key edmacro-mode-map (kbd "C-c C-k") 'assess-robot-copy-and-finish)) + +(provide 'assess-robot) +;;; assess-robot.el ends here diff --git a/lisp/emacs-lisp/assess/assess.el b/lisp/emacs-lisp/assess/assess.el new file mode 100644 index 00000000000..98668994579 --- /dev/null +++ b/lisp/emacs-lisp/assess/assess.el @@ -0,0 +1,1176 @@ +;;; assess.el --- Test support functions -*- lexical-binding: t -*- + +;;; Header: + +;; This file is not part of Emacs + +;; Author: Phillip Lord +;; Maintainer: Phillip Lord +;; Version: 0.4 +;; Package-Requires: ((emacs "24.1")(m-buffer "0.15")) + +;; The contents of this file are subject to the GPL License, Version 3.0. + +;; Copyright (C) 2015, 2016, Phillip Lord + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This file provides functions to support ert, the Emacs Regression Test +;; framework. It includes: + +;; - a set of predicates for comparing strings, buffers and file contents. +;; - explainer functions for all predicates giving useful output +;; - macros for creating many temporary buffers at once, and for restoring the +;; buffer list. +;; - methods for testing indentation, by comparison or "round-tripping". +;; - methods for testing fontification. + +;; Assess aims to be a stateless as possible, leaving Emacs unchanged whether +;; the tests succeed or fail, with respect to buffers, open files and so on; this +;; helps to keep tests independent from each other. Violations of this will be +;; considered a bug. + +;; Assess aims also to be as noiseless as possible, reducing and suppressing +;; extraneous messages where possible, to leave a clean ert output in batch mode. + + +;;; Status: + +;; Assess is currently a work in progress; the API is not currently stable. I +;; may also considering winding this into ert-x, because then it can be used +;; to test core. + +;; Assess used to be called sisyphus which seemed like a good idea when I +;; started, but I kept spelling it wrong. + + +;;; Code: + +;; ** Preliminaries + +;; #+begin_src emacs-lisp +(require 'pp) +(require 'ert) +(require 'm-buffer-at) +(require 'm-buffer) +(require 'seq) +;; #+end_src + +;; ** Advice + +;; Emacs-24 insists on printing out results on a single line with escaped +;; newlines. This does not work so well with the explainer functions in assess +;; and, probably, does not make sense anywhere. So, we advice here. The use of +;; nadvice.el limits this package to Emacs 24.4. Emacs 25 has this fixed. + +;; #+begin_src emacs-lisp +(when (fboundp 'advice-add) + + (defun assess--ert-pp-with-indentation-and-newline (orig object) + (let ((pp-escape-newlines nil)) + (funcall orig object))) + + (advice-add + 'ert--pp-with-indentation-and-newline + :around + #'assess--ert-pp-with-indentation-and-newline)) +;; #+end_src + +;; ** Deliberate Errors + +;; Sometimes during testing, we need to throw an "error" deliberately. Assess' +;; own test cases do this to check that state is preserved with this form of +;; non-local exit. Throwing `error' itself is a bit dangerous because we might +;; get that for other reasons; so we create a new symbol here for general use. + +;; #+begin_src emacs-lisp +(if (fboundp 'define-error) + (define-error 'assess-deliberate-error + "An error deliberately caused during testing." + 'error) + (put 'assess-deliberate-error + 'error-conditions + '(error assess-deliberate-error)) + (put 'assess-deliberate-error + 'error-message + "A error deliberately caused during testing.")) +;; #+end_src + +;; ** Buffer creation + +;; For tests, it is often better to use temporary buffers, as it is much less +;; affected by the existing state of Emacs, and much less likely to affect future +;; state; this is particularly the case where tests are being developed as the +;; developer may be trying to change or write test files at the same time as +;; Emacs is trying to use them for testing. + +;; Emacs really only provides a single primitive `with-temp-buffer' for this +;; situation, and that only creates a single temporary buffer at a time. Nesting +;; of these forms sometimes works, but fails if we need to operate on two buffers +;; at once. + +;; So, we provide an environment for restoring the buffer list. This allows any +;; creation of buffers we need for testing, followed by clean up afterwards. For +;; example, a trivial usage would be to remove buffers explicitly created. + +;; #+begin_src elisp +;; (assess-with-preserved-buffer-list +;; (get-buffer-create "a") +;; (get-buffer-create "b") +;; (get-buffer-create "c")) +;; #+end_src + +;; Any buffer created in this scope is removed, whether this is as a direct or +;; indirect result of the function. For example, this usage creates a ~*Help*~ +;; buffer which then gets removed again. + +;; #+begin_src elisp +;; (assess-with-preserved-buffer-list +;; (describe-function 'self-insert-command)) +;; #+end_src + +;; This does not prevent changes to existing buffers of course. If ~*Help*~ is +;; already open before evaluation, it will remain open afterwards but with +;; different content. + +;; Sometimes, it is useful to create several temporary buffers at once. +;; `assess-with-temp-buffers' provides an easy mechanism for doing this, as +;; well as evaluating content in these buffers. For example, this returns true +;; (actually three killed buffers which were live when the `mapc' form runs). + +;; #+begin_src elisp +;; (assess-with-temp-buffers +;; (a b c) +;; (mapc #'buffer-live-p (list a b c))) +;; #+end_src + +;; While this creates two buffers, puts "hellogoodbye" into one and "goodbye" +;; into the other, then compares the contents of these buffers with `assess='. + +;; #+begin_src elisp +;; (assess-with-temp-buffers +;; ((a (insert "hello") +;; (insert "goodbye")) +;; (b (insert "goodbye"))) +;; (assess= a b)) +;; #+end_src + +;; Finally, we provide a simple mechanism for converting any assess type into a +;; buffer. The following form, for example, returns the contents of the ~.emacs~ +;; file. + +;; #+begin_src elisp +;; (assess-as-temp-buffer +;; (assess-file "~/.emacs") +;; (buffer-string)) +;; #+end_src + +;; *** Implementation + +;; #+begin_src emacs-lisp +(defmacro assess-with-preserved-buffer-list (&rest body) + "Evaluate BODY, but delete any buffers that have been created." + (declare (debug t)) + `(let ((before-buffer-list + (buffer-list))) + (unwind-protect + (progn + ,@body) + (seq-map + (lambda (it) + (with-current-buffer it + (set-buffer-modified-p nil) + (kill-buffer))) + (seq-difference (buffer-list) + before-buffer-list))))) + +(defun assess--temp-buffer-let-form (item) + (if (not (listp item)) + (assess--temp-buffer-let-form + (list item)) + `(,(car item) + (with-current-buffer + (generate-new-buffer " *assess-with-temp-buffers*") + ,@(cdr item) + (current-buffer))))) +;; #+end_src + +;; The implementation of `assess-with-temp-buffers' currently uses +;; `assess-with-preserved-buffer-list' to remove buffers which means that it +;; will also delete any buffers created by the user; this may be a mistake, and +;; it might be better to delete the relevant buffers explicitly. + +;; #+begin_src emacs-lisp +(defmacro assess-with-temp-buffers (varlist &rest body) + "Bind variables in varlist to temp buffers, then eval BODY. + +VARLIST is (nearly) of the same form as a `let' binding. Each +element is a symbol or a list (symbol valueforms). Each symbol is +bound to a buffer generated with `generate-new-buffer'. +VALUEFORMS are evaluated with the buffer current. Any buffers +created inside this form (and not just by this form!) are +unconditionally killed at the end of the form. + +Unlike `let' there can be multiple valueforms which are, +effectively, placed within an impicit `progn'." + (declare (indent 1) + (debug + ((&rest (symbolp &rest form)) + body))) + (let ((let-form + (seq-map + #'assess--temp-buffer-let-form + varlist))) + `(assess-with-preserved-buffer-list + (let* ,let-form + ,@body)))) + +(defmacro assess-as-temp-buffer (x &rest body) + "Insert X in a type-appropriate way into a temp buffer and eval +BODY there. + +See `assess-to-string' for the meaning of type-appropriate." + (declare (indent 1) (debug t)) + `(with-temp-buffer + (insert (assess-to-string ,x)) + ,@body)) +;; #+end_src + +;; ** Types + +;; Many tests on files or buffers actually end up being string comparison. +;; In many cases, we want to compare the *contents* of a buffer to, for example, +;; the *contents* of a file. + +;; Emacs normally uses strings to represent files (i.e. file names) and can also +;; use them to represent buffers (i.e. buffer names). So, here, we introduce a +;; set of "types" where so that we can distinguish between strings, buffer names +;; and file names, passing them at a single parameter. This will allow us to make +;; later parts of the API use overloaded methods based on their type. + +;; "Types" are either a Emacs core type (as with buffers and strings), or an 2 +;; element list (I haven't used cons cells in case I want to add more elements), +;; with a keyword at the head. This allows assess to distinguish between a +;; simple string and a file or buffer name. + +;; #+begin_src elisp +;; ;; Identify "~/.emacs" as a file name +;; (assess-file "~/.emacs") + +;; ;; Identify "*Messages*" as a buffer +;; (assess-buffer "*Messages*") +;; #+end_src + +;; *** Implementation + +;; #+begin_src emacs-lisp +(defun assess-to-string (x) + "Turn X into a string in a type appropriate way. + +If X is identified as a file, returns the file contents. +If X is identified as a buffer, returns the buffer contents. +If X is a string, returns that. + +See also `assess-buffer' and `assess-file' which turn a +string into something that will identified appropriately." + (pcase x + ((pred stringp) x) + ((pred bufferp) (m-buffer-at-string x)) + (`(:buffer ,b) (assess-to-string (get-buffer-create b))) + (`(:file ,f) + (with-temp-buffer + (insert-file-contents f) + (buffer-string))) + ;; error condition + (_ (error "Type not recognised")))) + +(defun assess-buffer (b) + "Add type data to the string B marking it as a buffer." + `(:buffer ,b)) + +(defun assess-file (f) + "Add type data to the string F marking it as a file." + `(:file ,f)) + +(defun assess-to-file-name (file) + "Return file name for FILE. + +FILE can be either a string, or a plist returned by +`assess-file' or `assess-make-related-file'." + (pcase file + ((pred stringp) file) + (`(:file ,f) f) + (_ (error "Type not recognised")))) +;; #+end_src + +;; ** Entity Comparison + +;; In this section, we provide support for comparing strings, buffer or file +;; contents. The main entry point is `assess=', which works like `string=' but +;; on any of the three data types, in any order. + +;; #+begin_src elisp +;; ;; Compare Two Strings +;; (assess= "hello" "goodbye") + +;; ;; Compare the contents of Two Buffers +;; (assess= +;; (assess-buffer "assess.el") +;; (assess-buffer "assess-previous.el")) + +;; ;; Compare the contents of Two files +;; (assess= +;; (assess-file "~/.emacs") +;; (assess-file "~/.emacs")) + +;; ;; We can use core Emacs types also +;; (assess= +;; (assess-buffer "assess.el") +;; (get-buffer "assess-previous.el")) + +;; ;; And in any combination; here we compare a string and the contents of a +;; ;; file. +;; (assess= +;; ";; This is an empty .emacs file" +;; (assess-file "~/.emacs")) +;; #+end_src + +;; In addition, `assess=' has an "explainer" function attached which produces a +;; richer output when `assess=' returns false, showing diffs of the string +;; comparison. Compare, for example, the results of running these two tests, one +;; using `string=' and one using `assess='. + +;; #+BEGIN_EXAMPLE +;; F temp +;; (ert-test-failed +;; ((should +;; (string= "a" "b")) +;; :form +;; (string= "a" "b") +;; :value nil)) + +;; F test-assess= +;; (ert-test-failed +;; ((should +;; (assess= "a" "b")) +;; :form +;; (assess= "a" "b") +;; :value nil :explanation "Strings: +;; a +;; and +;; b +;; Differ at:*** /tmp/a935uPW 2016-01-20 13:25:47.373076381 +0000 +;; --- /tmp/b9357Zc 2016-01-20 13:25:47.437076381 +0000 +;; *************** +;; *** 1 **** +;; ! a +;; \\ No newline at end of file +;; --- 1 ---- +;; ! b +;; \\ No newline at end of file + +;; ")) +;; #+END_EXAMPLE + +;; As `assess=' has a compatible interface with `string=' it is also possible +;; to add this explainer function to `string=' for use with tests which do not +;; otherwise use assess, like so: + +;; #+begin_src elisp +;; (put 'string= 'ert-explainer 'assess-explain=) +;; #+end_src + +;; Currently, `assess' uses the ~diff~ program to do the comparison if it is +;; available, or falls back to just reporting a difference -- this could do with +;; improving, but it is at least no worse than the existing behaviour for string +;; comparison. + +;; *** Implementation + +;; We start by writing a file silently -- this is important because the +;; ~*Messages*~ buffer should not be affected by the machinary of a failing test, +;; as it hides what is happening from the test code. + +;; #+begin_src emacs-lisp +(defun assess--write-file-silently (filename) + "Write current buffer into FILENAME. +Unlike most other ways of saving a file, this should not +print any messages!" + (write-region + (point-min) (point-max) + filename nil + 'dont-display-wrote-file-message)) +;; #+end_src + +;; Diff does a nicer comparison than anything in Emacs, although a lisp +;; implementation would have been more portable. Diff is used by quite a few +;; other tools in Emacs, so probably most people will have access to diff. + +;; #+begin_src emacs-lisp +(defun assess--explainer-diff-string= (a b) + "Compare strings A and B using diff output. + +We assume that diff exists. Temporary files are left +afterwards for cleanup by the operating system." + (assess-with-preserved-buffer-list + (let* ((diff + (executable-find "diff")) + (a-buffer + (generate-new-buffer "a")) + (b-buffer + (generate-new-buffer "b")) + (a-file + (make-temp-file + (buffer-name a-buffer))) + (b-file + (make-temp-file + (buffer-name b-buffer)))) + (with-current-buffer + a-buffer + (insert a) + (assess--write-file-silently a-file)) + (with-current-buffer + b-buffer + (insert b) + (assess--write-file-silently b-file)) + (progn + (format "Strings:\n%s\nand\n%s\nDiffer at:%s\n" + a b + (with-temp-buffer + (call-process + diff + ;; no infile + nil + ;; dump to current buffer + t + nil + "-c" + a-file + b-file) + (buffer-string))))))) + +(defun assess--explainer-simple-string= (a b) + "Compare strings for first difference." + ;; We could do a bit more here. + (format "String :%s:%s: are not equal." a b)) +;; #+end_src + +;; And the actual predicate function and explainer. We do a simple string +;; comparison on the contents of each entity. + +;; #+begin_src emacs-lisp +(defun assess= (a b) + "Compare A and B to see if they are the same. + +Equality in this sense means compare the contents in a way which +is appropriate for the type of the two arguments. So, if they are +strings, the compare strings, if buffers, then compare the buffer +contents and so on. + +Text properties in strings or buffers are ignored." + (string= + (assess-to-string a) + (assess-to-string b))) + +(defun assess-explain= (a b) + "Compare A and B and return an explanation. + +This function is called by ERT as an explainer function +automatically. See `assess=' for more information." + (let ((a (assess-to-string a)) + (b (assess-to-string b))) + (cond + ((assess= a b) + t) + ((executable-find "diff") + (assess--explainer-diff-string= a b)) + (t + (assess--explainer-simple-string= a b))))) + +(put 'assess= 'ert-explainer 'assess-explain=) +;; #+end_src + +;; ** Opening files + +;; Opening files presents a particular problem for testing, particularly if we +;; open a file that is already open in the same or a different Emacs. For batch +;; use of Emacs with parallelisation, the situation becomes intractable. + +;; A solution is to copy files before we open them, which means that they can be +;; changed freely. Largely, the copied file will behave the same as the main file; +;; the only notable exception to this is those features which depend on the +;; current working directory (dir-local variables, for example). + +;; ~assess-make-related-file~ provides a simple method for doing this. For +;; example, this form will return exactly the contents of ~my-test-file.el~, even +;; if that file is current open in the current Emacs (even if the buffer has not +;; been saved). Likewise, a test opening this file could be run in a batch Emacs +;; without interfering with an running interactive Emacs. + +;; #+begin_src elisp +;; (assess-as-temp-buffer +;; (assess-make-related-file "dev-resources/my-test-file.el") +;; (buffer-substring)) +;; #+end_src + +;; We also add support for opening a file, as if it where opened interactively, +;; with all the appropriate hooks being run, in the form of the +;; `assess-with-find-file' macro. Combined with `assess-make-related-file', +;; we can write the following expression without removing our ~.emacs~. + +;; #+begin_src elisp +;; (assess-with-find-file +;; (assess-make-related-file "~/.emacs") +;; (erase-buffer) +;; (save-buffer)) +;; #+end_src + +;; #+RESULTS: + +;; *** Implementation + +;; All of the functions here support the file type introduced earlier, but +;; interpret raw strings as a file also. + +;; #+begin_src emacs-lisp +(defun assess--make-related-file-1 (file &optional directory) + (make-temp-file + (concat + (or directory + temporary-file-directory) + (file-name-nondirectory file)) + nil + (concat "." + (file-name-extension file)))) + +(defun assess-make-related-file (file &optional directory) + "Open a copy of FILE in DIRECTORY. + +FILE is copied to a temporary file in DIRECTORY or +`temporary-file-directory'. The copy has a unique name but shares +the same file extension. + +This is useful for making test changes to FILE without actually +altering it." + (let* ((file (assess-to-file-name file)) + (related-file + (assess--make-related-file-1 file directory))) + (copy-file file related-file t) + (assess-file + related-file))) + +(defmacro assess-with-find-file (file &rest body) + "Open FILE and evaluate BODY in resultant buffer. + +FILE is opened with `find-file-noselect' so all the normal hooks +for file opening should occur. The buffer is killed after the +macro exits, unless it was already open. This happens +unconditionally, even if the buffer has changed. + +See also `assess-make-related-file'." + (declare (debug t) (indent 1)) + (let ((temp-buffer (make-symbol "temp-buffer")) + (file-has-buffer-p (make-symbol "file-has-buffer-p")) + (file-s (make-symbol "file"))) + `(let* ((,file-s ,file) + (,file-s (assess-to-file-name ,file-s)) + (,file-has-buffer-p + (find-buffer-visiting ,file-s)) + (,temp-buffer)) + (unwind-protect + (with-current-buffer + (setq ,temp-buffer + (find-file-noselect ,file-s)) + ,@body) + (when + ;; kill the buffer unless it was already open. + (and (not ,file-has-buffer-p) + (buffer-live-p ,temp-buffer)) + ;; kill unconditionally + (with-current-buffer ,temp-buffer + (set-buffer-modified-p nil)) + (kill-buffer ,temp-buffer)))))) +;; #+end_src + +;; ** Creating Files and Directories +;; I can write some documentation here if Phil wants to merge code below. +;; *** Implementation +;; #+BEGIN_SRC emacs-lisp +(defun assess-with-filesystem--make-parent (spec path) + "If SPEC is a file name, create its parent directory rooted at PATH." + (save-match-data + (when (string-match "\\(.*\\)/" spec) + (make-directory (concat path "/" (match-string 1 spec)) t)))) + +(defun assess-with-filesystem--init (spec &optional path) + "Interpret the SPEC inside PATH." + (setq path (or path ".")) + (cond + ((listp spec) + (cond + ;; non-empty file + ((and (stringp (car spec)) + (stringp (cadr spec))) + (when (string-match-p "/\\'" (car spec)) + (error "Invalid syntax: `%s' - cannot create a directory with text content" (car spec))) + (assess-with-filesystem--make-parent (car spec) path) + (with-temp-file (concat path "/" (car spec)) + (insert (cadr spec)))) + ;; directory + ((and (stringp (car spec)) + (consp (cadr spec))) + (make-directory (concat path "/" (car spec)) t) + (mapc (lambda (s) (assess-with-filesystem--init + s (concat path "/" (car spec)))) (cadr spec))) + ;; recursive spec, this should probably never happen + (t (mapc (lambda (s) (assess-with-filesystem--init s path)) spec)))) + ;; directory specified using a string + ((and (stringp spec) + (string-match-p "/\\'" spec)) + (make-directory (concat path "/" spec) t)) + ;; empty file + ((stringp spec) + (assess-with-filesystem--make-parent spec path) + (write-region "" nil (concat path "/" spec) nil 'no-message)) + (t (error "Invalid syntax: `%s'" spec)))) + +(defmacro assess-with-filesystem (spec &rest forms) + "Create temporary file hierarchy according to SPEC and run FORMS. + +SPEC is a list of specifications for file system entities which +are to be created. + +File system entities are specified as follows: + +1. a string FILE is the name of file to be created + - if the string contains \"/\", parent directories are created + automatically + - if the string ends with \"/\", a directory is created +2. a list of two elements (FILE CONTENT) specifies filename and the + content to put in the file + - the \"/\" rules apply in the same way as in 1., except you can not + create a directory this way +3. a list where car is a string and cadr is a list (DIR SPEC) is a + recursive specification evaluated with DIR as current directory + - the \"/\" rules apply in the same way as in 1., except you can not + create a file this way, a directory is always created + +An example showing all the possibilities: + + (\"empty_file\" + \"dir/empty_file\" + \"dir/subdir/\" + (\"non_empty_file\" \"content\") + (\"dir/anotherdir/non_empty_file\" \"tralala\") + (\"big_dir\" (\"empty_file\" + (\"non_empty_file\" \"content\") + \"subdir/empty_file\"))) + +If we want to run some code in a directory with an empty file +\"foo.txt\" present, we call: + + (assess-with-filesystem '(\"foo\") + (code-here) + (and-some-more-forms)) + +You should *not* depend on where exactly the hierarchy is created. +By default, a new directory in `temporary-file-directory' is +created and the specification is evaluated there, but this is up +for change." + (declare (indent 1)) + (let ((temp-root (make-symbol "temp-root")) + (old-dd (make-symbol "old-dd"))) + `(let ((,temp-root (make-temp-file "temp-fs-" t)) + (,old-dd default-directory)) + (unwind-protect + (progn + (setq default-directory ,temp-root) + (mapc (lambda (s) (assess-with-filesystem--init s ".")) ,spec) + ,@forms) + (delete-directory ,temp-root t) + (setq default-directory ,old-dd))))) +;; #+END_SRC +;; ** Indentation functions + +;; There are two main ways to test indentation -- we can either take unindented +;; text, indent it, and then compare it to something else; or, we can roundtrip +;; -- take indented code, unindent it, re-indent it again and see whether we end +;; up with what we started. Assess supports both of these. + +;; Additionally, there are two different ways to specific a mode -- we can either +;; define it explicitly or, if we are opening from a file, we can use the normal +;; `auto-mode-alist' functionality to determine the mode. Assess supports both +;; of these also. + +;; The simplest function is `assess-indentation=' which we can use as follows. +;; In this case, we have mixed a multi-line string and a single line with +;; control-n characters; this is partly to show that we can, and partly to make +;; sure that the code works both in an `org-mode' buffer and an ~*Org Src*~ buffer. + +;; #+begin_src elisp +;; (assess-indentation= +;; 'emacs-lisp-mode +;; "(assess-with-find-file +;; \"~/.emacs\" +;; (buffer-string))" +;; "(assess-with-find-file\n \"~/.emacs\"\n (buffer-string))") +;; #+end_src + +;; #+RESULTS: +;; : t + +;; Probably more useful is `assess-roundtrip-indentation=' which allows us to +;; just specify the indented form; in this case, the string is first unindented +;; (every line starts at the first position) and then reindented. This saves the +;; effort of keeping the text in both the indented and unindent forms in sync +;; (but without the indentation). + +;; #+begin_src elisp +;; (assess-roundtrip-indentation= +;; 'emacs-lisp-mode +;; "(assess-with-find-file\n \"~/.emacs\"\n (buffer-string))") +;; #+end_src + +;; #+RESULTS: +;; : t + +;; While these are useful for simple forms of indentation checking, they have +;; the significant problem of writing indented code inside an Emacs string. An +;; easier solution for longer pieces of code is to use +;; `assess-file-roundtrip-indentation='. This opens a file (safely using +;; `assess-make-related-file'), unindents, and reindents. The mode must be set +;; up automatically by the file type. + +;; #+begin_src elisp +;; (assess-file-roundtrip-indentation= +;; "assess.el") +;; #+end_src + +;; #+RESULTS: + +;; All of these methods are fully supported with ert explainer functions -- as +;; before they use diff where possible to compare the two forms. + + +;; *** Implementation + +;; We start with some functionality for making Emacs quiet while indenting, +;; otherwise we will get a large amount of spam on the command line. Emacs needs +;; to have a better technique for shutting up `message'. + +;; #+begin_src emacs-lisp +(defun assess--indent-buffer (&optional column) + (cond + (column + (indent-region (point-min) (point-max) column)) + ;; if indent-region-function is set, use it, and hope that it is not + ;; noisy. + (indent-region-function + (funcall indent-region-function (point-min) (point-max))) + (t + (seq-map + (lambda (m) + (goto-char m) + (indent-according-to-mode)) + (m-buffer-match-line-start (current-buffer)))))) + +(defun assess--indent-in-mode (mode unindented) + (with-temp-buffer + (insert + (assess-to-string unindented)) + (funcall mode) + (assess--indent-buffer) + (buffer-string))) +;; #+end_src + +;; Now for the basic indentation= comparison. + +;; #+begin_src emacs-lisp +(defun assess-indentation= (mode unindented indented) + "Return non-nil if UNINDENTED indents in MODE to INDENTED. +Both UNINDENTED and INDENTED can be any value usable by +`assess-to-string'. Indentation is performed using +`indent-region', which MODE should set up appropriately. + +See also `assess-file-roundtrip-indentation=' for an +alternative mechanism." + (assess= + (assess--indent-in-mode + mode + unindented) + indented)) + +(defun assess-explain-indentation= (mode unindented indented) + "Explanation function for `assess-indentation='." + (assess-explain= + (assess--indent-in-mode + mode + unindented) + indented)) + +(put 'assess-indentation= 'ert-explainer 'assess-explain-indentation=) +;; #+end_src + +;; Roundtripping. + +;; #+begin_src emacs-lisp +(defun assess--buffer-unindent (buffer) + (with-current-buffer + buffer + (assess--indent-buffer 0))) + +(defun assess--roundtrip-1 (comp mode indented) + (with-temp-buffer + (funcall comp + mode + (progn + (insert + (assess-to-string indented)) + (assess--buffer-unindent (current-buffer)) + (buffer-string)) + indented))) + +(defun assess-roundtrip-indentation= (mode indented) + "Return t if in MODE, text in INDENTED is corrected indented. + +This is checked by unindenting the text, then reindenting it according +to MODE. + +See also `assess-indentation=' and +`assess-file-roundtrip-indentation=' for alternative +mechanisms of checking indentation." + (assess--roundtrip-1 + #'assess-indentation= + mode indented)) + +(defun assess-explain-roundtrip-indentation= (mode indented) + "Explanation function for `assess-roundtrip-indentation='." + (assess--roundtrip-1 + #'assess-explain-indentation= + mode indented)) + +(put 'assess-roundtrip-indentation= + 'ert-explainer + 'assess-explain-roundtrip-indentation=) +;; #+end_src + +;; And file based checking. + +;; #+begin_src emacs-lisp +(defun assess--file-roundtrip-1 (comp file) + (funcall + comp + (assess-with-find-file + (assess-make-related-file file) + (assess--buffer-unindent (current-buffer)) + (assess--indent-buffer) + (buffer-string)) + file)) + +(defun assess-file-roundtrip-indentation= (file) + "Return t if text in FILE is indented correctly. + +FILE is copied with `assess-make-related-file', so this +function should be side-effect free whether or not FILE is +already open. The file is opened with `find-file-noselect', so +hooks associated with interactive visiting of a file should all +be called, with the exception of directory local variables, as +the copy of FILE will be in a different directory." + (assess--file-roundtrip-1 + #'assess= file)) + +(defun assess-explain-file-roundtrip-indentation= (file) + "Explanation function for `assess-file-roundtrip-indentation=." + (assess--file-roundtrip-1 + #'assess-explain= file)) + +(put 'assess-file-roundtrip-indentation= + 'ert-explainer + 'assess-explain-file-roundtrip-indentation=) +;; #+end_src + +;; ** Font-Lock + +;; Here we define two predicates that can be used to checking +;; fontification/syntax highlighting; as with indentation, one accepts strings +;; but requires an explicit mode, while the other reads from file and depends on +;; the normal Emacs mechanisms for defining the mode. These two are +;; `assess-font-at=' and `assess-file-font-at='. Both of these have the same +;; interface and have attached explainer functions. Here, we show examples with +;; `assess-face-at='. + +;; The simplest use is to specify a point location and a face. This returns true +;; if at least that face is present at the location. + +;; #+begin_src elisp +;; (assess-face-at= +;; "(defun x ())" +;; 'emacs-lisp-mode +;; 2 +;; 'font-lock-keyword-face) +;; #+end_src + +;; It is also possible to specify several locations in a list, with a single +;; face. This checks that the given font is present at every location. + +;; #+begin_src elisp +;; (assess-face-at= +;; "(defun x ()) +;; (defun y ()) +;; (defun z ())" +;; 'emacs-lisp-mode +;; '(2 15 28) +;; 'font-lock-keyword-face) +;; #+end_src + +;; Or, we can specify a list of faces in which case the locations and faces are +;; checked in a pairwise manner. + +;; #+begin_src elisp +;; (assess-face-at= +;; "(defun x ())" +;; 'emacs-lisp-mode +;; '(2 8) +;; '(font-lock-keyword-face font-lock-function-name-face)) +;; #+end_src + +;; It is also possible to define locations with regexps; again either one or +;; multiple regexps can be used. With a single string, all matches are checked, +;; with the first match to the first is checked, then the next match to the +;; second, incrementally. + +;; #+begin_src elisp +;; (assess-face-at= +;; "(defun x ())\n(defun y ())\n(defun z ())" +;; 'emacs-lisp-mode +;; "defun" +;; 'font-lock-keyword-face) + +;; (assess-face-at= +;; "(defun x ())\n(defmacro y ())\n(defun z ())" +;; 'emacs-lisp-mode +;; '("defun" "defmacro" "defun") +;; 'font-lock-keyword-face) +;; #+end_src + + +;; The locations can also be specified as a `lambda' which takes a single +;; argument of a buffer. The return result can be any form of location accepted +;; by `assess-face-at=', including a list of match data generated, as in this +;; case, by the `m-buffer' package. + +;; #+begin_src elisp +;; (assess-face-at= +;; "(defun x ())\n(defun y ())\n(defun z ())" +;; 'emacs-lisp-mode +;; (lambda(buf) +;; (m-buffer-match buf "defun")) +;; 'font-lock-keyword-face) +;; #+end_src + + +;; *** Implementation + +;; First, `assess-face-at='. + + +;; #+begin_src emacs-lisp +(defun assess--face-at-location= + (location face property throw-on-nil) + ;; it's match data + (if (listp location) + ;; We need to test every point but not the last because the match is + ;; passed the end. + (let ((all nil)) + (cl-loop for i from + (marker-position (car location)) + below + (marker-position (cadr location)) + do + (setq all + (cons (assess--face-at-location= + i face + property throw-on-nil) + all))) + (seq-every-p #'identity all)) + (let* ((local-faces + (get-text-property location property)) + (rtn + ;; for face this can be one of -- a face name (a symbol or string) + ;; a list of faces, or a plist of face attributes + (pcase local-faces + ;; compare directly + ((pred symbolp) + (eq face local-faces)) + ;; give up -- we should probably be able to compare the plists here. + ((and `(,s . ,_) + (guard (keywordp s))) + nil) + ;; compare that we have at least this. + ((and `(,s . ,_) + (guard (symbolp s))) + (member face s))))) + (if (and throw-on-nil + (not rtn)) + (throw + 'face-non-match + (format "Face does not match expected value +\tExpected: %s +\tActual: %s +\tLocation: %s +\tLine Context: %s +\tbol Position: %s +" + face local-faces location + (thing-at-point 'line) + (m-buffer-at-line-beginning-position + (current-buffer) location))) + rtn)))) + + +(defun assess--face-at= + (buffer locations faces property throw-on-nil) + (let* ( + ;; default property + (property (or property 'face)) + ;; make sure we have a list of locations + (locations + (pcase locations + ((pred functionp) + (funcall locations buffer)) + ((pred listp) + locations) + (_ (list locations)))) + (first-location + (car locations)) + ;; make sure we have a list of markers + (locations + (cond + ((integerp first-location) + (m-buffer-pos-to-marker buffer locations)) + ((stringp first-location) + (m-buffer-match-multi locations :buffer buffer)) + ;; markers + ((markerp first-location) + locations) + ;; match data + ((and (listp first-location) + (markerp (car first-location))) + locations))) + ;; make sure we have a list of faces + (faces + (if (and (listp faces) + ;; but not nil + (not (eq nil faces))) + faces + (list faces))) + ;; make sure faces is as long as locations + (faces + (progn + (while (> (length locations) + (length faces)) + ;; cycle faces if needed + (setq faces (append faces (seq-copy faces)))) + faces))) + (seq-every-p + (lambda (it) + (assess--face-at-location= + (car it) (cdr it) property throw-on-nil)) + (seq-mapn #'cons locations faces)))) + +(defun assess--face-at=-1 (x mode locations faces property throw-on-nil) + (with-temp-buffer + (insert (assess-to-string x)) + (funcall mode) + (font-lock-fontify-buffer) + (assess--face-at= (current-buffer) locations faces property throw-on-nil))) + +(defun assess-face-at= + (x mode locations faces &optional property) + "Return non-nil if in X with MODE at MARKERS, FACES are present on PROPERTY. + +This function tests if one or more faces are present at specific +locations in some text. It operates over single or multiple +values for both locations and faces; if there are more locations +than faces, then faces will be cycled over. If locations are +match data, then each the beginning and end of each match are +tested against each face. + +X can be a buffer, file name or string -- see +`assess-to-string' for details. + +MODE is the major mode with which to fontify X -- actually, it +will just be a function called to initialize the buffer. + +LOCATIONS can be either one or a list of the following things: +integer positions in X; markers in X (or nil!); match data in X; +or strings which match X. If this is a list, all items in list +should be of the same type. + +FACES can be one or more faces. + +PROPERTY is the text property on which to check the faces. + +See also `assess-to-string' for treatment of the parameter X. + +See `assess-file-face-at=' for a similar function which +operates over files and takes the mode from that file." + (assess--face-at=-1 x mode locations faces property nil)) + +(defun assess-explain-face-at= + (x mode locations faces &optional property) + (catch 'face-non-match + (assess--face-at=-1 x mode locations faces property t))) + +(put 'assess-face-at= + 'ert-explainer + 'assess-explain-face-at=) +;; #+end_src + +;; Followed by `assess-file-face-at='. + +;; #+begin_src emacs-lisp +(defun assess--file-face-at=-1 (file locations faces property throw-on-nil) + (assess-with-find-file + (assess-make-related-file file) + (font-lock-fontify-buffer) + (assess--face-at= (current-buffer) locations faces property throw-on-nil))) + +(defun assess-file-face-at= (file locations faces &optional property) + (assess--file-face-at=-1 file locations faces property nil)) + +(defun assess-explain-file-face-at= (file locations faces &optional property) + (catch 'face-non-match + (assess--file-face-at=-1 file locations faces property t))) + +(put 'assess-file-face-at= + 'ert-explainer + 'assess-explain-file-face-at=) +;; #+end_src + + +;; #+begin_src emacs-lisp +(defmacro assess-with-safe-user-directory (&rest body) + (declare (debug t)) + `(let ((user-emacs-directory (make-temp-file "emacs-assess" t))) + ,@body)) +;; #+end_src + + +;; #+begin_src emacs-lisp +(provide 'assess) +;;; assess.el ends here +;; #+end_src diff --git a/lisp/emacs-lisp/m-buffer/m-buffer-at.el b/lisp/emacs-lisp/m-buffer/m-buffer-at.el new file mode 100644 index 00000000000..c8799715747 --- /dev/null +++ b/lisp/emacs-lisp/m-buffer/m-buffer-at.el @@ -0,0 +1,89 @@ +;;; m-buffer-at.el --- Stateless point functions -*- lexical-binding: t -*- + +;;; Header: + +;; This file is not part of Emacs + +;; The contents of this file are subject to the GPL License, Version 3.0. + +;; Copyright (C) 2014, Phillip Lord, Newcastle University + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Provides stateless equivalents to many core Emacs functions, that provide +;; information about a buffer. Most of these functions take either a buffer as +;; a parameter or a location, which is either a marker (with a non-nil buffer +;; and location) or a buffer and integer. + +;; These functions are generally competitive with the originals in terms of +;; speed. + +;;; Status: + +;; There are lots more to do, but the interface should be stable. + +;;; Code: + +;; #+begin_src emacs-lisp + +(require 'm-buffer-macro) + +(defun m-buffer-at-point (buffer) + "Return the location of point in BUFFER. +See also `point'." + (with-current-buffer + buffer + (point))) + +(defun m-buffer-at-eolp (&rest location) + "Return t if LOCATION is at the end of a line. +See also `eolp'." + (m-buffer-with-current-location + location + (eolp))) + +(defun m-buffer-at-bolp (&rest location) + "Return t if LOCATION is at the begining of a line. +See also `bolp'" + (m-buffer-with-current-location + location + (bolp))) + +(defun m-buffer-at-line-beginning-position (&rest location) + "Return the start of the line of LOCATION." + (m-buffer-with-current-location + location + (line-beginning-position))) + +(defun m-buffer-at-line-end-position (&rest location) + "Return the end of the line of LOCATION." + (m-buffer-with-current-location + location + (line-end-position))) + +(defun m-buffer-at-narrowed-p (buffer) + (with-current-buffer + buffer + (buffer-narrowed-p))) + +(defun m-buffer-at-string (buffer) + (with-current-buffer + buffer + (buffer-string))) + +(provide 'm-buffer-at) +;;; m-buffer-at.el ends here +;; #+end_src diff --git a/lisp/emacs-lisp/m-buffer/m-buffer-macro.el b/lisp/emacs-lisp/m-buffer/m-buffer-macro.el new file mode 100644 index 00000000000..d716ee5bb8c --- /dev/null +++ b/lisp/emacs-lisp/m-buffer/m-buffer-macro.el @@ -0,0 +1,123 @@ +;;; m-buffer-macro.el --- Create and dispose of markers -*- lexical-binding: t -*- + +;;; Header: + +;; This file is not part of Emacs + +;; The contents of this file are subject to the GPL License, Version 3.0. + +;; Copyright (C) 2014, Phillip Lord, Newcastle University + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This file provides some utility macros which help to support stateless +;; operation on buffers, by restoring global state after to what it was before +;; the macro starts. + +;; These macros are quite useful, but with the exception of +;; `m-buffer-with-markers', they are mostly meant to underpin `m-buffer-at'. The +;; aim is that all the cases where one of these macros is used with a single form +;; from core Emacs should be provided by m-buffer-at (although this is not the +;; case yet). These macros might be more efficient if there are a lot of calls to +;; group together. + +;;; Code: + +;; ** Markers + +;; Markers are generally much nicer than integers, but needs cleaning up +;; afterwards if a lot are created. It's possible to do this using +;; `m-buffer-nil-marker', but it can be a bit painful. This form looks like a +;; `let' form, but removes markers at the end. + +;; #+begin_src emacs-lisp +(defmacro m-buffer-with-markers (varlist &rest body) + "Bind variables after VARLIST then eval BODY. +VARLIST is of the same form as `let'. All variables should +contain markers or collections of markers. All markers are niled +after BODY." + ;; indent let part specially, and debug like let + (declare (indent 1)(debug let)) + ;; so, create a rtn var with make-symbol (for hygene) + (let* ((rtn-var (make-symbol "rtn-var")) + (marker-vars + (mapcar 'car varlist)) + (full-varlist + (append + varlist + `((,rtn-var + (progn + ,@body)))))) + `(let* ,full-varlist + (m-buffer-nil-marker + (list ,@marker-vars)) + ,rtn-var))) +;; #+end_src + +;; ** Point and Buffer + +;; These macros are extensions of `with-current-buffer', and `save-excursion', +;; which set the current buffer and location. + +;; #+begin_src emacs-lisp +(defmacro m-buffer-with-current-marker + (marker &rest body) + "At MARKER location run BODY." + (declare (indent 1) (debug t)) + `(with-current-buffer + (marker-buffer ,marker) + (save-excursion + (goto-char ,marker) + ,@body))) + +(defmacro m-buffer-with-current-position + (buffer location &rest body) + "In BUFFER at LOCATION, run BODY." + (declare (indent 2) + (debug t)) + `(with-current-buffer + ,buffer + (save-excursion + (goto-char ,location) + ,@body))) +;; #+end_src + +;; Combines the last two! + +;; #+begin_src emacs-lisp +(defmacro m-buffer-with-current-location + (location &rest body) + "At LOCATION, run BODY. +LOCATION should be a list. If a one element list, it is a marker. +If a two element, it is a buffer and position." + (declare (indent 1) (debug t)) + ;; multiple eval of location! + (let ((loc (make-symbol "loc"))) + `(let ((,loc ,location)) + (if (= 1 (length ,loc)) + (m-buffer-with-current-marker + (nth 0 ,loc) + ,@body) + (if (= 2 (length ,loc)) + (m-buffer-with-current-position + (nth 0 ,loc) + (nth 1 ,loc) + ,@body) + (error "m-buffer-with-current-location requires a list of one or two elements")))))) + +(provide 'm-buffer-macro) +;;; m-buffer-macro.el ends here +;; #+end_src diff --git a/lisp/emacs-lisp/m-buffer/m-buffer-pkg.el b/lisp/emacs-lisp/m-buffer/m-buffer-pkg.el new file mode 100644 index 00000000000..07ff27e81e7 --- /dev/null +++ b/lisp/emacs-lisp/m-buffer/m-buffer-pkg.el @@ -0,0 +1,2 @@ +(define-package "m-buffer" "0.4" "Buffer Manipulation Functions" + '((emacs "24.3"))) diff --git a/lisp/emacs-lisp/m-buffer/m-buffer.el b/lisp/emacs-lisp/m-buffer/m-buffer.el new file mode 100644 index 00000000000..c3f35236693 --- /dev/null +++ b/lisp/emacs-lisp/m-buffer/m-buffer.el @@ -0,0 +1,984 @@ +;;; m-buffer.el --- List-Oriented, Functional Buffer Manipulation -*- lexical-binding: t -*- + +;;; Header: + +;; This file is not part of Emacs + +;; Author: Phillip Lord +;; Maintainer: Phillip Lord +;; Version: 0.15 +;; Package-Requires: ((seq "2.14")) + +;; The contents of this file are subject to the GPL License, Version 3.0. + +;; Copyright (C) 2014, 2015, 2016, 2017 Phillip Lord + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This file provides a set of list-oriented functions for operating over the +;; contents of buffers, mostly revolving around regexp searching, and regions. +;; They avoid the use of looping, manipulating global state with `match-data'. +;; Many high-level functions exist for matching sentences, lines and so on. + +;; Functions are generally purish: i.e. that is those functions which do +;; change state, by for example replacing text or adding overlays, should only +;; change state in one way; they will not affect point, current buffer, match +;; data or so forth. + +;; Likewise to protect against changes in state, markers are used rather than +;; integer positions. This means that it is possible, for example, to search +;; for regexp matches and then replace them all without the earlier +;; replacements invalidating the location of the later ones. Otherwise +;; replacements need to be made in reverse order. This can have implications +;; for performance, so m-buffer also provides functions for making markers nil; +;; there are also macros which help manage markers in `m-buffer-macro'. + +;; Where possible, functions share interfaces. So most of the match functions +;; take a list of "match" arguments, either position or as a plist, which avoids +;; using lots of `nil' arguments. Functions operating on matches take a list of +;; `match-data' as returned by the match functions, making it easy to chain +;; matches. + +;; This file is documented using lentic.el. Use +;; [[http://github.com/phillord/lentic-server][lentic-server]] to view. + +;;; Status: + +;; m-buffer.el is now stable and is expected to change only in +;; forward-compatible ways. + +;;; Code: + +;; #+begin_src emacs-lisp +(require 'seq) +(require 'm-buffer-macro) + +;; #+end_src + +;; ** Regexp Matching + +;; We first provide a single match function, `m-bufffer-match' which converts +;; between Emacs' stateful matching and a more sequence-oriented interface. + +;; This function also defines the "match" arguments which are a standard set of +;; arguments used throughout this package. + +;; #+begin_src emacs-lisp +(defun m-buffer-match (&rest match) + "Return a list of all `match-data' for MATCH. +MATCH may be of the forms: +BUFFER REGEXP &optional MATCH-OPTIONS +WINDOW REGEXP &optional MATCH-OPTIONS +MATCH-OPTIONS + +If BUFFER is given, search this buffer. If WINDOW is given search +the visible window. MATCH-OPTIONS is a plist with any of the +following keys: +:buffer -- the buffer to search +:regexp -- the regexp to search with +:begin -- the start of the region to search -- default point min +:end -- the end of the region to search -- default point max +:post-match -- function called after a match -- default nil +:widen -- if true, widen buffer first -- default nil +:case-fold-search value of `case-fold-search' during search. +If :default accept the current buffer-local value +:numeric -- if true, return integers not markers + +If options are expressed in two places, the plist form takes +precedence over positional args. So calling with both a first +position buffer and a :buffer arg will use the second. Likewise, +if a window is given as first arg and :end is given, then +the :end value will be used. + +REGEXP should advance point (i.e. not be zero-width) or the +function will loop infinitely. POST-MATCH can be used to avoid +this. The buffer is searched forward." + (apply 'm-buffer--match-1 + (m-buffer--normalize-args match))) +;; #+end_src + +;; The match function is actually implemented here in the `m-buffer--match-1' +;; function, with positional arguments. + +;; #+begin_src emacs-lisp +(defun m-buffer--match-1 (buffer regexp begin end + post-match widen cfs + numeric) + "Return a list of `match-data'. + +This is an internal function: please prefer `m-buffer-match'. + +BUFFER -- the buffer. +REGEXP -- the regexp. +BEGIN -- the start of the region to search +END -- the end of the region to search +POST-MATCH -- function to run after each match +POST-MATCH is useful for zero-width matches which will otherwise +cause infinite loop. The buffer is searched forward. POST-MATCH +return can also be used to terminate the matching by returning nil. +WIDEN -- call widen first. +CFS -- Non-nil if searches and matches should ignore case. +NUMERIC -- Non-nil if we should return integers not markers." +;; #+end_src + +;; We start by saving everything to ensure that we do not pollute the global +;; state. This means match-data, point, narrowing and current buffer! Hopefully +;; this is all the global state that exists and that we are changing. + +;; #+begin_src emacs-lisp + (with-current-buffer + buffer + (save-match-data + (save-excursion + (save-restriction + (when widen (widen)) +;; #+end_src + +;; This let form is doing a number of things. It sets up a dynamic binding for +;; `case-fold-search' (which works even though we are using lexical binding), +;; ensures a non-nil value for =end-bound= and defines a sentinal value that +;; =post-match-return= can use to end early. + +;; #+begin_src emacs-lisp + (let ((rtn nil) + (post-match-return t) + (end-bound (or end (point-max))) + ;; over-ride default if necessary + (case-fold-search + (if (eq :default cfs) + case-fold-search + cfs))) +;; #+end_src + +;; We start at the beginning. There was no particularly good reason for this, and +;; it would have made just as much sense to go backward. + +;; #+begin_src emacs-lisp + (goto-char + (or begin + (point-min))) + (while + (and +;; #+end_src + +;; The original purpose for =post-match-return= was for zero-width matches -- +;; these do not advance point beyond their end, so the while loop never +;; terminates. Unfortunately, avoiding this depends on the regexp being called, +;; so we provide the most general solution of all. + +;; As well as this, we check the return value of =post-match-return=, so as well +;; as advancing `point' by side-effect, we can also use it to terminate the look +;; at any point that we want; for example, we can terminate after the first match +;; which feels more efficient than searching the whole buffer then taking the +;; first match. + +;; #+begin_src emacs-lisp + post-match-return + ;; we need to check we are less than the end-bound + ;; or re-search-forward will break + (<= (point) end-bound) + (re-search-forward + regexp end-bound + t)) +;; #+end_src + +;; Store the `match-data' in a backward list, run post-match. Finally, reverse +;; and terminate. + +;; #+begin_src emacs-lisp + (setq rtn + (cons + (if numeric + (m-buffer-marker-to-pos-nil + (match-data)) + (match-data)) + rtn)) + (when post-match + (setq post-match-return (funcall post-match)))) + (reverse rtn))))))) +;; #+end_src + +;; This method implements the argument list processing. I find this interface +;; fairly attractive to use since it takes the two "main" arguments -- buffer and +;; regexp -- as positional args optionally, and everything else as keywords. The +;; use of keywords is pretty much essential as have eight arguments most of which +;; are not essential. + +;; This is fairly close to the logic provided by `cl-defun' which I wasn't aware +;; of when I wrote this. However `cl-defun' does not allow optional arguments +;; before keyword arguments -- all the optional arguments have to be given if we +;; are to use keywords. + +;; #+begin_src emacs-lisp +(defun m-buffer--normalize-args (match-with) + "Manipulate args into a standard form and return as a list. +MATCH-WITH are these args. This is an internal function." + (let* ( + ;; split up into keyword and non keyword limits + (args + (seq-take-while + (lambda (x) (not (keywordp x))) + match-with)) + (pargs + (seq-drop-while + (lambda (x) (not (keywordp x))) + match-with)) + ;; sort actual actual parameters + (first (car args)) + ;; buffer may be first + (buffer + (or (plist-get pargs :buffer) + (and (bufferp first) first))) + ;; or window may be first + (window + (or (plist-get pargs :window) + (and (windowp first) first))) + ;; regexp always comes second + (regexp + (or (plist-get pargs :regexp) + (nth 1 args))) + ;; begin depends on other arguments + (begin + (or (plist-get pargs :begin) + (and window (window-start window)))) + ;; end depends on other arguments + (end + (or (plist-get pargs :end) + (and window (window-end window)))) + ;; pm + (post-match + (plist-get pargs :post-match)) + + ;; widen + (widen + (plist-get pargs :widen)) + + ;; case-fold-search this needs to overwrite the buffer contents iff + ;; set, otherwise be ignored, so we need to distinguish a missing + ;; property and a nil one + (cfs + (if (plist-member pargs :case-fold-search) + (plist-get pargs :case-fold-search) + :default)) + + ;; numeric + (numeric + (plist-get pargs :numeric))) + + (list buffer regexp begin end post-match widen cfs numeric))) +;; #+end_src + +;; Finally, this function provides a link between the match function, and the +;; match manipulation functions. We can either choose to match once against a set +;; of arguments and then apply multiple manipulations on the returned match data. +;; Or just use the match manipulation function directly. + +;; The first version of `m-buffer' did not include this but it required lots of +;; nested calls which seem inconvenient. + +;; #+begin_example +;; (m-buffer-match-manipulate +;; (m-buffer-match (current-buffer) "hello")) +;; #+end_example + +;; I think that convienience is worth the overhead. + +;; #+begin_src emacs-lisp +(defun m-buffer-ensure-match (&rest match) + "Ensure that we have MATCH data. +If a single arg, assume it is match data and return. If multiple +args, assume they are of the form accepted by +`m-buffer-match'." + (cond + ;; we have match data + ((= 1 (length match)) + (car match)) + ((< 1 (length match)) + (apply 'm-buffer-match match)) + (t + (error "Invalid arguments")))) +;; #+end_src + +;; ** Match Data Manipulation Functions + +;; These functions manipulate lists of either match-data or match arguments in +;; some way. + +;; #+begin_src emacs-lisp +(defun m-buffer-buffer-for-match (match-data) + "Given some MATCH-DATA return the buffer for that data." + (marker-buffer (caar match-data))) + +(defun m-buffer-match-nth-group (n match-data) + "Fetch the Nth group from MATCH-DATA." + (seq-map + (lambda (m) + (let ((drp + (seq-drop m (* 2 n)))) + (list + (car drp) (cadr drp)))) + match-data)) + +(defun m-buffer-match-begin-n (n &rest match) + "Return markers to the start of the Nth group in MATCH. +MATCH may be of any form accepted by `m-buffer-ensure-match'. Use +`m-buffer-nil-marker' after the markers have been finished with +or they will slow future use of the buffer until garbage collected." + (seq-map + (lambda (m) + (nth + (* 2 n) m)) + (apply 'm-buffer-ensure-match match))) + +(defun m-buffer-match-begin-n-pos (n &rest match) + "Return positions of the start of the Nth group in MATCH. +MATCH may be of any form accepted by `m-buffer-ensure-match'. If +`match-data' is passed markers will be set to nil after this +function. See `m-buffer-nil-marker' for details." + (m-buffer-marker-to-pos-nil + (apply 'm-buffer-match-begin-n + n match))) + +(defun m-buffer-match-begin (&rest match) + "Return a list of markers to the start of MATCH. +MATCH may of any form accepted by `m-buffer-ensure-match'. Use +`m-buffer-nil-marker' after the markers have been used or they +will slow future changes to the buffer." + (apply 'm-buffer-match-begin-n 0 match)) + +(defun m-buffer-match-begin-pos (&rest match) + "Return a list of positions at the start of matcher. +MATCH may be of any form accepted by `m-buffer-ensure-match'. +If `match-data' is passed markers will be set to nil after this +function. See `m-buffer-nil-marker' for details." + (apply 'm-buffer-match-begin-n-pos 0 match)) + +(defun m-buffer-match-end-n (n &rest match) + "Return markers to the end of the match to the Nth group. +MATCH may be of any form accepted by `m-buffer-ensure-match'. +If `match-data' is passed markers will be set to nil after this +function. See `m-buffer-nil-marker' for details." + (seq-map + (lambda (m) + (nth + (+ 1 (* 2 n)) + m)) + (apply 'm-buffer-ensure-match match))) + +(defun m-buffer-match-end-n-pos (n &rest match) + "Return positions of the end Nth group of MATCH. +MATCH may be of any form accepted by `m-buffer-ensure-match'. +If `match-data' is passed markers will be set to nil after this +function. See `m-buffer-nil-marker' for details." + (m-buffer-marker-to-pos-nil + (apply 'm-buffer-match-end-n-pos + n match))) + +(defun m-buffer-match-end (&rest match) + "Return a list of markers to the end of MATCH to regexp in buffer. +MATCH may be of any form accepted by `m-buffer-ensure-match'. Use +`m-buffer-nil-marker' after the markers have been used or they +will slow future changes to the buffer." + (apply 'm-buffer-match-end-n 0 match)) + +(defun m-buffer-match-end-pos (&rest match) + "Return a list of positions to the end of the match. +MATCH may be of any form accepted by `m-buffer-ensure-match'. +If `match-data' is passed markers will be set to nil after this +function. See `m-buffer-nil-marker' for details." + (m-buffer-marker-to-pos-nil + (apply 'm-buffer-match-end match))) +;; #+end_src + +;; ** Match Utility and Predicates + +;; *** Subtraction + +;; Some predicates and the ability to subtract to lists of matches from each +;; other. This makes up for limitations in Emacs regexp which can't do "match x +;; but not y". + +;; #+begin_src emacs-lisp +(defun m-buffer-match-equal (m n) + "Return true if M and N are cover the same region. +Matches are equal if they match the same region; subgroups are +ignored." + (and + (equal + (car m) + (car n)) + (equal + (cadr m) + (cadr n)))) +;; #+end_src + +;; A nice simple implementation for the general purpose solution. +;; Unfortunately, performance sucks, running in quadratic time. + +;; #+begin_src emacs-lisp +(defun m-buffer-match-subtract (m n) + "Remove from M any match in N. +Matches are equivalent if overall they match the same +area; subgroups are ignored. +See also `m-buffer-match-exact-subtract' which often +runs faster but has some restrictions." + (seq-remove + (lambda (o) + (seq-some + (lambda (p) + (m-buffer-match-equal o p)) + n)) + m)) +;; #+end_src + +;; The ugly and complicated and less general solution. But it runs in linear +;; time. + +;; #+begin_src emacs-lisp +(defun m-buffer-match-exact-subtract (m n) + "Remove from M any match in N. +Both M and N must be fully ordered, and any element in N must be +in M." + (if n + ;; n-eaten contains the remaining elements of n that we haven't tested + ;; for yet. We throw them away as we go + (let ((n-eaten n)) + (seq-remove + (lambda (o) + (cond + ;; n-eaten has been eaten. Check here or later "<" comparison crashes. + ((not n-eaten) + ;; return nil because we always want things in m now. + nil + ) + ;; we have a match so throw away the first element of n-eaten + ;; which we won't need again. + ((m-buffer-match-equal + (car n-eaten) o) + (progn + (setq n-eaten (seq-drop n-eaten 1)) + t)) + ;; we should discard also if n-eaten 1 is less than o because, both + ;; are sorted, so we will never match + ((< + ;; first half of the first match in n-eaten + (caar n-eaten) + ;; first half of match + (car o)) + (progn + (setq n-eaten (seq-drop n-eaten 1)) + t)))) + m)) + m)) + +(defun m-buffer-in-match-p (matches position) + "Returns true is any of MATCHES contain POSITION." + (seq-some + (lambda (match) + (and + (<= (car match) position) + (<= position (cadr match)))) + matches)) +;; #+end_src + + +;; *** Partition + +;; Partition one set of markers by another. This is useful for finding matched +;; pairs of markers. + +;; #+begin_src emacs-lisp +(defun m-buffer--partition-by-marker(list partition) + "Given LIST, split at markers in PARTITION. + +This is the main implementation for `m-buffer-partition-by-marker', +but assumes that partition starts with a very low value (or nil)." + (let* ((p-top (car-safe partition)) + (p-val (car-safe (cdr-safe partition))) + (p-fn (lambda (n) + (or (not p-val) + (< n p-val))))) + (when list + (cons + (cons + p-top + (seq-take-while p-fn list)) + (m-buffer--partition-by-marker + (seq-drop-while p-fn list) + (cdr partition)))))) + +(defun m-buffer-partition-by-marker (list partition) + "Given LIST of markers, split at markers in PARTITION. +Returns a list of lists. The first element of each list is nil or +the marker from PARTITION. The rest of the elements are those +elements in LIST which are at the same position or later in the +buffer than the element from PARTITION, but before the next +element from PARTITION. + +Both LIST and PARTITION must be sorted." + ;; TODO! + (m-buffer--partition-by-marker list (cons nil partition))) +;; #+end_src + + +;; ** Marker manipulation functions + +;; These functions do things to markers rather than the areas of the buffers +;; indicated by the markers. This includes transforming between markers and +;; integer positions, and niling markers explicitly, which prevents slow down +;; before garbage collection. + +;; #+begin_src emacs-lisp +(defun m-buffer-nil-marker (markers) + "Takes a (nested) list of MARKERS and nils them all. +Markers slow buffer movement while they are pointing at a +specific location, until they have been garbage collected. Niling +them prevents this. See Info node `(elisp) Overview of Markers'." + (seq-map + (lambda (marker) + (if (seqp marker) + (m-buffer-nil-marker marker) + (set-marker marker nil))) + markers)) + +(defun m-buffer-marker-to-pos (markers &optional postnil) + "Transforms a list of MARKERS to a list of positions. +If the markers are no longer needed, set POSTNIL to true, or call +`m-buffer-nil-marker' manually after use to speed future buffer +movement. Or use `m-buffer-marker-to-pos-nil'." + (seq-map + (lambda (marker) + (prog1 + (marker-position marker) + (when postnil + (set-marker marker nil)))) + markers)) + +(defun m-buffer-marker-to-pos-nil (markers) + "Transforms a list of MARKERS to a list of positions then nils. +See also `m-buffer-nil-markers'" + (m-buffer-marker-to-pos markers t)) + +(defun m-buffer-marker-tree-to-pos (marker-tree &optional postnil) + "Transforms a tree of markers to equivalent positions. +MARKER-TREE is the tree. +POSTNIL sets markers to nil afterwards." + (seq-map + (lambda (marker) + (if (seqp marker) + (m-buffer-marker-tree-to-pos marker postnil) + (prog1 + (marker-position marker) + (when postnil + (set-marker marker nil))))) + marker-tree)) + +(defun m-buffer-marker-tree-to-pos-nil (marker-tree) + "Transforms a tree of markers to equivalent positions. +MARKER-TREE is the tree. Markers are niled afterwards." + (m-buffer-marker-tree-to-pos marker-tree t)) + +(defun m-buffer-marker-clone (marker-tree &optional type) + "Return a clone of MARKER-TREE. +The optional argument TYPE specifies the insertion type. See +`copy-marker' for details." + (seq-map + (lambda (marker) + (if (seqp marker) + (m-buffer-marker-clone marker type) + (copy-marker marker type))) + marker-tree)) + +(defun m-buffer-pos-to-marker (buffer positions) + "In BUFFER translates a list of POSITIONS to markers." + (seq-map + (lambda (pos) + (set-marker + (make-marker) pos buffer)) + positions)) +;; #+end_src + +;; ** Replace, Delete, Extract + +;; #+begin_src emacs-lisp +(defun m-buffer-replace-match (match-data replacement + &optional fixedcase literal subexp) + "Given a list of MATCH-DATA, replace with REPLACEMENT. +If FIXEDCASE do not alter the case of the replacement text. +If LITERAL insert the replacement literally. +SUBEXP should be a number indicating the regexp group to replace. +Returns markers to the start and end of the replacement. These +markers are part of MATCH-DATA, so niling them will percolate backward. + +See also `replace-match'." + (save-excursion + (seq-map + (lambda (match) + (with-current-buffer + (marker-buffer (car match)) + (save-match-data + (set-match-data match) + (replace-match + replacement fixedcase literal nil + (or subexp 0))))) + match-data)) + ;; we have match-data + (m-buffer-match-nth-group (or subexp 0) match-data)) + +(defun m-buffer-delete-match (match-data &optional subexp) + "Delete all MATCH-DATA. +SUBEXP should be a number indicating the regexp group to delete. +Returns markers to the start and end of the replacement. These +markers are part of MATCH_DATA, so niling them will percolate backward." + (m-buffer-replace-match match-data "" subexp)) + +(defun m-buffer-match-string (match-data &optional subexp) + "Return strings for MATCH-DATA optionally of group SUBEXP." + (seq-map + (lambda (match) + (with-current-buffer + (marker-buffer (car match)) + (save-match-data + (set-match-data match) + (match-string + (or subexp 0))))) + match-data)) + +(defun m-buffer-match-string-no-properties (match-data &optional subexp) + "Return strings for MATCH-DATA optionally of group SUBEXP. +Remove all properties from return." + (seq-map + 'substring-no-properties + (m-buffer-match-string + match-data subexp))) +;; #+end_src + +;; ** Match Things + +;; Emacs comes with a set of in-built regexps most of which we use here. + +;; We define `m-buffer-apply-join' first. The reason for this function is that +;; we want to take a list of match arguments and add to with, for instance, a +;; regular expression. We need to add these at the end because most of our +;; functions contain some positional arguments. + + +;; #+begin_src emacs-lisp +(defun m-buffer-apply-join (fn match &rest more-match) + (let* + ((args + (seq-take-while + (lambda (x) (not (keywordp x))) + match)) + (pargs + (seq-drop-while + (lambda (x) (not (keywordp x))) + match)) + (more-keywords + (seq-map + 'car + (seq-partition more-match 2)))) + (when + (seq-find + (lambda (keyword) + (plist-member pargs keyword)) + more-keywords) + (error + "Match arg contradicts a defined argument.")) + (apply fn (append args more-match pargs)))) +;; #+end_src + +;; For the following code, we use Emacs core regexps where possible. + +;; #+begin_src emacs-lisp +(defun m-buffer-match-page (&rest match) + "Return a list of match data to all pages in MATCH. +MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See +`m-buffer-match' for further details." + (m-buffer-apply-join 'm-buffer-match + match :regexp page-delimiter)) +;; #+end_src + +;; The `paragraph-separate' regexp can match an empty region, so we need to start +;; each search at the beginning of the next line. + +;; #+begin_src emacs-lisp +(defun m-buffer-match-paragraph-separate (&rest match) + "Return a list of match data to `paragraph-separate' in MATCH. +MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See +`m-buffer-match' for futher details." + (m-buffer-apply-join + 'm-buffer-match match :regexp paragraph-separate + :post-match 'm-buffer-post-match-forward-line)) + +(defvar m-buffer--line-regexp + "^.*$" + "Regexp to match a line.") + +(defun m-buffer-match-line (&rest match) + "Return a list of match data to all lines. +MATCH is of the form BUFFER-OR-WINDOW MATCH-OPTIONS. +See `m-buffer-match for further details." + (m-buffer-apply-join + 'm-buffer-match + match :regexp m-buffer--line-regexp + :post-match 'm-buffer-post-match-forward-char)) + +(defun m-buffer-match-line-start (&rest match) + "Return a list of match data to all line start. +MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See +`m-buffer-match' for further details." + (m-buffer-apply-join + 'm-buffer-match-begin + match :regexp "^" + :post-match 'm-buffer-post-match-forward-char)) + +(defun m-buffer-match-line-end (&rest match) + "Return a list of match to line end. +MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See +`m-buffer-match' for further details." + (m-buffer-apply-join + 'm-buffer-match-begin + match :regexp "$" + :post-match 'm-buffer-post-match-forward-char)) +;; #+end_src + +;; This is the first use of the =post-match= to terminate the loop, and was +;; actually the motivation for adding it. We automatically terminate after the +;; first match by simply returning nil. + +;; #+begin_src emacs-lisp +(defun m-buffer-match-first (&rest match) + "Return the first match to MATCH. +This matches more efficiently than matching all matches and +taking the car. See `m-buffer-match' for further details of +MATCH." + (m-buffer-apply-join + #'m-buffer-match match + :post-match (lambda () nil))) + +(defun m-buffer-match-first-line (&rest match) + "Return a match to the first line of MATCH. +This matches more efficiently than matching all lines and taking +the car. See `m-buffer-match' for further details of MATCH." + (m-buffer-apply-join + 'm-buffer-match-first match + :regexp m-buffer--line-regexp)) + +(defun m-buffer-match-multi (regexps &rest match) + "Incrementally find matches to REGEXPS in MATCH. +Finds the first match to the first element of regexps, then +starting from the end of this match, the first match to the +second element of regexps and so forth. See `m-buffer-match' for +futher details of MATCH." + (when regexps + (let ((first-match + (m-buffer-apply-join + #'m-buffer-match-first + match + :regexp (car regexps)))) + (append + first-match + (apply + #'m-buffer-match-multi + (cdr regexps) + (plist-put + match + :begin (car (m-buffer-match-end first-match)))))))) +;; #+end_src + +;; Emacs has a rather inconsistent interface here -- suddenly, we have a function +;; rather than a variable for accessing a regexp. + +;; #+begin_src emacs-lisp +(defun m-buffer-match-sentence-end (&rest match) + "Return a list of match to sentence end. +MATCH is of the form BUFFER-OR-WINDOW MATCH-OPTIONS. See +`m-buffer-match' for further details." + (m-buffer-apply-join + 'm-buffer-match-begin + match :regexp (sentence-end))) + +(defun m-buffer-match-word (&rest match) + "Return a list of match to all words. +MATCH is of the form BUFFER-OR-WINDOW MATCH-OPTIONS. See +`m-buffer-match' for further details." + (m-buffer-apply-join + 'm-buffer-match + match :regexp "\\\w+")) + +(defun m-buffer-match-empty-line (&rest match) + "Return a list of match to all empty lines. +MATCH is of the form BUFFER-OR-WINDOW MATCH-OPTIONS. See +`m-buffer-match' for further details." + (m-buffer-apply-join + 'm-buffer-match + match :regexp "^$" + :post-match 'm-buffer-post-match-forward-line)) + +(defun m-buffer-match-non-empty-line (&rest match) + "Return a list of match to all non-empty lines. +MATCH is fo the form BUFFER-OR-WINDOW MATCH-OPTIONS. See +`m-buffer-match' for further details." + (m-buffer-apply-join + 'm-buffer-match + match :regexp "^.+$")) + +(defun m-buffer-match-whitespace-line (&rest match) + "Return match data to all lines with only whitespace characters. +Note empty lines are not included. MATCH is of form +BUFFER-OR-WINDOW MATCH-OPTIONS. See `m-buffer-match' for +further details." + (m-buffer-apply-join + 'm-buffer-match + match :regexp "^\\s-+$")) + +;; #+end_src + +;; I don't think that there is a way to do this with regexps entirely, so we use +;; substraction. + +;; #+begin_src emacs-lisp +(defun m-buffer-match-non-whitespace-line (&rest match) + "Return match data to all lines with at least one non-whitespace character. +Note empty lines do not contain any non-whitespace lines. +MATCH is of form BUFFER-OR-WINDOW MATCH-OPTIONS. See +`m-buffer-match' for further details." + (seq-difference + (apply 'm-buffer-match-line match) + (apply 'm-buffer-match-whitespace-line match))) + +;; Useful post-match functions +(defun m-buffer-post-match-forward-line () + "Attempt to move forward one line, return true if success." + (= 0 (forward-line))) + +(defun m-buffer-post-match-forward-char () + "Attempts to move forward one char. +Returns true if succeeds." + (condition-case _e + (progn + (forward-char) + t) + (error 'end-of-buffer + nil))) +;; #+end_src + + +;; ** Apply Function to Match + +;; These functions apply another function to some match-data. This is pretty +;; useful generically, but also I use it for many of the following functions. + +;; #+begin_src emacs-lisp +(defun m-buffer-on-region (fn match-data) + "Apply FN to MATCH-DATA. +FN should take two args, the start and stop of each region. +MATCH-DATA can be any list of lists with two elements (or more)." + (m-buffer-on-region-nth-group fn 0 match-data)) + +(defun m-buffer-on-region-nth-group (fn n match-data) + "Apply FN to the Nth group of MATCH-DATA. +FN should take two args, the start and stop of each region. +MATCH-DATA can be any list of lists with two elements (or more)." + (seq-map + (lambda (x) + (apply fn x)) + (m-buffer-match-nth-group n match-data))) +;; #+end_src + +;; ** Overlay and Property Functions + +;; Adding properties or overlays to match-data. The functionality here somewhat +;; overlaps with [[https://github.com/ShingoFukuyama/ov.el][ov.el]], which I didn't know about when I wrote this. It generally +;; works over overlays, or regexps, while m-buffer works over match-data. + +;; #+begin_src emacs-lisp +(defun m-buffer-overlay-match (match-data &optional front-advance rear-advance) + "Return an overlay for all match to MATCH-DATA. +FRONT-ADVANCE and REAR-ADVANCE controls the borders of the +overlay as defined in `make-overlay'. Overlays do not scale that +well, so use `m-buffer-propertize-match' if you intend to make +and keep many of these. + +See Info node `(elisp) Overlays' for further information." + (let ((buffer (m-buffer-buffer-for-match match-data))) + (m-buffer-on-region + (lambda (beginning end) + (make-overlay + beginning end buffer + front-advance rear-advance)) + match-data))) + +(defun m-buffer-add-text-property-match + (match-data properties) + "To MATCH-DATA add PROPERTIES. +See `add-text-property' for details of the format of properties. +Text properties are associated with the text and move with it. See +Info node `(elisp) Text Properties' for further details." + (m-buffer-on-region + (lambda (beginning end) + (add-text-properties beginning end properties)) + match-data)) + +(defun m-buffer-put-text-property-match (match-data property value) + "To MATCH-DATA add PROPERTY wth VALUE. +See `put-text-property' for details of the format of properties. +Text properties are associated with the text and move with it. See +Info node `(elisp) Text Properties' for further details." + (m-buffer-on-region + (lambda (beginning end) + (put-text-property beginning end property value)) + match-data)) + +(defun m-buffer-overlay-face-match (match-data face) + "To MATCH-DATA add FACE to the face property. +This is for use in buffers which do not have function `font-lock-mode' +enabled; otherwise use `m-buffer-overlay-font-lock-face-match'." + (seq-map + (lambda (ovly) + (overlay-put ovly 'face face)) + (m-buffer-overlay-match match-data))) + +(defun m-buffer-overlay-font-lock-face-match (match-data face) + "To MATCH-DATA add FACE to the face property. +This is for use in buffers which have variable `font-lock-mode' enabled; +otherwise use `m-buffer-overlay-face-match'." + (seq-map + (lambda (ovly) + (overlay-put ovly 'face face)) + (m-buffer-overlay-match match-data))) + +(defun m-buffer-text-property-face (match-data face) + "To MATCH-DATA apply FACE. +This is for use in buffers which do +not have variable `font-lock-mode' enabled; otherwise use +`m-buffer-text-property-font-lock-face'." + (m-buffer-put-text-property-match match-data + 'face face)) + +(defun m-buffer-text-property-font-lock-face (match-data face) + "To MATCH-DATA apply FACE. +This is for use in buffers which have variable `font-lock-mode' +enabled; otherwise use `m-buffer-text-property-face'." + (m-buffer-put-text-property-match match-data + 'font-lock-face face)) + +(provide 'm-buffer) + + +;;; m-buffer.el ends here +;; #+end_src diff --git a/test/lisp/tutorial-tests.el b/test/lisp/tutorial-tests.el new file mode 100644 index 00000000000..26cdb469247 --- /dev/null +++ b/test/lisp/tutorial-tests.el @@ -0,0 +1,43 @@ +;;; tutorial-tests.el --- Test suite for tutorial -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Phillip Lord +;; Keywords: abbrevs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'tutorial) + +(ert-deftest tutorial--open-tutorial () + ;; We do not care about the return value (which happens to be nil), + ;; but it should not error. + (should-not + (let ((current-language-environment "English")) + (help-with-tutorial))) + (should-not + (let ((current-language-environment "Russian")) + (help-with-tutorial))) + (should-error + (let ((current-language-environment "Elvish")) + (help-with-tutorial)))) + + +(provide 'tutorial-tests) +;;; tutorial-tests.el ends here -- 2.39.5