diff options
Diffstat (limited to 'module')
| -rw-r--r-- | module/hnh/test/testrunner.scm | 152 | ||||
| -rw-r--r-- | module/hnh/util/atomic-queue.scm | 49 | ||||
| -rw-r--r-- | module/hnh/util/atomic-stack.scm | 43 | ||||
| -rw-r--r-- | module/hnh/util/atomic.scm | 11 | ||||
| -rw-r--r-- | module/hnh/util/coverage.scm | 3 |
5 files changed, 196 insertions, 62 deletions
diff --git a/module/hnh/test/testrunner.scm b/module/hnh/test/testrunner.scm index 384afd4b..38df0ee1 100644 --- a/module/hnh/test/testrunner.scm +++ b/module/hnh/test/testrunner.scm @@ -1,8 +1,11 @@ (define-module (hnh test testrunner) :use-module (srfi srfi-64) :use-module (hnh test util) + :use-module (hnh util type) + :use-module (hnh util atomic-queue) :use-module (ice-9 pretty-print) :use-module (ice-9 format) + :use-module (ice-9 curried-definitions) :export (verbose? construct-test-runner) ) @@ -21,97 +24,124 @@ width: (- 79 (string-length indent))))) (string-append indent prefix-1)))) +;;; Return a "name" for the test. +;;; If the test was explicitly named, than that name will be used. +;;; Otherwise a string describing the expected value will be returned. +(define (test-runner-test-name/description runner) + (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))))))) -(define (construct-test-runner) + +(define (test-runner-describe-error runner depth) + (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)) "> "))) + +(define ((construct-test-runner print err-queue)) + (typecheck err-queue atomic-queue?) (define runner (test-runner-null)) + ;; TODO wouldn't `depth` need to be atomic to work? (define depth 0) - ;; end of individual test case + (test-runner-on-test-begin! runner (lambda (runner) + ;; This should be thread local, TODO test that (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)))))))) + (display + (case (test-result-kind runner) + ((pass) (green "X")) + ((fail) (red "E")) + ((xpass) (red "X")) + ((xfail) (yellow "E")) + ((skip) (yellow "-")))) + + (when (or (verbose?) #;(eq? 'fail (test-result-kind))) + (format #t " ~a~%" (test-runner-test-name/description runner))) + (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)) "> ") - )) + (enqueue! + (with-output-to-string + (lambda () + (display + (red (format #f "Test failed: ~a~%" + (test-runner-test-name/description runner)))) + (test-runner-describe-error runner 0))) + err-queue)) (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))) - ))))) + (enqueue! + (format #f "~%Slow test: ~s, took ~a~%" + (test-runner-test-name/description runner) + (exact->inexact (/ (- end start) (µs 1)))) + err-queue))) + + )) ;; on start of group (test-runner-on-group-begin! runner ;; count is number of #f (lambda (runner name count) - (if (<= depth 1) + (if (<= depth 0) (format #t "~a ~a ~a~%" (make-string 10 #\=) name (make-string 10 #\=)) (when (verbose?) - (format #t "~a~a~%" (make-string (* depth 2) #\space) name))) + (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) diff --git a/module/hnh/util/atomic-queue.scm b/module/hnh/util/atomic-queue.scm new file mode 100644 index 00000000..2ab0c2ef --- /dev/null +++ b/module/hnh/util/atomic-queue.scm @@ -0,0 +1,49 @@ +(define-module (hnh util atomic-queue) + :use-module (srfi srfi-18) ; Threading + :use-module (rnrs records syntactic) + :use-module (rnrs exceptions) + ;; :use-module (rnrs mutable-pair) + :use-module (hnh util atomic) + :use-module (hnh util type) + :use-module ((hnh util) :select (begin1)) + :export (atomic-queue + atomic-queue? + queue-peek queue->list + enqueue! dequeue!)) + + + +;;; Items are added at the back, and poped from the front + +(define-record-type (queue %atomic-queue atomic-queue?) + (fields front + (mutable back) + front-mutex back-mutex) + (sealed #t) + (opaque #t)) + +(define (atomic-queue) + (let ((p (list 'FRONT))) + (%atomic-queue p p (make-mutex) (make-mutex)))) + +(define (enqueue! value q) + (typecheck q atomic-queue?) + (with-mutex (queue-back-mutex q) + (set-cdr! (queue-back q) (list value)) + (queue-back-set! q (cdr (queue-back q))))) + +(define (queue-peek q) + (typecheck q atomic-queue?) + (cadr (queue-front q))) + +(define (dequeue! q) + (typecheck q atomic-queue?) + (with-mutex (queue-front-mutex q) + (guard (_ (else #f)) + (begin1 (queue-peek q) + (set-cdr! (queue-front q) + (cddr (queue-front q))))))) + +(define (queue->list q) + (typecheck q atomic-queue?) + (cdr (queue-front q))) diff --git a/module/hnh/util/atomic-stack.scm b/module/hnh/util/atomic-stack.scm new file mode 100644 index 00000000..6b17724d --- /dev/null +++ b/module/hnh/util/atomic-stack.scm @@ -0,0 +1,43 @@ +(define-module (hnh util atomic-stack) + :use-module (srfi srfi-18) ; Threading + :use-module (rnrs records syntactic) + :use-module (rnrs exceptions) + :use-module (hnh util atomic) + :use-module ((hnh util type) :select (typecheck)) + :use-module ((hnh util) :select (begin1)) + :export (atomic-stack + atomic-stack? + stack-peek stack->list + push! pop!)) + +(define-record-type (stack %atomic-stack atomic-stack?) + (fields (mutable contents) + mutex) + (sealed #t) + (opaque #t)) + +(define (atomic-stack) + (%atomic-stack '() (make-mutex))) + +(define (stack->list stack) + (stack-contents stack)) + +(define (push! value stack) + (typecheck stack atomic-stack?) + (with-mutex (stack-mutex stack) + (stack-contents-set! + stack + (cons value (stack-contents stack))))) + +(define (stack-peek stack) + (typecheck stack atomic-stack?) + (car (stack-contents stack))) + +(define (pop! stack) + (typecheck stack atomic-stack?) + (with-mutex (stack-mutex stack) + (guard (_ (else #f)) + (begin1 (stack-peek stack) + (stack-contents-set! + stack (cdr (stack-contents stack))))))) + diff --git a/module/hnh/util/atomic.scm b/module/hnh/util/atomic.scm new file mode 100644 index 00000000..1deba2c1 --- /dev/null +++ b/module/hnh/util/atomic.scm @@ -0,0 +1,11 @@ +(define-module (hnh util atomic) + :use-module (srfi srfi-18) + :export (with-mutex)) + +(define-syntax with-mutex + (syntax-rules () + ((_ mutex body ...) + (dynamic-wind + (lambda () (mutex-lock! mutex)) + (lambda () body ...) + (lambda () (mutex-unlock! mutex)))))) diff --git a/module/hnh/util/coverage.scm b/module/hnh/util/coverage.scm index 2517e81f..9b76411b 100644 --- a/module/hnh/util/coverage.scm +++ b/module/hnh/util/coverage.scm @@ -63,7 +63,7 @@ (fold (lambda (line state) (match (parse-coverage-line line) (('DA line hits) - (modify state (compose-lens car* lines) + (modify state (compose-lenses car* lines) (lambda (lines) (cons (cons line hits) lines)))) (('SF source) (set state car* filename source)) @@ -86,6 +86,7 @@ "Can only merge coverage data for the same file, got ~s and ~s" (list (filename a) (filename b)) #f)) + #; (unless (= (total-lines a) (total-lines b)) (scm-error 'misc-error "merge-coverage" "Mismatch between found lines. Is it really the same file? File: ~s, got ~s and ~s" |