Merge path-absolute? and better test running.

4 files changed, 79 insertions, 14 deletions

diff --git a/doc/ref/guile/util-path.texi b/doc/ref/guile/util-path.texi
index 322c50ec..2a53ba91 100644
--- a/doc/ref/guile/util-path.texi
+++ b/doc/ref/guile/util-path.texi
@@ -3,7 +3,10 @@
 
 Provided by the module @code{(hnh util path)}.
 
-See also @code{absolute-file-name?} from Guile.
+
+@defun path-absolute? string
+Alias of @code{absolute-file-name?} from Guile.
+@end defun
 
 @defun path-append strings ...
 Joins all strings into a path, squeezing duplicated delimiters, but
diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm
index ea081e85..0c8af48a 100644
--- a/module/hnh/util/path.scm
+++ b/module/hnh/util/path.scm
@@ -3,6 +3,7 @@
   :use-module (srfi srfi-71)
   :use-module (hnh util)
   :export (path-append
+           path-absolute?
            path-join
            path-split
            file-hidden?
@@ -12,6 +13,8 @@
 (define // file-name-separator-string)
 (define /? file-name-separator?)
 
+(define path-absolute? absolute-file-name?)
+
 (define (path-append . strings)
   (fold (lambda (s done)
           (string-append
diff --git a/module/srfi/srfi-64/util.scm b/module/srfi/srfi-64/util.scm
new file mode 100644
index 00000000..a371227f
--- /dev/null
+++ b/module/srfi/srfi-64/util.scm
@@ -0,0 +1,11 @@
+(define-module (srfi srfi-64 util)
+  :use-module (ice-9 curried-definitions)
+  :use-module ((srfi srfi-1) :select (every))
+  :use-module (srfi srfi-64)
+  :export (test-match-group))
+
+;; Specifier for name of group
+(define ((test-match-group name . names) runner)
+  (every string=?
+         (reverse (cons name names))
+         (test-runner-group-stack runner)))
diff --git a/tests/run-tests.scm b/tests/run-tests.scm
index 5270636e..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))
              )
@@ -54,6 +55,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 +94,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 +116,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)
@@ -203,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)
 
@@ -240,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)))