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.

1 files changed, 126 insertions, 0 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)
+