Finishing touches on ctrf library

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

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} && echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > test-r7rs.scm
-	cd ${TMPDIR} && COMPILE_R7RS=${SCHEME} compile-scheme -I . -o test-r7rs test.scm
+	cat ${TESTFILE} >> ${TMPDIR}/test-r7rs.scm
-	cd ${TMPDIR} && ./test-r7rs
+	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 . > /dev/null
-	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 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}"
 

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)))
+                 (result-ref
-
+                   (lambda (runner key)
-            (when (test-result-ref runner 'expected-value)
+                     (let ((value (test-result-ref runner key)))
-              (hash-table-set! extra
+                       (if value (any->string value) "")))))
-                               'expected-value
+            (let* ((suite (car (reverse (vector->list current-test-groups))))
-                               (test-result-ref runner 'expected-value)))
+                   (test `((name . ,name)
-
+                           (status . ,status)
-            (when (test-result-ref runner 'actual-value)
+                           (duration . ,duration)
-              (hash-table-set! extra
+                           (suite . ,suite)
-                               'actual-value
+                           (extra .  ((source-file . ,(result-ref runner 'source-file))
-                               (test-result-ref runner 'actual-value)))
+                                      (source-line . ,(result-ref runner 'source-line))
-
+                                      (source-form . ,(result-ref runner 'source-form))
-            (when (test-result-ref runner 'expected-error)
+                                      (count . ,current-test-group-count)
-              (hash-table-set! extra
+                                      (expected-value . ,(result-ref runner 'expected-value))
-                               'expected-error
+                                      (actual-value . ,(result-ref runner 'actual-value))
-                               (test-result-ref runner 'expected-error)))
+                                      (expected-error . ,(result-ref runner 'expected-error))
-
+                                      (actual-error . ,(result-ref runner 'actual-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)))
 
+              (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))))
+                       (environment . ,env)))
-
+             (output-file (string-append implementation-name
-            (json-write output (current-output-port))
+                                         "-"
-            (newline)
+                                         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)))

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)
+    (capyscheme (begin (define implementation-name "capyscheme")))
-    (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
     (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
+          (time-second (current-time)))))
-          0)))
     (else
       (begin
         (define (time-ms) (/ (/ (current-jiffy) (jiffies-per-second)) 1000)))))

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.

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