1. David Krentzlin
  2. veritas

Commits

certainty  committed ef1e565

updated console reporter to properly report failures

  • Participants
  • Parent commits dca34ad
  • Branches default

Comments (0)

Files changed (5)

File examples/console.scm

View file
  • Ignore whitespace
   ;; reported only once
   (verify subj (is > 0)))
 
-(meta (dissect: #t)
-   (verify 3.0 (is 3.01)))
+;; (meta (dissect: #t)
+;;    (verify 3.0 (is 3.01)))
 
 ;; Grouping
 (group "Root"
         (verify 3 (is 3)))
       (describe "Error with wrapping description"
         (verify 3 (is 4))))))
+
+;; conditions inside verifications
+(define (raising-proc)
+  (error 'raising-proc "This is my error"))
+
+(verify (raising-proc) (is 3))

File reporters/console.scm

View file
  • Ignore whitespace
 (module veritas-console-reporter
   (use-short-formatter use-documentation-formatter current-failure-exit-code current-success-exit-code)
-  (import chicken scheme extras srfi-13)
+  (import chicken scheme extras srfi-13 ports srfi-1)
   (use veritas veritas-base-reporter fmt fmt-color posix (only data-structures conc identity string-split))
 
   (define current-column (make-parameter 0))
           (result (cdr entry)))
       (fmt #t (space-to 4) (cat id ") " (extract-description result) nl))
       (newline)
-      (report-failure-details result)
-      (fmt #t nl)))
+      (report-failure-details result)))
 
   (define (report-failure-details result)
-    (fmt #t (format-failure-lines (verification-result-message result) 8) nl))
+    (cond
+     ((verification-result-condition result)
+      (fmt #t (format-failure-lines (format-condition result) 8)))
+     (else
+      (fmt #t (format-failure-lines (verification-result-message result) 8) nl))))
+
+  (define (format-condition result)
+    (with-output-to-string
+      (lambda ()
+        (let ((condition (verification-result-condition result)))
+          (fmt #t (cat (verification-result-message result) " CONDITION") nl)
+          (newline)
+          (let ((ls (condition->list condition)))
+            (for-each
+             (lambda (elt)
+               (fmt #t (format-condition-kind (car elt) (cdr elt)) nl))
+             ls))
+          (let ((callchain ((condition-property-accessor 'exn 'call-chain '()) condition)))
+            (fmt #t (cleanup-callchain (verification-result-stacktrace result))))))))
+
+  (define (cleanup-callchain string)
+    (string-join
+     (map (lambda (line) (string-trim line #\tab))
+          (string-split string "\n"))
+     "\n"))
+
+  (define (format-condition-kind kind properties)
+    (with-output-to-string
+      (lambda ()
+        (let* ((props (remove (lambda (elt) (eq? 'call-chain (car elt))) properties))
+               (->string    (lambda (e) (sprintf "~a" e)))
+               (prop-keys   (map (o ->string car) props))
+               (prop-values (map (o ->string cadr) props)))
+          (fmt #t (cat "Kind: " kind) nl)
+          (fmt #t "Properties: " nl)
+          (fmt #t (tabular " | "
+                           (dsp (string-join prop-keys " \n")) " | "
+                           (dsp (string-join prop-values " \n")) " | ") nl)))))
 
   (define (format-failure-lines text spaces)
-    (apply cat (map (lambda (text) (cat (space-to spaces) ((colorize fmt-red) text) nl)) (string-split text "\n"))))
+    (apply cat (map (lambda (text) (cat (space-to spaces) ((colorize fmt-red) text) nl)) (string-split text "\n" #t))))
 
   (define (report-summary)
     (if (reporter-use-colors?)

File reporters/repl.scm

View file
  • Ignore whitespace
     (display (conc (current-success-designator) "  ") out))
 
   (define (print-failure/colors result out)
-    (fmt out (fmt-red (fmt-bold (cat (current-failure-designator) "  "))))
+    (fmt out (fmt-red (fmt-bold (cat (current-failure-designator) "  FAILED"))) nl)
     (fmt out (fmt-red (verification-result-message result))))
 
   (define (print-failure/nocolors result out)

File verifiers/is.scm

View file
  • Ignore whitespace
           (printf "     got: ~s~%" actual)
           (when (or (> (length actual-lines) 1) (> (length expected-lines) 1))
             (let ((hunks (textdiff actual-lines expected-lines 3)))
-              (print " \n")
-              (print "Diff:")
-              (print " \n")
+              (print "\nDiff:")
               ((make-format-textdiff 'context) (current-output-port) hunks "actual" "" "expected" "")))))))
    (else
     (with-output-to-string

File veritas.scm

View file
  • Ignore whitespace
 (module veritas
   *
-  (import chicken scheme data-structures extras srfi-1 kvlists)
+  (import chicken scheme data-structures extras srfi-1 kvlists ports)
   (require-library matchable kvlists)
   (import-for-syntax matchable)
 
 (define current-meta-data (make-parameter '()))
 
 (define-record verification-subject quoted-expression expression-promise meta-data)
-(define-record verification-result id subject message status)
+(define-record verification-result id subject message status condition stacktrace)
 
-(define (fail    subject message) (make-verification-result 'nil subject message 'fail))
-(define (pass    subject)         (make-verification-result 'nil subject "" 'pass))
-(define (pending subject)         (make-verification-result 'nil subject "" 'pending))
+(define (fail    subject message) (make-verification-result #f subject message 'fail #f #f))
+(define (pass    subject)         (make-verification-result #f subject "" 'pass #f #f))
+(define (pending subject)         (make-verification-result #f subject "" 'pending #f #f))
 
 (define (verification-failure? result)
   (and (verification-result? result)
 (define (apply-verifier subject verifier complement?)
   (notify-verification 'start subject verifier)
   (let ((result (condition-case (verifier subject complement?)
-                  (e () (condition->verification-failure e)))))
+                  (e () (condition->verification-failure subject e (with-output-to-string print-call-chain))))))
     (notify-verification 'end subject verifier result)
     result))
 
-(define (condition->verification-failure condition) #t)
+(define (condition->verification-failure subject condition stacktrace)
+  (make-verification-result 'nil subject (get-condition-property condition 'exn 'message) 'fail condition stacktrace))
 
 ;; the verifier protocol is simple
 ;; a verifier is a procedure that returns a procedure of two arguments