Finishing touches on ctrf library
This commit is contained in:
parent
757bc3150f
commit
fcbe5075bd
|
|
@ -37,6 +37,7 @@ ENV PATH=/root/.local/bin:${PATH}
|
|||
RUN akku update
|
||||
WORKDIR /build/foreign-c
|
||||
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 64)" || true
|
||||
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 180)" || true
|
||||
RUN timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(foreign c)" || true
|
||||
RUN make SCHEME=${SCHEME} build install
|
||||
WORKDIR /workdir
|
||||
|
|
|
|||
26
Makefile
26
Makefile
|
|
@ -1,6 +1,7 @@
|
|||
TMPDIR=.tmp/${SCHEME}
|
||||
|
||||
.SILENT: build install test-r7rs test-r7rs-docker clean ${TMPDIR}
|
||||
.SILENT: build install test-r6rs test-r6rs-docker test-r7rs test-r7rs-docker \
|
||||
clean ${TMPDIR}
|
||||
.PHONY: ${TMPDIR}
|
||||
|
||||
SCHEME=chibi
|
||||
|
|
@ -34,19 +35,30 @@ uninstall:
|
|||
|
||||
${TMPDIR}:
|
||||
mkdir -p ${TMPDIR}
|
||||
cp ${TESTFILE} ${TMPDIR}/
|
||||
mkdir -p ${TMPDIR}/retropikzel
|
||||
cp -r retropikzel/${LIBRARY} ${TMPDIR}/retropikzel/
|
||||
cp -r retropikzel/${LIBRARY}.s* ${TMPDIR}/retropikzel/
|
||||
|
||||
test-r6rs: ${TMPDIR}
|
||||
cd ${TMPDIR} && printf "#!r6rs\n(import (rnrs base) (rnrs control) (rnrs io simple) (rnrs files) (rnrs programs) (srfi :64) (retropikzel ${LIBRARY}))\n" > test-r6rs.sps
|
||||
cat ${TESTFILE} >> ${TMPDIR}/test-r6rs.sps
|
||||
cd ${TMPDIR} && akku install chez-srfi akku-r7rs > /dev/null
|
||||
cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} timeout 60 compile-scheme -I .akku/lib -o test-r6rs test-r6rs.sps
|
||||
cd ${TMPDIR} && timeout 60 ./test-r6rs
|
||||
|
||||
test-r6rs-docker: ${TMPDIR}
|
||||
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=scheme-library-test-${SCHEME} -f Dockerfile.test --quiet . > /dev/null
|
||||
docker run -v "${PWD}:/workdir" -w /workdir -t scheme-library-test-${SCHEME} \
|
||||
sh -c "make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes LIBRARY=${LIBRARY} build install test-r6rs; chmod -R 755 ${TMPDIR}"
|
||||
|
||||
test-r7rs: ${TMPDIR}
|
||||
echo "Hello"
|
||||
cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} compile-scheme -I . -o test-r7rs test.scm
|
||||
cd ${TMPDIR} && ./test-r7rs
|
||||
cd ${TMPDIR} && echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > test-r7rs.scm
|
||||
cat ${TESTFILE} >> ${TMPDIR}/test-r7rs.scm
|
||||
cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} timeout 60 compile-scheme -I . -o test-r7rs test-r7rs.scm
|
||||
cd ${TMPDIR} && timeout 60 ./test-r7rs
|
||||
|
||||
test-r7rs-docker: ${TMPDIR}
|
||||
echo "Building docker image..."
|
||||
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=scheme-library-test-${SCHEME} -f Dockerfile.test --quiet . 2> ${TMPDIR}/docker.log || cat ${TMPDIR}/docker.log
|
||||
docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=scheme-library-test-${SCHEME} -f Dockerfile.test --quiet . > /dev/null
|
||||
docker run -v "${PWD}:/workdir" -w /workdir -t scheme-library-test-${SCHEME} \
|
||||
sh -c "make SCHEME=${SCHEME} SNOW_CHIBI_ARGS=--always-yes LIBRARY=${LIBRARY} build install test-r7rs; chmod -R 755 ${TMPDIR}"
|
||||
|
||||
|
|
|
|||
|
|
@ -1,19 +1,24 @@
|
|||
(define (any->string any)
|
||||
(parameterize
|
||||
((current-output-port (open-output-string)))
|
||||
(display any)
|
||||
(get-output-string (current-output-port))))
|
||||
|
||||
(define ctrf-runner
|
||||
(lambda ()
|
||||
(let ((runner (test-runner-null))
|
||||
(let ((any->string
|
||||
(lambda (any)
|
||||
(parameterize
|
||||
((current-output-port (open-output-string)))
|
||||
(display any)
|
||||
(get-output-string (current-output-port)))))
|
||||
(runner (test-runner-null))
|
||||
(tests (vector))
|
||||
(failed-tests (vector))
|
||||
(current-test-start-time 0)
|
||||
(current-test-groups (vector)))
|
||||
(current-test-groups (vector))
|
||||
(current-test-group-count 0)
|
||||
(first-group-name #f))
|
||||
|
||||
(test-runner-on-group-begin!
|
||||
runner
|
||||
(lambda (runner suite-name count)
|
||||
(set! current-test-group-count 0)
|
||||
(when (not first-group-name) (set! first-group-name suite-name))
|
||||
(set! current-test-groups
|
||||
(vector-append current-test-groups (vector suite-name)))))
|
||||
|
||||
|
|
@ -30,6 +35,7 @@
|
|||
(test-runner-on-test-begin!
|
||||
runner
|
||||
(lambda (runner)
|
||||
(set! current-test-group-count (+ current-test-group-count 1))
|
||||
(set! current-test-start-time (time-ms))))
|
||||
|
||||
(test-runner-on-test-end!
|
||||
|
|
@ -44,51 +50,29 @@
|
|||
((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)))
|
||||
(result-ref
|
||||
(lambda (runner key)
|
||||
(let ((value (test-result-ref runner key)))
|
||||
(if value (any->string value) "")))))
|
||||
(let* ((suite (car (reverse (vector->list current-test-groups))))
|
||||
(test `((name . ,name)
|
||||
(status . ,status)
|
||||
(duration . ,duration)
|
||||
(suite . ,suite)
|
||||
(extra . ((source-file . ,(result-ref runner 'source-file))
|
||||
(source-line . ,(result-ref runner 'source-line))
|
||||
(source-form . ,(result-ref runner 'source-form))
|
||||
(count . ,current-test-group-count)
|
||||
(expected-value . ,(result-ref runner 'expected-value))
|
||||
(actual-value . ,(result-ref runner 'actual-value))
|
||||
(expected-error . ,(result-ref runner 'expected-error))
|
||||
(actual-error . ,(result-ref runner 'actual-error)))))))
|
||||
|
||||
(when (or (equal? result 'fail)
|
||||
(equal? result 'xfail))
|
||||
(set! failed-tests
|
||||
(vector-append failed-tests
|
||||
(vector (cons `(suite . ,suite) test)))))
|
||||
(set! tests (vector-append tests (vector test)))))))
|
||||
|
||||
(test-runner-on-final!
|
||||
|
|
@ -100,7 +84,8 @@
|
|||
(fail (test-runner-fail-count runner))
|
||||
(xfail (test-runner-xfail-count runner))
|
||||
(skipped (test-runner-skip-count runner))
|
||||
(tool `((name . "srfi-64-retropikzel-ctrf")))
|
||||
(tool `((name . "(retropikzel ctrf)")
|
||||
(version . "1.0.0")))
|
||||
(summary `((tests . ,(+ pass xpass fail xfail))
|
||||
(passed . ,(+ pass xpass))
|
||||
(failed . ,(+ fail xfail))
|
||||
|
|
@ -116,9 +101,16 @@
|
|||
(specVersion . "0.0.0")
|
||||
(results . ,results)
|
||||
(generatedBy . "(retropikzel ctrf)")
|
||||
(environment . ,env))))
|
||||
|
||||
(json-write output (current-output-port))
|
||||
(newline)
|
||||
(environment . ,env)))
|
||||
(output-file (string-append implementation-name
|
||||
"-"
|
||||
first-group-name
|
||||
".ctrf.json")))
|
||||
(when (file-exists? output-file) (delete-file output-file))
|
||||
(with-output-to-file
|
||||
output-file
|
||||
(lambda ()
|
||||
(json-write output (current-output-port))))
|
||||
(json-write failed-tests (current-output-port))
|
||||
(exit (+ fail xfail)))))
|
||||
runner)))
|
||||
|
|
|
|||
|
|
@ -3,27 +3,19 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme time)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(srfi 64)
|
||||
(srfi 69)
|
||||
(srfi 180))
|
||||
(export ctrf-runner)
|
||||
(begin
|
||||
(define operation-system
|
||||
(cond-expand
|
||||
(windows "windows")
|
||||
(linux "linux")
|
||||
(else "other"))))
|
||||
(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
|
||||
(capyscheme (begin (define implementation-name "capyscheme")))
|
||||
(chezscheme (begin (define implementation-name "chezscheme")))
|
||||
(chibi (begin (define implementation-name "chibi")))
|
||||
(chicken (begin (define implementation-name "chicken")))
|
||||
|
|
@ -44,10 +36,10 @@
|
|||
(else (begin (define implementation-name "unknown"))))
|
||||
(cond-expand
|
||||
(r6rs
|
||||
(import (srfi :19))
|
||||
(begin
|
||||
(define (time-ms)
|
||||
;; FIXME
|
||||
0)))
|
||||
(time-second (current-time)))))
|
||||
(else
|
||||
(begin
|
||||
(define (time-ms) (/ (/ (current-jiffy) (jiffies-per-second)) 1000)))))
|
||||
|
|
|
|||
|
|
@ -13,8 +13,9 @@ Usage:
|
|||
|
||||
|
||||
Then run tests as usual. The CTRF output will be outputted into JSON file
|
||||
named as $SCHEME-$TESTNAME.json.
|
||||
named as ${SCHEME}-${FIRST\_TEST\_GROUP\_NAME}.ctrf.json.
|
||||
|
||||
Any failing tests and summary will be printed into stdout.
|
||||
Any failing tests and summary will be printed into stdout as list of JSON
|
||||
objects.
|
||||
|
||||
Exit code is the amount of failed tests.
|
||||
|
|
|
|||
|
|
@ -1,9 +1,3 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(srfi 64)
|
||||
(retropikzel ctrf))
|
||||
|
||||
(test-runner-current (ctrf-runner))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue