Fix ctrf to use SRFI-180

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}
+	mkdir -p ${TMPDIR}
-	@cp ${TESTFILE} ${TMPDIR}/
+	cp ${TESTFILE} ${TMPDIR}/
-	@mkdir -p ${TMPDIR}/retropikzel
+	mkdir -p ${TMPDIR}/retropikzel
-	@cp -r retropikzel/${LIBRARY} ${TMPDIR}/retropikzel/
+	cp -r retropikzel/${LIBRARY} ${TMPDIR}/retropikzel/
-	@cp -r retropikzel/${LIBRARY}.s* ${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} && COMPILE_R7RS=${SCHEME} compile-scheme -I . -o test-r7rs test.scm
-	cd ${TMPDIR} && ./test
+	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

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)

retropikzel/ctrf.sld

@@ -1,19 +1,12 @@
 (define-library
   (retropikzel ctrf)
-  (cond-expand
+  (import (scheme base)
-    (chezscheme
+            (scheme write)
-      (import (rnrs)
+            (scheme time)
-              (srfi 64)
+            (scheme process-context)
-              (srfi 69)
+            (srfi 64)
-              (srfi 180)))
+            (srfi 69)
-    (else
+            (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
+  (include "ctrf.scm"))
-    (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)))

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")