[nongnu] elpa/buttercup 638a836 061/340: The batch reporter now displays failures and stack traces.

[ELPA Syncer]

branch: elpa/buttercup
commit 638a8362227e63b2802f992e0c1d14224d261262
Author: Jorgen Schaefer <contact@jorgenschaefer.de>
Commit: Jorgen Schaefer <contact@jorgenschaefer.de>

    The batch reporter now displays failures and stack traces.
---
 buttercup-test.el |  71 +++++++++++++++++++------------
 buttercup.el      | 125 ++++++++++++++++++++++++++++++++++++++++--------------
 2 files changed, 136 insertions(+), 60 deletions(-)

diff --git a/buttercup-test.el b/buttercup-test.el
index 12c859d..eb24062 100644
--- a/buttercup-test.el
+++ b/buttercup-test.el
@@ -29,13 +29,6 @@
             :to-throw
             'buttercup-failed)))
 
-(describe "The buttercup-error signal"
-  (it "can be raised"
-    (expect (lambda ()
-              (signal 'buttercup-error t))
-            :to-throw
-            'buttercup-error)))
-
 (describe "The `expect' form"
   (it "with a matcher should translate directly to the function call"
     (expect (macroexpand '(expect (+ 1 1) :to-equal 2))
@@ -208,6 +201,21 @@
               :to-equal
               2))))
 
+(describe "The `buttercup-suites-total-specs-failed' function"
+  (it "should return the number of failed specs in a list of suites"
+    (let ((su1 (make-buttercup-suite :description "su1"))
+          (su2 (make-buttercup-suite :description "su2"))
+          (sp1 (make-buttercup-spec :description "sp1"))
+          (sp2 (make-buttercup-spec :description "sp2"
+                                    :status 'failed)))
+      (buttercup-suite-add-child su1 su2)
+      (buttercup-suite-add-child su1 sp1)
+      (buttercup-suite-add-child su2 sp2)
+
+      (expect (buttercup-suites-total-specs-failed (list su1))
+              :to-equal
+              1))))
+
 (describe "The `buttercup-suite-full-name' function"
   (let (su1 su2)
     (before-each
@@ -538,7 +546,7 @@
             spec (make-buttercup-spec :description "spec"))
       (buttercup-suite-add-child parent-suite child-suite)
       (buttercup-suite-add-child child-suite spec)
-      (spy-on 'message))
+      (spy-on 'buttercup--print))
 
     (it "should handle the start event"
       (buttercup-reporter-batch 'buttercup-started nil))
@@ -546,18 +554,18 @@
     (it "should emit an indented suite description on suite start"
       (buttercup-reporter-batch 'suite-started child-suite)
 
-      (expect 'message
+      (expect 'buttercup--print
               :to-have-been-called-with
-              "%s%s"
+              "%s%s\n"
               "  "
               "child-suite"))
 
     (it "should emit an indented spec description on spec start"
       (buttercup-reporter-batch 'spec-started spec)
 
-      (expect 'message
+      (expect 'buttercup--print
               :to-have-been-called-with
-              "%s%s"
+              "%s%s\n"
               "    "
               "spec"))
 
@@ -567,12 +575,12 @@
     (it "should emit a newline at the end of the top-level suite"
       (buttercup-reporter-batch 'suite-done parent-suite)
 
-      (expect 'message :to-have-been-called-with ""))
+      (expect 'buttercup--print :to-have-been-called-with "\n"))
 
     (it "should not emit anything at the end of other suites"
       (buttercup-reporter-batch 'suite-done child-suite)
 
-      (expect 'message :not :to-have-been-called))
+      (expect 'buttercup--print :not :to-have-been-called))
 
     (it "should handle the end event"
       (buttercup-reporter-batch 'buttercup-done nil))))
@@ -580,17 +588,24 @@
 ;;;;;;;;;;;;;
 ;;; Utilities
 
-(describe "The `buttercup--funcall' function'"
-  (it "should return passed if everything works fine"
-    (let ((res (buttercup--funcall (lambda () (+ 2 3)))))
-      (expect res
-              :to-equal
-              (list 'passed 5 nil))))
-
-  (it "should return failed with the correct stack if an exception occurred"
-    (let ((res (buttercup--funcall (lambda () (/ 1 0)))))
-      (expect res
-              :to-equal
-              (list 'failed
-                    '(error (arith-error))
-                    (list '(t / 1 0)))))))
+;; We can't test `buttercup--funcall' with buttercup, because the way
+;; we get the backtrace from Emacs does not nest.
+
+(let ((res (buttercup--funcall (lambda () (+ 2 3)))))
+  (when (not (equal res (list 'passed 5 nil)))
+    (error "Expected passing buttercup--funcall not to return %S"
+           res)))
+
+(let ((res (buttercup--funcall (lambda () (buttercup-fail "Bla")))))
+  (when (not (equal res (list 'failed
+                              "Bla"
+                              nil)))
+    (error "Expected failing buttercup--funcall not to return %S"
+           res)))
+
+(let ((res (buttercup--funcall (lambda () (/ 1 0)))))
+  (when (not (equal res (list 'error
+                              '(error (arith-error))
+                              (list '(t / 1 0)))))
+    (error "Expected erroring buttercup--funcall not to return %S"
+           res)))
diff --git a/buttercup.el b/buttercup.el
index 5f2ae75..a5c65b8 100644
--- a/buttercup.el
+++ b/buttercup.el
@@ -48,9 +48,6 @@
 (define-error 'buttercup-failed
   "Buttercup test failed")
 
-(define-error 'buttercup-error
-  "Buttercup test raised an error")
-
 (defmacro expect (arg &optional matcher &rest args)
   "Expect a condition to be true.
 
@@ -215,20 +212,36 @@ MATCHER is either a matcher defined with
 ;;; Suite and spec data structures
 
 (cl-defstruct buttercup-suite
+  ;; The name of this specific suite
   description
+  ;; Any children of this suite, both suites and specs
   children
+  ;; The parent of this suite, another suite
   parent
+  ;; Closure to run before and after each spec in this suite and its
+  ;; children
   before-each
   after-each
+  ;; Likewise, but before and after all specs.
   before-all
-  after-all)
+  after-all
+  ;; These are set if there are errors in after-all.
+  ;; One of: passed failed pending
+  status
+  failure-description
+  failure-stack)
 
-;; Have to define the spec up here instead of with the specs where it
-;; belongs because we `setf' to it here.
 (cl-defstruct buttercup-spec
+  ;; The description of the it form this was generated from
   description
+  ;; The suite this spec is a member of
   parent
-  function)
+  ;; The closure to run for this spec
+  function
+  ;; One of: passed failed pending
+  status
+  failure-description
+  failure-stack)
 
 (defun buttercup-suite-add-child (parent child)
   "Add a CHILD suite to a PARENT suite."
@@ -258,17 +271,32 @@ MATCHER is either a matcher defined with
 (defun buttercup-suites-total-specs-defined (suite-list)
   "Return the number of specs defined in all suites in SUITE-LIST."
   (let ((nspecs 0))
-    (dolist (suite suite-list)
-      (setq nspecs (+ nspecs
-                      (buttercup--total-specs-defined suite))))
+    (dolist (spec-or-suite (buttercup--specs-and-suites suite-list))
+      (when (buttercup-spec-p spec-or-suite)
+        (setq nspecs (1+ nspecs))))
+    nspecs))
+
+(defun buttercup-suites-total-specs-failed (suite-list)
+  "Return the number of failed specs in all suites in SUITE-LIST."
+  (let ((nspecs 0))
+    (dolist (spec-or-suite (buttercup--specs-and-suites suite-list))
+      (when (and (buttercup-spec-p spec-or-suite)
+                 (eq (buttercup-spec-status spec-or-suite) 'failed))
+        (setq nspecs (1+ nspecs))))
     nspecs))
 
-(defun buttercup--total-specs-defined (suite-or-spec)
+(defun buttercup--specs-and-suites (spec-or-suite-list)
   "Return the number of specs defined in SUITE-OR-SPEC and its children."
-  (if (buttercup-spec-p suite-or-spec)
-      1
-    (apply #'+ (mapcar #'buttercup--total-specs-defined
-                       (buttercup-suite-children suite-or-spec)))))
+  (let ((specs-and-suites nil))
+    (dolist (spec-or-suite spec-or-suite-list)
+      (setq specs-and-suites (append specs-and-suites
+                                     (list spec-or-suite)))
+      (when (buttercup-suite-p spec-or-suite)
+        (setq specs-and-suites
+              (append specs-and-suites
+                      (buttercup--specs-and-suites
+                       (buttercup-suite-children spec-or-suite))))))
+    specs-and-suites))
 
 (defun buttercup-suite-full-name (suite)
   "Return the full name of SUITE, which includes the names of the parents."
@@ -624,8 +652,7 @@ Do not change the global value.")
   (let* ((buttercup--before-each (append buttercup--before-each
                                          (buttercup-suite-before-each suite)))
          (buttercup--after-each (append (buttercup-suite-after-each suite)
-                                        buttercup--after-each))
-         (debug-on-error t))
+                                        buttercup--after-each)))
     (funcall buttercup-reporter 'suite-started suite)
     (dolist (f (buttercup-suite-before-all suite))
       (funcall f))
@@ -644,7 +671,13 @@ Do not change the global value.")
   (buttercup--with-cleanup
    (dolist (f buttercup--before-each)
      (funcall f))
-   (funcall (buttercup-spec-function spec))
+   (let ((res (buttercup--funcall (buttercup-spec-function spec))))
+     (setf (buttercup-spec-status spec)
+           (elt res 0))
+     (setf (buttercup-spec-failure-description spec)
+           (elt res 1))
+     (setf (buttercup-spec-failure-stack spec)
+           (elt res 2)))
    (dolist (f buttercup--after-each)
      (funcall f)))
   (funcall buttercup-reporter 'spec-done spec))
@@ -680,33 +713,59 @@ buttercup-done -- All suites have run, the test run is 
over.")
 (defun buttercup-reporter-batch (event arg)
   (pcase event
     (`buttercup-started
-     t)
+     (buttercup--print "Running %s specs.\n\n"
+                       (buttercup-suites-total-specs-defined arg)))
 
     (`suite-started
      (let ((level (length (buttercup-suite-parents arg))))
-       (message "%s%s"
-                (make-string (* 2 level) ?\s)
-                (buttercup-suite-description arg))))
+       (buttercup--print "%s%s\n"
+                         (make-string (* 2 level) ?\s)
+                         (buttercup-suite-description arg))))
 
     (`spec-started
      (let ((level (length (buttercup-spec-parents arg))))
-       (message "%s%s"
-                (make-string (* 2 level) ?\s)
-                (buttercup-spec-description arg))))
+       (buttercup--print "%s%s\n"
+                         (make-string (* 2 level) ?\s)
+                         (buttercup-spec-description arg))))
 
     (`spec-done
-     t)
+     (cond
+      ((eq (buttercup-spec-status arg) 'passed)
+       t)
+      ((eq (buttercup-spec-status arg) 'failed)
+       (let ((description (buttercup-spec-failure-description arg))
+             (stack (buttercup-spec-failure-stack arg)))
+         (when stack
+           (buttercup--print "\nTraceback (most recent call last):\n")
+           (dolist (frame stack)
+             (buttercup--print "  %S\n" (cdr frame))))
+         (if (stringp description)
+             (buttercup--print "FAILED: %s\n"
+                               (buttercup-spec-failure-description arg))
+           (buttercup--print "%S: %S\n\n" (car err) (cdr err)))
+         (buttercup--print "\n")))
+      (t
+       (buttercup--print "??? %S\n" (buttercup-spec-status arg)))))
 
     (`suite-done
      (when (= 0 (length (buttercup-suite-parents arg)))
-       (message "")))
+       (buttercup--print "\n")))
 
     (`buttercup-done
-     t)
+     (buttercup--print "Ran %s specs, %s failed.\n"
+                       (buttercup-suites-total-specs-defined arg)
+                       (buttercup-suites-total-specs-failed arg)
+                       )
+     (when (> (buttercup-suites-total-specs-failed arg) 0)
+       (error "")))
 
     (t
      (error "Unknown event %s" event))))
 
+(defun buttercup--print (fmt &rest args)
+  (let ((print-escape-newlines t))
+    (princ (apply #'format fmt args))))
+
 ;;;;;;;;;;;;;
 ;;; Utilities
 
@@ -718,8 +777,8 @@ Returns a list of three values. The first is the state:
 passed -- The second value is the return value of the function
   call, the third is nil.
 
-failed -- The second value is the error that occurred, the third
-  is the stack trace."
+failed -- The second value is the description of the expectation
+  which failed or the error, the third is the backtrace or nil."
   (catch 'buttercup-debugger-continue
     (let ((debugger #'buttercup--debugger)
           (debug-on-error t)
@@ -733,8 +792,10 @@ failed -- The second value is the error that occurred, the 
third
   ;; subsequent calls. Thanks to ert for this.
   (setq num-nonmacro-input-events (1+ num-nonmacro-input-events))
   (throw 'buttercup-debugger-continue
-         (list 'failed args (buttercup--backtrace))))
-
+         (if (and (eq (elt args 0) 'error)
+                  (eq (car (elt args 1)) 'buttercup-failed))
+             (list 'failed (cdr (elt args 1)) nil)
+           (list 'error args (buttercup--backtrace)))))
 
 (defun buttercup--backtrace ()
   (let* ((n 0)