run-tests.scm

#!/usr/bin/guile \
--debug -e main -s
!#

(use-modules (srfi srfi-64)
             (srfi srfi-71)
             (ice-9 getopt-long)
             (ice-9 format)
             (ice-9 match)
             (system vm coverage))

(define (µs x)
  (* x #e1e6))

(define (transform-time-of-day tod)
  (+ (* (µs 1) (car tod))
     (cdr tod)))

(define* (print-summary runner #:optional (port #t))
  (let ((pass (test-runner-pass-count runner))
        (fail (test-runner-fail-count runner))
        (xpass (test-runner-xpass-count runner))
        (xfail (test-runner-xfail-count runner)))
    (format #t "pass:  ~a~%" pass)
    (format #t "fail:  ~a~%" fail)
    (format #t "xpass: ~a~%" xpass)
    (format #t "xfail: ~a~%" xfail)
    (list pass fail xpass xfail)))

(define* (fmt-header name #:optional (left #\=) (right left))
  (string-append
          (make-string 10 left)
          " " name " "
          (make-string 10 right)))

(define* (construct-test-runner #:key verbose?)
  (lambda ()
    (define totals (list 0 0 0 0))
    (define runner (test-runner-null))
    ;; 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)
        (case (test-result-kind runner)
          ((pass)  (display "\x1b[0;32mX\x1b[m"))
          ((fail)  (newline) (display "\x1b[0;31mE\x1b[m"))
          ((xpass) (display "\x1b[0;33mX\x1b[m"))
          ((xfail) (display "\x1b[0;33mE\x1b[m"))
          ((skip)  (display "\x1B[0;33m-\x1b[m")))
        (when (or verbose? (eq? 'fail (test-result-kind)))
          (format #t " ~a~%" (test-runner-test-name runner)))
        (when (eq? 'fail (test-result-kind))
          (cond ((test-result-ref runner 'actual-error)
                 => (match-lambda
                      ((err-type proc fmt args data)
                       (catch #t (lambda () (format #t "~a in ~a: ~?~%" err-type proc fmt args))
                         (lambda err-err
                           (format #t "~a~%" err-err)
                           (format #t "~s ~s ~s ~s ~s~%"
                                   err-type proc fmt args data))))
                      (err (format #t "Error: ~s~%" err))))
                (else
                 (format #t "Expected: ~s~%Received: ~s~%"
                         (test-result-ref runner 'expected-value "[UNKNOWN]")
                         (test-result-ref runner 'actual-value "[UNKNOWN]"))))
          (format #t "Near ~a:~a~%~y"
                  (test-result-ref runner 'source-file)
                  (test-result-ref runner 'source-line)
                  (test-result-ref runner 'source-form)))

        (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)
        (display (fmt-header name)) (newline)))

    (test-runner-on-group-end! runner
      (lambda (runner)
        (display (fmt-header "Summary" #\-)) (newline)
        (set! totals (map + totals (print-summary runner)))
        (newline)))

    ;; after everything else is done
    (test-runner-on-final! runner
      (lambda (runner)
        (format #t "Guile version ~a~%~a~%"
                (version)
                (fmt-header "Total" #\< #\>))
         totals (print-summary runner)))

    runner))



(define (run-test-file test-file)
  (format #t "Running test in ~a~%" test-file)
  (load
   (format #f "~a/tests/~a"
           (dirname (current-filename))
           test-file)))

(define option-spec
  '((verbose (single-char #\v) (value #f))
    (coverage (value #t))))

(define (main args)
  (define options (getopt-long args option-spec))
  (define verbose? (option-ref options 'verbose #f))
  (define coverage-file )
  (define tests (option-ref options '() '()))
  (define run-tests (lambda () (for-each run-test-file tests)))
  (test-runner-factory (construct-test-runner #:verbose? verbose?))
  (test-begin "All Tests")
  (cond ((option-ref options 'coverage #f)
         => (lambda (file)
              (let ((coverage _ (with-code-coverage run-tests)))
                (call-with-output-file file
                  (lambda (port) (coverage-data->lcov coverage port))))))
        (else (run-tests)))
  (test-end))