diff --git a/Dockerfile.test b/Dockerfile.test index 0cbb998..02a8dd5 100644 --- a/Dockerfile.test +++ b/Dockerfile.test @@ -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 diff --git a/Makefile b/Makefile index 8ffc9a4..950ab59 100644 --- a/Makefile +++ b/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}" diff --git a/retropikzel/ctrf.scm b/retropikzel/ctrf.scm index 9843120..0cca34a 100644 --- a/retropikzel/ctrf.scm +++ b/retropikzel/ctrf.scm @@ -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))) diff --git a/retropikzel/ctrf.sld b/retropikzel/ctrf.sld index 32e91b8..6a7bed1 100644 --- a/retropikzel/ctrf.sld +++ b/retropikzel/ctrf.sld @@ -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))))) diff --git a/retropikzel/ctrf/README.md b/retropikzel/ctrf/README.md index 452b785..97da9fc 100644 --- a/retropikzel/ctrf/README.md +++ b/retropikzel/ctrf/README.md @@ -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. diff --git a/retropikzel/ctrf/test.scm b/retropikzel/ctrf/test.scm index 78a38c9..78901cc 100644 --- a/retropikzel/ctrf/test.scm +++ b/retropikzel/ctrf/test.scm @@ -1,9 +1,3 @@ -(import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (srfi 64) - (retropikzel ctrf)) (test-runner-current (ctrf-runner))