emacs-elpa-diffs
[Top][All Lists]
Advanced

[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"



reply via email to

[Prev in Thread] Current Thread [Next in Thread]