Move test runner to library.

This will both allow us multiple test entry points, since some
integration tests doesn't fit to well in our current unit test
setup.

It will hopefully also allow me to reuse the code in other projects.

3 files changed, 185 insertions, 157 deletions

diff --git a/module/hnh/test/testrunner.scm b/module/hnh/test/testrunner.scm
new file mode 100644
index 00000000..384afd4b
--- /dev/null
+++ b/module/hnh/test/testrunner.scm
@@ -0,0 +1,126 @@
+(define-module (hnh test testrunner)
+  :use-module (srfi srfi-64)
+  :use-module (hnh test util)
+  :use-module (ice-9 pretty-print)
+  :use-module (ice-9 format)
+  :export (verbose? construct-test-runner)
+  )
+
+(define verbose? (make-parameter #f))
+
+(define (pp form indent prefix-1)
+  (let ((prefix (make-string (+ (string-length indent)
+                                (string-length prefix-1))
+                             #\space)))
+    (string-replace-head
+     (with-output-to-string
+       (lambda () (pretty-print
+              form
+              display?: #t
+              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)
+  ;; end of individual test case
+  (test-runner-on-test-begin! runner
+    (lambda (runner)
+      (test-runner-aux-value! runner (transform-time-of-day (gettimeofday)))))
+  (test-runner-on-test-end! runner
+    (lambda (runner)
+      (when (verbose?) (display (make-indent depth)))
+      (case (test-result-kind runner)
+        ((pass)  (display (green "X")))
+        ((fail)  (display (red "E")))
+        ((xpass) (display (yellow "X")))
+        ((xfail) (display (yellow "E")))
+        ((skip)  (display (yellow "-"))))
+      (when (or (verbose?) (eq? 'fail (test-result-kind)))
+        (format #t " ~a~%"
+                (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))))))))
+      (when (eq? 'fail (test-result-kind))
+        (cond ((test-result-ref runner 'actual-error)
+               => (lambda (err)
+                    (if (and (list? err)
+                             (= 5 (length err)))
+                        (let ((err (list-ref err 0))
+                              (proc (list-ref err 1))
+                              (fmt (list-ref err 2))
+                              (args (list-ref err 3)))
+                         (format #t "~a~a in ~a: ~?~%"
+                                 (make-indent (1+ depth))
+                                 err proc fmt args))
+                        (format #t "~aError: ~s~%" (make-indent (1+ depth)) err))))
+              (else
+               (let ((unknown-expected (gensym))
+                     (unknown-actual (gensym)))
+                 (let ((expected (test-result-ref runner 'expected-value unknown-expected))
+                       (actual (test-result-ref runner 'actual-value unknown-actual)))
+                   (let ((indent (make-indent (1+ depth))))
+                     (if (eq? expected unknown-expected)
+                         (format #t "~aAssertion failed~%" indent)
+                         (begin
+                           (display (pp expected indent "Expected: "))
+                           (display (pp actual indent "Received: "))
+                           (let ((d (diff (pp expected "" "")
+                                          (pp actual "" ""))))
+                             (display
+                              (string-join
+                               (map (lambda (line) (string-append indent "|" line))
+                                    (string-split d #\newline))
+                               "\n" 'suffix))))))))))
+        (format #t "~aNear ~a:~a~%"
+                (make-indent (1+ depth))
+                (test-result-ref runner 'source-file)
+                (test-result-ref runner 'source-line))
+        (pretty-print (test-result-ref runner 'source-form)
+                      (current-output-port)
+                      per-line-prefix: (string-append (make-indent (1+ depth)) "> ")
+                      ))
+
+      (let ((start (test-runner-aux-value runner))
+            (end (transform-time-of-day (gettimeofday))))
+        (when (< (µs 1) (- end start))
+          (format #t "~%Slow test: ~s, took ~a~%"
+                  (test-runner-test-name runner)
+                  (exact->inexact (/ (- end start) (µs 1)))
+                  )))))
+
+  ;; on start of group
+  (test-runner-on-group-begin! runner
+    ;; count is number of #f
+    (lambda (runner name count)
+      (if (<= depth 1)
+          (format #t "~a ~a ~a~%"
+                  (make-string 10 #\=)
+                  name
+                  (make-string 10 #\=))
+          (when (verbose?)
+           (format #t "~a~a~%" (make-string (* depth 2) #\space) name)))
+      (set! depth (1+ depth))))
+  (test-runner-on-group-end! runner
+    (lambda (runner)
+      (set! depth (1- depth))
+      (when (<= depth 1)
+        (newline))))
+  ;; after everything else is done
+  (test-runner-on-final! runner
+    (lambda (runner)
+      (format #t "Guile version ~a~%~%" (version))
+      (format #t "pass:  ~a~%" (test-runner-pass-count runner))
+      (format #t "fail:  ~a~%" (test-runner-fail-count runner))
+      (format #t "xpass: ~a~%" (test-runner-xpass-count runner))
+      (format #t "xfail: ~a~%" (test-runner-xfail-count runner))
+      ))
+
+  runner)
+
diff --git a/module/hnh/test/util.scm b/module/hnh/test/util.scm
new file mode 100644
index 00000000..3d51e162
--- /dev/null
+++ b/module/hnh/test/util.scm
@@ -0,0 +1,57 @@
+(define-module (hnh test util)
+  :use-module ((hnh util) :select (begin1))
+  :use-module ((hnh util io) :select (call-with-tmpfile))
+  :use-module (ice-9 pretty-print)
+  :use-module ((ice-9 rdelim) :select (read-string))
+  :use-module ((ice-9 popen)
+               :select (open-pipe*
+                        close-pipe))
+  :export (µs
+           transform-time-of-day
+           green
+           red
+           yellow
+           bold
+           make-indent
+           string-replace-head
+           diff
+           ))
+
+(define (µs x)
+  (* x #e1e6))
+
+(define (transform-time-of-day tod)
+  (+ (* (µs 1) (car tod))
+     (cdr tod)))
+
+(define (escaped sequence string)
+  (format #f "\x1b[~am~a\x1b[m" sequence string))
+
+;; Terminal output formatting. Doesn NOT compose
+(define (green s)  (escaped 32 s))
+(define (red s)    (escaped 31 s))
+(define (yellow s) (escaped 33 s))
+(define (bold s)   (escaped  1 s))
+
+(define (make-indent depth)
+  (make-string (* 2 depth) #\space))
+
+(define (string-replace-head s1 s2)
+  (string-replace s1 s2
+                  0 (string-length s2)))
+
+
+(define diff-cmd
+  ;; '("diff")
+  '("git" "diff" "--no-index" "--color-moved=default" "--color=always"; "--word-diff=color"
+    )
+  )
+
+(define (diff s1 s2)
+  (let ((filename1 (call-with-tmpfile (lambda (p f) (pretty-print s1 p display?: #t) f)))
+        (filename2 (call-with-tmpfile (lambda (p f) (pretty-print s2 p display?: #t) f))))
+    (let ((pipe (apply open-pipe*
+                 OPEN_READ
+                 (append diff-cmd (list filename1 filename2)))))
+      (begin1 (read-string pipe)
+              (close-pipe pipe)))))
diff --git a/tests/run-tests.scm b/tests/run-tests.scm
index f1ff7b03..d3ba53f8 100755
--- a/tests/run-tests.scm
+++ b/tests/run-tests.scm
@@ -20,11 +20,8 @@ fi
 (use-modules (srfi srfi-1)
              (srfi srfi-64)
              (srfi srfi-88)
-             (hnh util)
              ((hnh util io) :select (call-with-tmpfile))
-             (ice-9 ftw)
              (ice-9 format)
-             (ice-9 pretty-print)
              (ice-9 getopt-long)
              (ice-9 match)
              (ice-9 regex)
@@ -34,164 +31,12 @@ fi
              ((ice-9 rdelim) :select (read-string))
              (system vm coverage)
              ((hnh module-introspection all-modules) :select (fs-find))
+
+             (hnh test testrunner)
              )
 
 
 
-
-(define diff-cmd '("diff")
-  ;; '("git" "diff" "--no-index" "--word-diff=color")
-  )
-
-(define (µs x)
-  (* x #e1e6))
-
-(define (transform-time-of-day tod)
-  (+ (* (µs 1) (car tod))
-     (cdr tod)))
-
-(define verbose? (make-parameter #f))
-
-(define (escaped sequence string)
-  (format #f "\x1b[~am~a\x1b[m" sequence string))
-
-(define (green s)  (escaped 32 s))
-(define (red s)    (escaped 31 s))
-(define (yellow s) (escaped 33 s))
-(define (bold s)   (escaped  1 s))
-
-(define (make-indent depth)
-  (make-string (* 2 depth) #\space))
-
-(define (string-replace-head s1 s2)
-  (string-replace s1 s2
-                  0 (string-length s2)))
-
-(define (diff s1 s2)
-  (let ((filename1 (call-with-tmpfile (lambda (p f) (pretty-print s1 p display?: #t) f)))
-        (filename2 (call-with-tmpfile (lambda (p f) (pretty-print s2 p display?: #t) f))))
-    (let ((pipe (apply open-pipe*
-                 OPEN_READ
-                 (append diff-cmd (list filename1 filename2)))))
-      (begin1 (read-string pipe)
-              (close-pipe pipe)))))
-
-(define (pp form indent prefix-1)
-  (let ((prefix (make-string (+ (string-length indent)
-                                (string-length prefix-1))
-                             #\space)))
-    (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)
-  ;; end of individual test case
-  (test-runner-on-test-begin! runner
-    (lambda (runner)
-      (test-runner-aux-value! runner (transform-time-of-day (gettimeofday)))))
-  (test-runner-on-test-end! runner
-    (lambda (runner)
-      (flush-all-ports)
-      (when (verbose?) (display (make-indent depth)))
-      (case (test-result-kind runner)
-        ((pass)  (display (green "X")))
-        ((fail)  (display (red "E")))
-        ((xpass) (display (yellow "X")))
-        ((xfail) (display (yellow "E")))
-        ((skip)  (display (yellow "-"))))
-      (when (or (verbose?) (eq? 'fail (test-result-kind)))
-        (format #t " ~a~%"
-                (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))))))))
-      (when (eq? 'fail (test-result-kind))
-        (cond ((test-result-ref runner 'actual-error)
-               => (lambda (err)
-                    (if (and (list? err)
-                             (= 5 (length err)))
-                        (let ((err (list-ref err 0))
-                              (proc (list-ref err 1))
-                              (fmt (list-ref err 2))
-                              (args (list-ref err 3)))
-                         (format #t "~a~a in ~a: ~?~%"
-                                 (make-indent (1+ depth))
-                                 err proc fmt args))
-                        (format #t "~aError: ~s~%" (make-indent (1+ depth)) err))))
-              (else
-               (let ((unknown-expected (gensym))
-                     (unknown-actual (gensym)))
-                 (let ((expected (test-result-ref runner 'expected-value unknown-expected))
-                       (actual (test-result-ref runner 'actual-value unknown-actual)))
-                   (let ((indent (make-indent (1+ depth))))
-                     (if (eq? expected unknown-expected)
-                         (format #t "~aAssertion failed~%" indent)
-                         (begin
-                           (display (pp expected indent "Expected: "))
-                           (display (pp actual indent "Received: "))
-                           (let ((d (diff (pp expected "" "")
-                                          (pp actual "" ""))))
-                             (display
-                              (string-join
-                               (map (lambda (line) (string-append indent "|" line))
-                                    (string-split d #\newline))
-                               "\n" 'suffix))))))))))
-        (format #t "~aNear ~a:~a~%"
-                (make-indent (1+ depth))
-                (test-result-ref runner 'source-file)
-                (test-result-ref runner 'source-line))
-        (pretty-print (test-result-ref runner 'source-form)
-                      (current-output-port)
-                      per-line-prefix: (string-append (make-indent (1+ depth)) "> ")
-                      ))
-
-      (let ((start (test-runner-aux-value runner))
-            (end (transform-time-of-day (gettimeofday))))
-        (when (< (µs 1) (- end start))
-          (format #t "~%Slow test: ~s, took ~a~%"
-                  (test-runner-test-name runner)
-                  (exact->inexact (/ (- end start) (µs 1)))
-                  )))))
-
-  ;; on start of group
-  (test-runner-on-group-begin! runner
-    ;; count is number of #f
-    (lambda (runner name count)
-      (if (<= depth 1)
-          (format #t "~a ~a ~a~%"
-                  (make-string 10 #\=)
-                  name
-                  (make-string 10 #\=))
-          (when (verbose?)
-           (format #t "~a~a~%" (make-string (* depth 2) #\space) name)))
-      (set! depth (1+ depth))))
-  (test-runner-on-group-end! runner
-    (lambda (runner)
-      (set! depth (1- depth))
-      (when (<= depth 1)
-        (newline))))
-  ;; after everything else is done
-  (test-runner-on-final! runner
-    (lambda (runner)
-      (format #t "Guile version ~a~%~%" (version))
-      (format #t "pass:  ~a~%" (test-runner-pass-count runner))
-      (format #t "fail:  ~a~%" (test-runner-fail-count runner))
-      (format #t "xpass: ~a~%" (test-runner-xpass-count runner))
-      (format #t "xfail: ~a~%" (test-runner-xfail-count runner))
-      ))
-
-  runner)
-
 (test-runner-factory construct-test-runner)