From 436710023e4961cece4fa7c3f5e0c3478c70e700 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 23 Nov 2025 06:35:22 +0200 Subject: [PATCH] Fix ctrf to use SRFI-180 --- Makefile | 27 +++---- retropikzel/ctrf.scm | 125 ++++++++++++++++++++++++++++++++ retropikzel/ctrf.sld | 147 +++----------------------------------- retropikzel/ctrf/test.scm | 11 +++ 4 files changed, 159 insertions(+), 151 deletions(-) create mode 100644 retropikzel/ctrf.scm create mode 100644 retropikzel/ctrf/test.scm diff --git a/Makefile b/Makefile index 7684298..79a3a9f 100644 --- a/Makefile +++ b/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 diff --git a/retropikzel/ctrf.scm b/retropikzel/ctrf.scm new file mode 100644 index 0000000..f87709d --- /dev/null +++ b/retropikzel/ctrf.scm @@ -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) diff --git a/retropikzel/ctrf.sld b/retropikzel/ctrf.sld index 84bad73..de85e5e 100644 --- a/retropikzel/ctrf.sld +++ b/retropikzel/ctrf.sld @@ -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")) diff --git a/retropikzel/ctrf/test.scm b/retropikzel/ctrf/test.scm new file mode 100644 index 0000000..437b0f5 --- /dev/null +++ b/retropikzel/ctrf/test.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")