~ chicken-core (chicken-5) 5176cac7f58c56dc9636ada7b1dc8364d8b06545

commit 5176cac7f58c56dc9636ada7b1dc8364d8b06545
Author:     megane <meganeka@gmail.com>
AuthorDate: Tue Sep 18 11:30:45 2018 +0300
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue Oct 2 12:21:17 2018 +0200

    * tests/scrutinizer-tests.scm (test): Add more information to failure messages
    
    Signed-off-by: Peter Bex <peter@more-magic.net>
    Signed-off-by: felix <felix@call-with-current-continuation.org>

diff --git a/tests/scrutinizer-tests.scm b/tests/scrutinizer-tests.scm
index ed313a49..94ce66bd 100644
--- a/tests/scrutinizer-tests.scm
+++ b/tests/scrutinizer-tests.scm
@@ -9,6 +9,10 @@
 (define-syntax test
   (er-macro-transformer
    (lambda (expr rename _)
+     (define extra-fail-info '())
+     (define (add-fail-info msg)
+       (set! extra-fail-info (cons (string-append "  " msg) extra-fail-info))
+       #f)
      (define pass
        (let loop ((e (cadr expr)))
          (case (car e)
@@ -18,25 +22,36 @@
            ((<=)  (and (type<=? (cadr e) (caddr e))
                        (match-types (caddr e) (cadr e))))
            ;; subtype
-           ((<)   (and (type<=? (cadr e) (caddr e))
-                       (match-types (caddr e) (cadr e))
-                       (not (type<=? (caddr e) (cadr e)))))
+           ((<)   (and (or (type<=? (cadr e) (caddr e))
+			   (add-fail-info "<= returned #f"))
+		       (or (match-types (caddr e) (cadr e))
+			   (add-fail-info ">= returned #f"))
+                       (or (not (type<=? (caddr e) (cadr e)))
+			   (add-fail-info "not >= returned #f"))))
            ;; type equality
-           ((=)   (and (type<=? (cadr e) (caddr e))
-                       (type<=? (caddr e) (cadr e))))
+           ((=)   (and (or (type<=? (cadr e) (caddr e))
+			   (add-fail-info "<= failed"))
+                       (or (type<=? (caddr e) (cadr e))
+			   (add-fail-info ">= failed"))))
            ;; fuzzy match (both directions)
            ((?)   (and (match-types (cadr e) (caddr e))
                        (match-types (caddr e) (cadr e))))
            ;; fuzzy non-match (both directions)
-           ((!)   (and (not (match-types (cadr e) (caddr e)))
-                       (not (match-types (caddr e) (cadr e)))))
+           ((!)   (and (or (not (match-types (cadr e) (caddr e)))
+			   (add-fail-info ">= was true"))
+                       (or (not (match-types (caddr e) (cadr e)))
+			   (add-fail-info "<= was true"))))
            ;; strict non-match (both directions)
            ((><)  (and (not (type<=? (cadr e) (caddr e)))
                        (not (type<=? (caddr e) (cadr e)))))
            ;; A refined with B gives C
-           ((~>)  (equal? (refine-types (cadr e) (caddr e))
-                          (cadddr e))))))
+           ((~>)  (let ((t (refine-types (cadr e) (caddr e))))
+		    (or (equal? t (cadddr e))
+			(add-fail-info
+			 (format "Refined to `~a', but expected `~a'" t (cadddr e)) )))))))
      (printf "[~a] ~a~n" (if pass " OK " "FAIL") (cadr expr))
+     (unless pass
+       (for-each print extra-fail-info))
      (when (not pass) (set! success #f))
      (rename '(void)))))