From 47c5ddd16d7bf9f782aa6335055fbda0e9ae8145 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 7 Jul 2022 01:23:48 +0200
Subject: Better expected/actual printing in tests.

---
 tests/run-tests.scm | 35 ++++++++++++++++++++++++++++-------
 1 file changed, 28 insertions(+), 7 deletions(-)

(limited to 'tests')

diff --git a/tests/run-tests.scm b/tests/run-tests.scm
index 5270636e..d868fd2c 100755
--- a/tests/run-tests.scm
+++ b/tests/run-tests.scm
@@ -54,6 +54,24 @@ fi
 (define (make-indent depth)
   (make-string (* 2 depth) #\space))
 
+(define (string-replace-head s1 s2)
+  (string-replace s1 s2
+                  0 (string-length s2)))
+
+(define (pp form indent prefix-1)
+  (let ((prefix (make-string (+ (string-length indent)
+                                (string-length prefix-1))
+                             #\space)))
+    (display
+     (string-replace-head
+      (with-output-to-string
+        (lambda () (pretty-print
+               form
+               per-line-prefix: prefix
+               width: (- 79 (string-length indent)))))
+      (string-append indent prefix-1)))))
+
+
 (define (construct-test-runner)
   (define runner (test-runner-null))
   (define depth 0)
@@ -75,7 +93,10 @@ fi
                 (cond ((test-runner-test-name runner)
                        (negate string-null?) => identity)
                       ((test-result-ref runner 'expected-value)
-                       => (lambda (p) (with-output-to-string (lambda () (display (bold "[SOURCE]: ")) (truncated-print p width: 60))))))))
+                       => (lambda (p) (with-output-to-string
+                                   (lambda ()
+                                     (display (bold "[SOURCE]: "))
+                                     (truncated-print p width: 60))))))))
       (when (eq? 'fail (test-result-kind))
         (cond ((test-result-ref runner 'actual-error)
                => (lambda (err)
@@ -94,12 +115,12 @@ fi
                      (unknown-actual (gensym)))
                  (let ((expected (test-result-ref runner 'expected-value unknown-expected))
                        (actual (test-result-ref runner 'actual-value unknown-actual)))
-                   (if (eq? expected unknown-expected)
-                       (format #t "~aAssertion failed, received ~s~%"
-                               (make-indent (1+ depth)) actual)
-                       (format #t "~aExpected: ~s~%~aReceived: ~s~%"
-                               (make-indent (1+ depth)) expected
-                               (make-indent (1+ depth)) actual))))))
+                   (let ((indent (make-indent (1+ depth))))
+                     (if (eq? expected unknown-expected)
+                         (format #t "~aAssertion failed~%" indent)
+                         (begin
+                           (pp expected indent "Expected: ")
+                           (pp actual indent "Received: "))))))))
         (format #t "~aNear ~a:~a~%"
                 (make-indent (1+ depth))
                 (test-result-ref runner 'source-file)
-- 
cgit v1.2.3


From 34a732ae8e1682b5825970dab6e27ed305626b3a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 7 Jul 2022 01:24:05 +0200
Subject: Tests allows multiple --only and --skip.

---
 tests/run-tests.scm | 39 +++++++++++++++++++++++++++++++++------
 1 file changed, 33 insertions(+), 6 deletions(-)

(limited to 'tests')

diff --git a/tests/run-tests.scm b/tests/run-tests.scm
index d868fd2c..3955a6a2 100755
--- a/tests/run-tests.scm
+++ b/tests/run-tests.scm
@@ -27,6 +27,7 @@ fi
              (ice-9 pretty-print)
              (ice-9 getopt-long)
              (ice-9 match)
+             (ice-9 regex)
              (system vm coverage)
              ((all-modules) :select (fs-find))
              )
@@ -224,9 +225,6 @@ fi
 
 ;; (format #t "Running on:~%~y~%" files)
 
-(awhen (option-ref options 'only #f)
-       (set! files (list (path-append "test" it))))
-
 
 ((@ (hnh util exceptions) warnings-are-errors) #t)
 
@@ -261,9 +259,38 @@ fi
 
 (test-begin "suite")
 
-(awhen (option-ref options 'skip #f)
-       (format #t "Skipping ~s~%" it)
-       (test-skip it))
+
+(define onlies
+  (let %loop ((args (command-line)) (onlies '()))
+    (define* (loop args key: only)
+      (if only
+          (%loop args (cons only onlies))
+          (%loop args onlies)))
+    (if (null? args)
+        onlies
+        (cond ((string-match "^--skip(=.*)?$" (car args))
+               => (lambda (m)
+                    (cond ((match:substring m 1)
+                           => (lambda (s)
+                                (format #t "Skipping ~s~%" s)
+                                (test-skip s)
+                                (loop (cdr args))))
+                          (else (format #t "Skipping ~s~%" (cadr args))
+                                (test-skip (cadr args))
+                                (loop (cddr args))))))
+              ((string-match "^--only(=.*)?$" (car args))
+               => (lambda (m)
+                    (cond ((match:substring m 1)
+                           => (lambda (s)
+                                (loop (cdr args)  only: s)))
+                          (else (loop (cddr args) only: (cadr args))))))
+              (else (loop (cdr args)))))))
+
+(unless (null? onlies)
+  (set! files
+    (map (lambda (x) (path-append "test" x))
+         ;; reverse only until I have built a dependency graph for tests
+         (reverse onlies))))
 
 (finalizer (lambda () (for-each (lambda (f) (catch/print-trace (lambda () (test-group f (load f)))))
                            files)))
-- 
cgit v1.2.3