[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[nongnu] elpa/buttercup 789570cf7d 10/16: Merge pull request #249 from s
From: |
ELPA Syncer |
Subject: |
[nongnu] elpa/buttercup 789570cf7d 10/16: Merge pull request #249 from snogge/fix-247 |
Date: |
Wed, 4 Sep 2024 18:59:25 -0400 (EDT) |
branch: elpa/buttercup
commit 789570cf7d4b7e84c2787aceebab33a55ec812b4
Merge: dfbef21772 f577efc524
Author: Ola Nilsson <ola.nilsson@gmail.com>
Commit: GitHub <noreply@github.com>
Merge pull request #249 from snogge/fix-247
Improve backtrace looks and performance
---
buttercup.el | 133 ++++++++++++++++++++++++++++-----------------
tests/test-buttercup.el | 139 +++++++++++++++++++++++++++++++++---------------
2 files changed, 181 insertions(+), 91 deletions(-)
diff --git a/buttercup.el b/buttercup.el
index cf6019d65f..3fc51db26a 100644
--- a/buttercup.el
+++ b/buttercup.el
@@ -83,13 +83,12 @@ For Emacs < 29:
The function MUST be byte-compiled or have one of the following
forms:
-\(closure (ENVLIST) () (quote EXPR) (buttercup--mark-stackframe) EXPANDED)
-\(lambda () (quote EXPR) (buttercup--mark-stackframe) EXPR)
+\(closure (ENVLIST) () (quote EXPR) EXPANDED)
+\(lambda () (quote EXPR) EXPR)
and the return value will be EXPR, unevaluated. The quoted EXPR
is useful if EXPR is a macro call, in which case the `quote'
ensures access to the un-expanded form."
- (cl-assert (functionp fun) t "Expected FUN to be a function")
(if (buttercup--thunk-p fun)
(buttercup--thunk--expr fun)
(pcase fun
@@ -99,7 +98,7 @@ ensures access to the un-expanded form."
;; * the stackframe marker
;; * the macroexpanded original expression
(`(closure ,(pred listp) nil
- (quote ,expr) (buttercup--mark-stackframe) ,_expanded)
+ (quote ,expr) ,_expanded)
expr)
;; This a when FUN has not been evaluated.
;; Why does that happen?
@@ -108,7 +107,7 @@ ensures access to the un-expanded form."
;; * the stackframe marker
;; * the expanded expression
(`(lambda nil
- (quote ,expr) (buttercup--mark-stackframe) ,_expanded)
+ (quote ,expr) ,_expanded)
expr)
;; This is when FUN has been byte compiled, as when the entire
;; test file has been byte compiled. Check that it has an empty
@@ -189,11 +188,9 @@ Does not have the IGNORE-MISSING and SPLIT parameters."
"Wrap EXPR in a `buttercup--thunk' to be used by `buttercup-expect'."
(if (fboundp 'oclosure-lambda) ;Emacsā„29
`(oclosure-lambda (buttercup--thunk (expr ',expr)) ()
- (buttercup--mark-stackframe)
,expr)
`(lambda ()
(quote ,expr)
- (buttercup--mark-stackframe)
,expr)))
(defmacro expect (arg &optional matcher &rest args)
@@ -1016,7 +1013,6 @@ most probably including one or more calls to `expect'."
`(buttercup-it ,description
(lambda ()
(buttercup-with-converted-ert-signals
- (buttercup--mark-stackframe)
,@body)))
`(buttercup-xit ,description)))
@@ -2108,50 +2104,87 @@ ARGS according to `debugger'."
;; args is (error (signal . data) ....) where the tail
;; may be empty
(cl-destructuring-bind (signal-type . data) (cl-second args)
- (unless (eq signal-type 'buttercup-pending)
- (buttercup--backtrace))))))
-
-(defalias 'buttercup--mark-stackframe #'ignore
- "Marker to find where the backtrace start.")
+ (cl-case signal-type
+ ((buttercup-pending buttercup-failed))
+ (otherwise (buttercup--backtrace)))))))
(defun buttercup--backtrace ()
"Create a backtrace, a list of frames returned from `backtrace-frame'."
- ;; Read the backtrace frames from 0 (the closest) upward.
- (cl-do* ((n 0 (1+ n))
- (frame (backtrace-frame n) (backtrace-frame n))
- (frame-list nil)
- (in-program-stack nil))
+ ;; Read the backtrace frames from `buttercup--debugger' + 1 upward.
+ (cl-do* ((n 1 (1+ n))
+ (frame (backtrace-frame n #'buttercup--debugger)
+ (backtrace-frame n #'buttercup--debugger))
+ (frame-list nil))
((not frame) frame-list)
- ;; discard frames until (and including) `buttercup--debugger', they
- ;; only contain buttercup code
- (when in-program-stack
- (push frame frame-list))
- (when (eq (elt frame 1)
- 'buttercup--debugger)
- (setq in-program-stack t))
- ;; keep frames until one of the known functions are found, after
- ;; this is just the buttercup framework and not interesting for
- ;; users (incorrect for testing buttercup). Some frames before the
- ;; function also have to be discarded
- (cl-labels ((tree-find (key tree)
- (cl-block tree-find
- (while (consp tree)
- (let ((elem (pop tree)))
- (when (or (and (consp elem)
- (tree-find key elem))
- (and (buttercup--thunk-p elem)
- (tree-find key (aref elem
1)))
- (eql key elem))
- (cl-return-from tree-find t))))
- (cl-return-from tree-find
- (and tree (eql tree key))))))
- ;; TODO: Only check the cadr of frame, that is where the function is.
- ;; The buttercup--mark-stackframe should only be in wrapped
expressions,
- ;; optimize by checking if it is a wrapped expression?
- ;; Will we even need the marker if we can check that?
- (when (and in-program-stack (tree-find 'buttercup--mark-stackframe
frame))
- (pop frame-list)
- (cl-return frame-list)))))
+ ;; Keep frames until one if the end conditions is met. After
+ ;; this is just the buttercup framework and not interesting for
+ ;; users - except for testing buttercup.
+ (when (or
+ ;; When the error occurs in the calling of one of the
+ ;; wrapped expressions of an expect.
+ (buttercup--wrapper-fun-p (cadr frame))
+ ;; When an error happens in spec code but outside an expect
+ ;; statement
+ ;; buttercup--update-with-funcall
+ ;; apply buttercup--funcall
+ ;; buttercup--funcall - sets debugger
+ ;; apply FUNCTION
+ ;; FUNCTION -- spec body function
+ ;; condition-case -- from
buttercup-with-converted-ert-signals
+ ;; (let ((buttercup--stackframe-marker 1)) -- the same
+ ;; ACTUAL CODE
+ (and (null (car frame))
+ (eq 'let (cadr frame))
+ (equal '((buttercup--stackframe-marker 1)) (car (cddr frame)))
+ )
+ ;; TODO: What about :to-throw?
+ ;; buttercup--update-with-funcall (spec ...
+ ;; apply buttercup--funcall
+ ;; buttercup--funcall -- sets the debugger
+ ;; apply FUNCTION
+ ;; FUNCTION -- spec body function
+ ;; condition-case -- from buttercup-with-converted-ert-signals
+ ;; (let ((buttercup--stackframe-marker 1))
+ ;; (buttercup-expect
+ ;; (buttercup--apply-matcher
+ ;; (apply to-throw-matcher
+ ;; (to-throw-matcher
+ ;; We need a new debugger here, the
+ ;; condition-case can not be used to collect
+ ;; backtrace.
+ ;; When the error happens in the matcher function
+ ;; (buttercup-expect
+ ;; (buttercup--apply-matcher
+ ;; (apply some-kind-of-function
+ ;; (matcher
+ ;; ACTUAL CODE
+ (and (eq 'buttercup--apply-matcher (cadr frame))
+ ;; The two preceeding frames are not of user interest
+ (pop frame-list) (pop frame-list)
+ ;; Add a fake frame for the matcher function
+ (push (cons t
+ (cons (car (cddr frame))
+ (mapcar (lambda (x)
+ (if (buttercup--wrapper-fun-p x)
+ (buttercup--enclosed-expr x)
+ x))
+ (cadr (cddr frame)))))
+ frame-list))
+ ;; TODO: What about signals in before and after blocks?
+ ;; BEFORE-EACH:
+ ;; buttercup--run-suite
+ ;; (let* ...
+ ;; (dolist (f (buttercup-suite-before-all ...
+ ;; (buttercup--update-with-funcall suite f
+ ;; (apply buttercup--funcall
+ ;; (buttercup-funcall f
+ ;; (f)
+ ;; Currently, buttercup silently ignores error in
+ ;; (before|after)-(all|each). As long as that is the case,
+ ;; there is nothing we can do about stacktraces.
+ )
+ (cl-return frame-list))
+ (push frame frame-list)))
(defun buttercup--format-stack-frame (frame &optional style)
"Format stack FRAME according to STYLE.
@@ -2200,7 +2233,9 @@ Specifically, `ert-test-failed' is converted to
`buttercup-pending'."
(declare (indent 0))
`(condition-case err
- (progn ,@body)
+ (let ((buttercup--stackframe-marker 1))
+ (ignore buttercup--stackframe-marker)
+ ,@body)
(ert-test-failed
(buttercup-fail "%S" err))
(ert-test-skipped
diff --git a/tests/test-buttercup.el b/tests/test-buttercup.el
index 31a9fbbd4f..08be241c33 100644
--- a/tests/test-buttercup.el
+++ b/tests/test-buttercup.el
@@ -180,18 +180,18 @@ before it's processed by other functions."
"Not testable on Emacs 30+, not relevant for Emacs 29+")
(expect (buttercup--enclosed-expr
(let ((_foo 1))
- (lambda () '(ignore) (buttercup--mark-stackframe) (ignore))))
+ (lambda () '(ignore) (ignore))))
:to-equal '(ignore)))
(it "a lambda with expression copy?"
;; I suspect there is nothing to make sure that the quoted
;; expression matches the actual expression
(expect (buttercup--enclosed-expr
- '(lambda () (quote (ignore)) (buttercup--mark-stackframe)
(ignore))))
+ '(lambda () (quote (ignore)) (ignore))))
:to-equal '(ignore))
(describe "byte compiled"
(it "lambda objects"
(expect (buttercup--enclosed-expr
- (byte-compile-sexp '(lambda () '(ignore)
(buttercup--mark-stackframe) (ignore))))))
+ (byte-compile-sexp '(lambda () '(ignore) (ignore))))))
(it "wrapped expression"
(assume (not (fboundp 'buttercup--thunk-p)) "Not with Oclosures")
(expect (buttercup--enclosed-expr (byte-compile-sexp
(buttercup--wrap-expr '(ignore))))))))
@@ -202,15 +202,15 @@ before it's processed by other functions."
:to-throw 'buttercup-enclosed-expression-error))
(it "on a closure with stackframe marker but no quoted expression"
(expect
- (buttercup--enclosed-expr (let ((_foo 1)) (lambda ()
(buttercup--mark-stackframe) (ignore))))
+ (buttercup--enclosed-expr (let ((_foo 1)) (lambda () (ignore))))
:to-throw 'buttercup-enclosed-expression-error))
(it "for multi-statement closures"
(expect (buttercup--enclosed-expr
- (lambda () '(+ 1 2) (buttercup--mark-stackframe) (+ 1 2)
(ignore)))
+ (lambda () '(+ 1 2) (+ 1 2) (ignore)))
:to-throw 'buttercup-enclosed-expression-error))
(it "for closures with non-empty argument lists"
(expect (buttercup--enclosed-expr
- (lambda (foo) '(ignore foo) (buttercup--mark-stackframe)
(ignore foo)))
+ (lambda (foo) '(ignore foo) (ignore foo)))
:to-throw 'buttercup-enclosed-expression-error))
(it "on simple lambda objects"
(expect (buttercup--enclosed-expr
@@ -218,7 +218,7 @@ before it's processed by other functions."
:to-throw))
(it "on a lambda with stackframe marker but no quoted expression"
(expect (buttercup--enclosed-expr
- '(lambda () (buttercup--mark-stackframe) (ignore)))
+ '(lambda () (ignore)))
:to-throw 'buttercup-enclosed-expression-error))
(it "for multi-statement lambdas"
(expect (buttercup--enclosed-expr
@@ -230,7 +230,7 @@ before it's processed by other functions."
:to-throw 'buttercup-enclosed-expression-error))
(it "on byte-compiled functions with arguments"
(expect (buttercup--enclosed-expr
- (byte-compile-sexp '(lambda (_a) '(ignore)
(buttercup--mark-stackframe) (ignore))))
+ (byte-compile-sexp '(lambda (_a) '(ignore) (ignore))))
:to-throw 'buttercup-enclosed-expression-error))))
;;;;;;;;;;
@@ -1121,7 +1121,6 @@ before it's processed by other functions."
'(buttercup-it "description"
(lambda ()
(buttercup-with-converted-ert-signals
- (buttercup--mark-stackframe)
body)))))
(it "without argument should expand to xit."
@@ -1947,7 +1946,7 @@ before it's processed by other functions."
(kill-buffer print-buffer)
(setq print-buffer nil))
;; define a buttercup-reporter-batch variant that only outputs on
- ;; buttercup-done
+ ;; buttercup-done, because that is where backtraces are printed
(before-each
(spy-on 'backtrace-reporter :and-call-fake
(lambda (event arg)
@@ -1960,31 +1959,96 @@ before it's processed by other functions."
(spy-on 'buttercup-reporter-batch--print-summary))
;; define a known backtrace with a typical error
(before-all
- (defun bc-bt-foo (a) (bc-bt-bar a))
- (defun bc-bt-bar (a) (bc-bt-baz a))
- (defun bc-bt-baz (a)
+ (defun bc-bt-baz (a)
(or (number-or-marker-p a)
- (signal 'wrong-type-argument `(number-or-marker-p ,a)))))
+ (signal 'wrong-type-argument `(number-or-marker-p ,a))))
+ (with-no-warnings
+ (defun bc-bt-bar (a) (bc-bt-baz a))
+ (defun bc-bt-foo (a) (bc-bt-bar a))))
(after-all
(fmakunbound 'bc-bt-foo)
(fmakunbound 'bc-bt-bar)
(fmakunbound 'bc-bt-baz))
- (it "should be printed for each failed spec"
- (with-local-buttercup
- :reporter #'backtrace-reporter
- (describe "suite"
- (it "expect 2" (expect (+ 1 2) :to-equal 2))
- (it "expect nil" (expect nil)))
- (buttercup-run :noerror))
- (expect (buttercup-output) :to-match
- (rx string-start
- (= 2 (seq (= 40 ?=) "\n"
- "suite expect " (or "2" "nil") "\n"
- "\n"
- "Traceback (most recent call last):\n"
- (* (seq " " (+ not-newline) "\n"))
- (or "FAILED" "error") ": " (+ not-newline) "\n\n"))
- string-end)))
+ (describe "should not be collected or printed for"
+ :var (test-suites)
+ (before-each
+ (setq test-suites nil)
+ (spy-on 'buttercup--backtrace :and-call-through)
+ )
+ (it "failed specs"
+ (with-local-buttercup
+ :reporter #'backtrace-reporter
+ (describe "suite"
+ (it "expect 2" (expect (+ 1 2) :to-equal 2))
+ (it "expect nil" (expect nil)))
+ (buttercup-run :noerror)
+ (setq test-suites buttercup-suites))
+ (expect 'buttercup--backtrace :not :to-have-been-called)
+ ;; Checking both if buttercup--backtrace have been called and
+ ;; the failure-stack value might be overkill
+ (expect (cl-every #'null
+ (mapcar #'buttercup-spec-failure-stack
+ (buttercup-suite-children (car test-suites)))))
+ (expect (buttercup-output) :to-match
+ (rx string-start
+ (= 40 ?=) "\nsuite expect " "2" "\nFAILED: " (+
not-newline) "\n\n"
+ (= 40 ?=) "\nsuite expect " "nil" "\nFAILED: " (+
not-newline) "\n\n"
+ string-end)))
+ (it "passed specs"
+ (with-local-buttercup
+ :reporter #'backtrace-reporter
+ (describe "suite"
+ (it "expect 2" (expect (+ 1 1) :to-equal 2))
+ (it "expect t" (expect t)))
+ (buttercup-run :noerror)
+ (setq test-suites buttercup-suites))
+ (expect 'buttercup--backtrace :not :to-have-been-called)
+ ;; Checking both if buttercup--backtrace have been called and
+ ;; the failure-stack value might be overkill
+ (expect (cl-every #'null
+ (mapcar #'buttercup-spec-failure-stack
+ (buttercup-suite-children (car test-suites)))))
+ (expect (buttercup-output) :to-equal ""))
+ (it "skipped specs"
+ (with-local-buttercup
+ :reporter #'backtrace-reporter
+ (describe "one description with"
+ (it "one skipped spec"
+ (buttercup-skip "skip"))
+ (xit "one empty spec")
+ (it "one un-assumed spec"
+ (assume nil "A very unassuming spec")))
+ (buttercup-run :noerror)
+ (setq test-suites buttercup-suites))
+ (expect 'buttercup--backtrace :not :to-have-been-called)
+ ;; Checking both if buttercup--backtrace have been called and
+ ;; the failure-stack value might be overkill
+ (expect (cl-every #'null
+ (mapcar #'buttercup-spec-failure-stack
+ (buttercup-suite-children (car test-suites)))))
+ (expect (buttercup-output) :to-equal "")))
+ (describe "should be collected for errors in"
+ (it "matchers"
+ (put :--failing-matcher 'buttercup-matcher
+ (lambda (&rest _) (/ 1 0)))
+ (with-local-buttercup
+ :reporter #'backtrace-reporter
+ (describe "One suite with"
+ (it "a bad matcher"
+ (expect 1 :--failing-matcher 1)))
+ (buttercup-run :no-error))
+ (put :--failing-matcher 'buttercup-matcher nil)
+ (expect (buttercup-output) :to-equal
+ (concat
+ (make-string 40 ?=) "\n"
+ "One suite with a bad matcher\n"
+ "\n"
+ "Traceback (most recent call last):\n"
+ " :--failing-matcher(1 1)\n"
+ " /(1 0)\n"
+ "error: (arith-error)\n\n"
+ )))
+ )
(describe "with style"
:var (test-suites long-string)
;; Set up tests to test
@@ -2002,6 +2066,8 @@ before it's processed by other functions."
(bc-bt-foo long-string)
:to-be-truthy)))
(setq test-suites buttercup-suites)))
+ (after-each
+ (setq test-suites nil))
(it "`crop' should print truncated lines"
(with-local-buttercup
:suites test-suites :reporter #'backtrace-reporter
@@ -2132,18 +2198,7 @@ before it's processed by other functions."
(matcher-spec ":to-have-been-called-with" :to-have-been-called-with 2)
(matcher-spec ":not :to-have-been-called-with" :not
:to-have-been-called-with 2)
(matcher-spec ":to-have-been-called-times" :to-have-been-called-times 2)
- (matcher-spec ":not :to-have-been-called-times" :not
:to-have-been-called-times 2)))
- (it "should not generate backtraces for skipped specs"
- (let (test-spec)
- (spy-on 'buttercup--backtrace :and-call-through)
- (with-local-buttercup
- (describe "one description"
- (it "with a pending spec")
- (buttercup-skip "skip"))
- (buttercup-run :noerror)
- (setq test-spec (car (buttercup-suite-children (car
buttercup-suites)))))
- (expect 'buttercup--backtrace :not :to-have-been-called)
- (expect (buttercup-spec-failure-stack test-spec) :to-be nil))))
+ (matcher-spec ":not :to-have-been-called-times" :not
:to-have-been-called-times 2))))
(describe "When using quiet specs in the batch reporter"
- [nongnu] elpa/buttercup ee000fabd1 04/16: tests: Cleanup and comments, (continued)
- [nongnu] elpa/buttercup ee000fabd1 04/16: tests: Cleanup and comments, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup 0552fe4d5b 12/16: Add :to-be-close-to docstring, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup c8f34ae3ed 05/16: Limit backtraces for spec exceptions outside expect, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup add32f8cbf 08/16: Collect stacktraces for errors in matchers, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup be72aa872c 06/16: tests: Verify that backtraces are not collected for passed specs, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup 8408579758 16/16: Rewrite buttercup-expect with pcase, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup 925af155be 15/16: tests: Add backtrace tests for function matchers, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup df7f98e110 03/16: Do not collect backtraces for failed specs, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup 4b1682ec98 01/16: Use the base argument of backtrace-frame, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup a1d0d73999 11/16: Improve docstring of buttercup-define-matcher, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup 789570cf7d 10/16: Merge pull request #249 from snogge/fix-247,
ELPA Syncer <=
- [nongnu] elpa/buttercup f577efc524 09/16: Remove remaining uses of `buttercup--mark-stackframe', ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup 9bb00a269d 13/16: Improve the docstring of the expect macro, ELPA Syncer, 2024/09/04
- [nongnu] elpa/buttercup 19e1a86626 14/16: Clarify that buttercup--wrap-expr is only meant for expect, ELPA Syncer, 2024/09/04