250 lines
9.2 KiB
Scheme
250 lines
9.2 KiB
Scheme
(define-library
|
|
(retropikzel ctrf)
|
|
(cond-expand
|
|
(chezscheme
|
|
(import (rnrs)
|
|
(srfi 64)
|
|
(srfi 69)
|
|
(srfi 180)))
|
|
(else
|
|
(import (scheme base)
|
|
(scheme write)
|
|
(scheme time)
|
|
(scheme process-context)
|
|
(srfi 64)
|
|
(srfi 69)
|
|
(srfi 180))))
|
|
(export test-begin
|
|
test-end
|
|
test-group
|
|
test-group-with-cleanup
|
|
test-skip
|
|
test-expect-fail
|
|
test-match-name
|
|
test-match-nth
|
|
test-match-all
|
|
test-match-any
|
|
test-assert
|
|
test-eqv
|
|
test-eq
|
|
test-equal
|
|
test-approximate
|
|
test-error
|
|
test-read-eval-string
|
|
test-apply test-with-runner
|
|
test-exit
|
|
test-runner-null
|
|
test-runner?
|
|
test-runner-reset
|
|
test-result-alist
|
|
test-result-alist!
|
|
test-result-ref
|
|
test-result-set!
|
|
test-result-remove
|
|
test-result-clear
|
|
test-runner-pass-count
|
|
test-runner-fail-count
|
|
test-runner-xpass-count
|
|
test-runner-xfail-count
|
|
test-runner-skip-count
|
|
test-runner-test-name
|
|
test-runner-group-path
|
|
test-runner-group-stack
|
|
test-runner-aux-value
|
|
test-runner-aux-value!
|
|
test-result-kind test-passed?
|
|
test-runner-on-test-begin
|
|
test-runner-on-test-begin!
|
|
test-runner-on-test-end
|
|
test-runner-on-test-end!
|
|
test-runner-on-group-begin
|
|
test-runner-on-group-begin!
|
|
test-runner-on-group-end
|
|
test-runner-on-group-end!
|
|
test-runner-on-final
|
|
test-runner-on-final!
|
|
test-runner-on-bad-count
|
|
test-runner-on-bad-count!
|
|
test-runner-on-bad-end-name
|
|
test-runner-on-bad-end-name!
|
|
test-runner-factory
|
|
test-runner-create
|
|
test-runner-current
|
|
test-runner-get
|
|
test-runner-simple
|
|
test-on-group-begin-simple
|
|
test-on-group-end-simple
|
|
test-on-final-simple
|
|
test-on-test-begin-simple
|
|
test-on-test-end-simple
|
|
test-on-bad-count-simple
|
|
test-on-bad-end-name-simple)
|
|
(cond-expand
|
|
;; Guile has both r6rs and r7rs on (features)
|
|
(guile
|
|
(begin (define operation-system
|
|
(cond-expand
|
|
(windows "windows")
|
|
(else "unix")))))
|
|
(r6rs
|
|
(begin (define operation-system "unknown")))
|
|
(else
|
|
(begin (define operation-system
|
|
(cond-expand
|
|
(windows "windows")
|
|
(linux "linux")
|
|
(else "other"))))))
|
|
(cond-expand
|
|
(chezscheme (begin (define implementation-name "chezscheme")))
|
|
(chibi (begin (define implementation-name "chibi")))
|
|
(chicken (begin (define implementation-name "chicken")))
|
|
(cyclone (begin (define implementation-name "cyclone")))
|
|
(gambit (begin (define implementation-name "gambit")))
|
|
(gauche (begin (define implementation-name "gauche")))
|
|
(guile (begin (define implementation-name "guile")))
|
|
(ikarus (begin (define implementation-name "ikarus")))
|
|
(ironscheme (begin (define implementation-name "ironscheme")))
|
|
(kawa (begin (define implementation-name "kawa")))
|
|
(mit-scheme (begin (define implementation-name "mit-scheme")))
|
|
(mosh (begin (define implementation-name "mosh")))
|
|
(racket (begin (define implementation-name "racket")))
|
|
(sagittarius (begin (define implementation-name "sagittarius")))
|
|
(stklos (begin (define implementation-name "stklos")))
|
|
(tr7 (begin (define implementation-name "tr7")))
|
|
(ypsilon (begin (define implementation-name "ypsilon")))
|
|
(else (begin (define implementation-name "unknown"))))
|
|
(cond-expand
|
|
(r6rs
|
|
(begin
|
|
(define (time-ms)
|
|
;; FIXME
|
|
0)))
|
|
(else
|
|
(begin
|
|
(define (time-ms) (/ (/ (current-jiffy) (jiffies-per-second)) 1000)))))
|
|
(begin
|
|
(define (any->string any)
|
|
(parameterize
|
|
((current-output-port (open-output-string)))
|
|
(display any)
|
|
(get-output-string (current-output-port))))
|
|
|
|
(define runner
|
|
(lambda ()
|
|
(let ((runner (test-runner-null))
|
|
(tests (list))
|
|
(current-test-start-time 0)
|
|
(current-test-groups '()))
|
|
|
|
(test-runner-on-group-begin!
|
|
runner
|
|
(lambda (runner suite-name count)
|
|
(set! current-test-groups (append current-test-groups (list suite-name)))))
|
|
|
|
(test-runner-on-group-end!
|
|
runner
|
|
(lambda (runner)
|
|
(set! current-test-groups
|
|
(reverse (list-tail (reverse current-test-groups) 1)))))
|
|
|
|
(test-runner-on-test-begin!
|
|
runner
|
|
(lambda (runner)
|
|
(set! current-test-start-time (time-ms))))
|
|
|
|
(test-runner-on-test-end!
|
|
runner
|
|
(lambda (runner)
|
|
(let* ((name (test-runner-test-name runner))
|
|
(result (test-result-kind runner))
|
|
(status (cond ((equal? result 'pass) "passed")
|
|
((equal? result 'xpass) "passed")
|
|
((equal? result 'fail) "failed")
|
|
((equal? result 'xfail) "failed")
|
|
((equal? result 'skipped) "skipped")
|
|
(else "other")))
|
|
(duration (exact (floor (- (time-ms) current-test-start-time))))
|
|
(extra (make-hash-table)))
|
|
|
|
(when (test-result-ref runner 'expected-value)
|
|
(hash-table-set! extra
|
|
'expected-value
|
|
(test-result-ref runner 'expected-value)))
|
|
|
|
(when (test-result-ref runner 'actual-value)
|
|
(hash-table-set! extra
|
|
'actual-value
|
|
(test-result-ref runner 'actual-value)))
|
|
|
|
(when (test-result-ref runner 'expected-error)
|
|
(hash-table-set! extra
|
|
'expected-error
|
|
(test-result-ref runner 'expected-error)))
|
|
|
|
(when (test-result-ref runner 'actual-error)
|
|
(hash-table-set! extra
|
|
'actual-error
|
|
(test-result-ref runner 'actual-error)))
|
|
|
|
(when (test-result-ref runner 'source-form)
|
|
(hash-table-set! extra
|
|
'source-form
|
|
(any->string (test-result-ref runner 'source-form))))
|
|
|
|
(let ((test (alist->hash-table
|
|
`((name . ,name)
|
|
(status . ,status)
|
|
(duration . ,duration)
|
|
(suite . ,current-test-groups)
|
|
(extra . ,extra)))))
|
|
|
|
(when (test-result-ref runner 'source-file)
|
|
(hash-table-set! extra
|
|
'filePath
|
|
(test-result-ref runner 'source-file)))
|
|
|
|
(when (test-result-ref runner 'source-line)
|
|
(hash-table-set! extra
|
|
'line
|
|
(test-result-ref runner 'source-line)))
|
|
|
|
(set! tests (append tests (list test)))))))
|
|
|
|
(test-runner-on-final!
|
|
runner
|
|
(lambda (runner)
|
|
(let*
|
|
((pass (test-runner-pass-count runner))
|
|
(xpass (test-runner-xpass-count runner))
|
|
(fail (test-runner-fail-count runner))
|
|
(xfail (test-runner-xfail-count runner))
|
|
(skipped (test-runner-skip-count runner))
|
|
(tool (alist->hash-table
|
|
`((name . "srfi-64-retropikzel-ctrf"))))
|
|
(summary (alist->hash-table
|
|
`((tests . ,(+ pass xpass fail xfail))
|
|
(passed . ,(+ pass xpass))
|
|
(failed . ,(+ fail xfail))
|
|
(pending . 0)
|
|
(skipped . ,skipped)
|
|
(other . 0))))
|
|
(results (alist->hash-table
|
|
`((tool . ,tool)
|
|
(summary . ,summary)
|
|
(tests . ,tests))))
|
|
(env (alist->hash-table
|
|
`((appName . ,implementation-name)
|
|
(osPlatform . ,operation-system))))
|
|
(output (alist->hash-table
|
|
`((reportFormat . "CTRF")
|
|
(specVersion . "0.0.0")
|
|
(results . ,results)
|
|
(generatedBy . "(retropikzel ctrf)")
|
|
(environment . ,env)))))
|
|
|
|
(display (json-write-string output #t))
|
|
(newline)
|
|
(exit (+ fail xfail)))))
|
|
runner)))
|
|
(test-runner-factory runner)))
|