tools.editors.emacs.tests.ert-support.el Maven / Gradle / Ivy
;; Common support facilities
(add-to-list 'load-path "..")
(load "rst.el" nil t)
(require 'cl)
(require 'ert)
;; ****************************************************************************
;; ****************************************************************************
;; Support for comparison of buffer results
;; ****************************************************************************
;; `buf' and related functions
(defvar buf-point-char "\^@"
"Special character used to mark the position of point in a `buf'.")
(defvar buf-mark-char "\^?"
"Special character used to mark the position of mark in a `buf'.")
(defstruct (buf
(:constructor string2buf
(string
&aux
(analysis (buf-parse-string string))
(content (car analysis))
(point (cadr analysis))
(mark (caddr analysis))))
(:constructor buffer2buf
(&aux
(content (buffer-substring-no-properties
(point-min) (point-max)))
(point (point))
(mark (mark t))
(string (buf-create-string content point mark)))))
"Structure to hold comparable information about a buffer."
(content nil :read-only t)
(point nil :read-only t)
(mark nil :read-only t)
(string nil :read-only t)
)
(defun buf-parse-string (string)
"Parse STRING and return a list constisting of the cleaned
content, the position of point if `buf-point-char' was found and
the the position of mark if `buf-mark-char' was found."
(with-temp-buffer
(let ((case-fold-search nil)
fnd point-fnd mark-fnd)
(insert string)
(goto-char (point-min))
(while (re-search-forward (concat "[" buf-point-char buf-mark-char "]")
nil t)
(setq fnd (match-string 0))
(replace-match "")
(cond
((equal fnd buf-point-char)
(if point-fnd
(error "Duplicate point"))
(setq point-fnd (point)))
((equal fnd buf-mark-char)
(if mark-fnd
(error "Duplicate mark"))
(setq mark-fnd (point)))
(t
(error "Unexpected marker found"))))
(list (buffer-substring-no-properties (point-min) (point-max))
point-fnd mark-fnd))))
(defun buf-create-string (content point mark)
"Creates a string representation from CONTENT, POINT and MARK."
(with-temp-buffer
(insert content)
(let (pnt-chs)
(if point
(setq pnt-chs (nconc pnt-chs (list (cons point buf-point-char)))))
(if mark
(setq pnt-chs (nconc pnt-chs (list (cons mark buf-mark-char)))))
;; Sort pairs so the highest position is last
(setq pnt-chs (sort pnt-chs (lambda (el1 el2) (> (car el1) (car el2)))))
(while pnt-chs
(goto-char (caar pnt-chs))
(insert (cdar pnt-chs))
(setq pnt-chs (cdr pnt-chs)))
(buffer-substring-no-properties (point-min) (point-max)))))
(defun buf2buffer (buf)
"Set current buffer according to BUF."
(insert (buf-content buf))
(if (buf-point buf)
(goto-char (buf-point buf)))
(if (buf-mark buf)
(set-mark (buf-mark buf))))
;; ****************************************************************************
;; Runners
(defvar ert-inputs nil
"Variable to hold the strings to give successively to `ert-completing-read'.")
(defadvice completing-read (around ert-completing-read first
(prompt collection &optional predicate
require-match initial-input hist
def inherit-input-method))
"Advice for `completing-read' to accept input from `ert-inputs'
instead of the minibuffer."
(if (not ert-inputs)
(error "No more input strings in `ert-inputs'"))
(let* ((input (pop ert-inputs)))
(setq ad-return-value
(cond
((eq (try-completion input collection predicate) t) ;; Perfect match
input)
((not require-match) ;; Non-matching input allowed
input)
((and (equal input "")
(eq require-match t)) ;; Empty input and this is allowed
input)
(t
(error "Input '%s' is not allowed for `completing-read' expecting %s"
input collection))))))
(defadvice read-string (around ert-read-string first
(prompt &optional initial-input history
default-value inherit-input-method))
"Advice for `read-string' to accept input from `ert-inputs'
instead of the minibuffer."
(if (not ert-inputs)
(error "No more input strings in `ert-inputs'"))
(let* ((input (pop ert-inputs)))
(setq ad-return-value
(if (and (equal input "") default-value)
default-value
input))))
(defadvice read-number (around ert-read-number first
(prompt &optional default))
"Advice for `read-number' to accept input from `ert-inputs'
instead of the minibuffer."
(if (not ert-inputs)
(error "No more input strings in `ert-inputs'"))
(let* ((input (pop ert-inputs)))
(setq ad-return-value
(if (and (equal input "") default)
default
input))))
(defun run-test (input funcall interactive)
"Run list FUNCALL with a buffer filled with INPUT. Return a
cons consisting of the return value and a `buf'. If INTERACTIVE
is non-nil FUNCALL is called in an interactive environment."
(let ((buf (string2buf input)))
(with-temp-buffer
(buf2buffer buf)
(let ((act-return
(cond
((not interactive)
(apply (car funcall) (cdr funcall)))
((eq interactive t)
(let ((current-prefix-arg (cadr funcall)))
(call-interactively (car funcall))))
((listp interactive)
(setq ert-inputs interactive)
(ad-activate 'read-string)
(ad-activate 'read-number)
(ad-activate 'completing-read)
(unwind-protect
(let ((current-prefix-arg (cadr funcall)))
(call-interactively (car funcall)))
(progn
(ad-deactivate 'completing-read)
(ad-deactivate 'read-number)
(ad-deactivate 'read-string)))
(if ert-inputs
(error "%d input strings left over"
(length ert-inputs))))))
(act-buf (buffer2buf)))
(cons act-return act-buf)))))
(defun compare-test (result exp-output ignore-return exp-return)
"Compare the RESULT of a test from `run-test' with expexted values.
Return a list of booleans where t stands for a successful test of this kind:
* Content of output buffer
* Point in output buffer
* Return value"
(let ((act-return (car result))
(act-buf (cdr result))
(exp-buf (and exp-output (string2buf exp-output))))
(list
(or (not exp-buf)
(equal (buf-content act-buf) (buf-content exp-buf)))
(or
(not exp-buf)
(not (buf-point exp-buf))
(equal (buf-point act-buf) (buf-point exp-buf)))
(or ignore-return
(equal act-return exp-return)))))
(defun equal-buffer-internal (funcall input exp-output ignore-return exp-return interactive)
"Run list FUNCALL with a buffer filled with INPUT. Compare the
buffer content to EXP-OUTPUT if this is non-nil and the return
value to EXP-RETURN. Ignore return value if IGNORE-RETURN. Return
t if equal.
INPUT and EXP-OUTPUT are expected to be parsable by
`buf-parse-string'.
If INTERACTIVE is non-nil the FUNCALL is done interactively and
`current-prefix-arg' is set to the cadr of FUNCALL and thus must
comply to the format of `current-prefix-arg'. If INTERACTIVE is t
only `call-interactively' is used. If INTERACTIVE is a list of
strings the elements of the list are given to (advised forms of)
functions reading from the minibuffer as user input strings."
(reduce (lambda (l r) (and l r))
(compare-test (run-test input funcall interactive)
exp-output ignore-return exp-return)))
(defun equal-buffer-return (funcall input exp-output exp-return &optional interactive)
"Call `equal-buffer-internal' and caring for result of FUNCALL"
(equal-buffer-internal funcall input exp-output nil exp-return interactive))
(defun equal-buffer (funcall input exp-output &optional interactive)
"Call `equal-buffer-internal' not caring for result of FUNCALL"
(equal-buffer-internal funcall input exp-output t nil interactive))
;; ****************************************************************************
;; Explainers
(defun equal-buffer-internal-explain (funcall input exp-output ignore-return exp-return interactive)
"Return an explanation why `equal-buffer-internal' failed with
these parameters"
(let ((test-result (run-test input funcall interactive))
(exp-buf (and exp-output (string2buf exp-output))))
(destructuring-bind (ok-string ok-point ok-return)
(compare-test test-result exp-output ignore-return exp-return)
(let (result)
(if (not ok-return)
(push (list 'different-return-values
(ert--explain-not-equal (car test-result) exp-return))
result))
(if (not ok-point)
(push (list 'different-points
(buf-string (cdr test-result))
(buf-string exp-buf))
result))
(if (not ok-string)
(push (list 'different-buffer-contents
(ert--explain-not-equal
(buf-content (cdr test-result)) (buf-content exp-buf)))
result))
result))))
(defun equal-buffer-return-explain (funcall input exp-output exp-return &optional interactive)
(equal-buffer-internal-explain funcall input exp-output nil exp-return interactive))
(put 'equal-buffer-return 'ert-explainer 'equal-buffer-return-explain)
(defun equal-buffer-explain (funcall input exp-output &optional interactive)
(equal-buffer-internal-explain funcall input exp-output t nil interactive))
(put 'equal-buffer 'ert-explainer 'equal-buffer-explain)