Fix ctrf to use SRFI-180
This commit is contained in:
parent
dc7ff1c92f
commit
436710023e
27
Makefile
27
Makefile
|
|
@ -1,4 +1,8 @@
|
|||
#.SILENT: build install test test-docker clean ${TMPDIR}
|
||||
TMPDIR=.tmp/${SCHEME}
|
||||
|
||||
.SILENT: build install test test-docker clean ${TMPDIR}
|
||||
.PHONY: ${TMPDIR}
|
||||
|
||||
SCHEME=chibi
|
||||
LIBRARY=cgi
|
||||
AUTHOR=retropikzel
|
||||
|
|
@ -10,7 +14,6 @@ README=retropikzel/${LIBRARY}/README.html
|
|||
TESTFILE=retropikzel/${LIBRARY}/test.scm
|
||||
|
||||
PKG=${AUTHOR}-${LIBRARY}-${VERSION}.tgz
|
||||
TMPDIR=.tmp/${SCHEME}
|
||||
|
||||
DOCKERIMG=${SCHEME}:head
|
||||
ifeq "${SCHEME}" "chicken"
|
||||
|
|
@ -30,21 +33,21 @@ uninstall:
|
|||
-snow-chibi remove --impls=${SCHEME} ${PKG}
|
||||
|
||||
${TMPDIR}:
|
||||
@mkdir -p ${TMPDIR}
|
||||
@cp ${TESTFILE} ${TMPDIR}/
|
||||
@mkdir -p ${TMPDIR}/retropikzel
|
||||
@cp -r retropikzel/${LIBRARY} ${TMPDIR}/retropikzel/
|
||||
@cp -r retropikzel/${LIBRARY}.s* ${TMPDIR}/retropikzel/
|
||||
mkdir -p ${TMPDIR}
|
||||
cp ${TESTFILE} ${TMPDIR}/
|
||||
mkdir -p ${TMPDIR}/retropikzel
|
||||
cp -r retropikzel/${LIBRARY} ${TMPDIR}/retropikzel/
|
||||
cp -r retropikzel/${LIBRARY}.s* ${TMPDIR}/retropikzel/
|
||||
|
||||
test: ${TMPDIR}
|
||||
test-r7rs: ${TMPDIR}
|
||||
echo "Hello"
|
||||
cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} compile-r7rs -I . -o test test.scm
|
||||
cd ${TMPDIR} && ./test
|
||||
cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} compile-scheme -I . -o test-r7rs test.scm
|
||||
cd ${TMPDIR} && ./test-r7rs
|
||||
|
||||
test-docker: ${TMPDIR}
|
||||
test-r7rs-docker: ${TMPDIR}
|
||||
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=scheme-library-test-${SCHEME} -f Dockerfile.test . 2> ${TMPDIR}/docker.log || cat ${TMPDIR}/docker.log
|
||||
docker run -v "${PWD}:/workdir" -w /workdir -t scheme-library-test-${SCHEME} \
|
||||
sh -c "make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes build install test; chmod -R 755 ${TMPDIR}"
|
||||
sh -c "make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes build install test-r7rs; chmod -R 755 ${TMPDIR}"
|
||||
|
||||
clean:
|
||||
git clean -X -f
|
||||
|
|
|
|||
|
|
@ -0,0 +1,125 @@
|
|||
(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 '((a . 1))))
|
||||
(newline)
|
||||
(exit (+ fail xfail)))))
|
||||
runner)))
|
||||
|
||||
(test-runner-factory runner)
|
||||
|
|
@ -1,19 +1,12 @@
|
|||
(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))))
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme time)
|
||||
(scheme process-context)
|
||||
(srfi 64)
|
||||
(srfi 69)
|
||||
(srfi 180))
|
||||
(export test-begin
|
||||
test-end
|
||||
test-group
|
||||
|
|
@ -122,128 +115,4 @@
|
|||
(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)))
|
||||
(include "ctrf.scm"))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(retropikzel ctrf))
|
||||
|
||||
(test-begin "ctrf")
|
||||
|
||||
(test-assert #t)
|
||||
|
||||
(test-end "ctrf")
|
||||
Loading…
Reference in New Issue