Retropikzel
/
r7rs-tests
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First steps

This commit is contained in:
retropikzel 2024-10-05 11:55:06 +03:00
commit 20cb936e0d
59 changed files with 8393 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
.gitignore vendored Normal file
View File

@ -0,0 +1,18 @@
*.swp
*.log
test-prefix
*.so
*.o
*.o*
*.c
*.dep
*.zo
*.meta
compiled
srfi-*.scm
srfi-*.sld
srfi.*.scm
srfi.*.sld
reports
r7rs-tests.scm
snow.*

489
Jenkinsfile vendored Normal file
View File

@ -0,0 +1,489 @@
pipeline {
agent {
dockerfile {
filename 'Dockerfile.jenkins'
dir '.'
args '--privileged -v /var/run/docker.sock:/var/run/docker.sock'
}
}
options {
buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10'))
}
parameters {
choice(name: 'BUILD_IMPLEMENTATION',
description: 'Build',
choices: [
'all',
'chibi',
'chicken',
'cyclone',
'gambit',
'gauche',
'guile',
'kawa',
'loko',
'mit-scheme',
'sagittarius',
'stklos',
'skint',
'tr7',
])
}
stages {
stage("Init") {
steps {
sh 'rm -rf srfi-test && git clone https://github.com/srfi-explorations/srfi-test.git'
sh 'mkdir -p reports'
sh 'touch reports/placeholder'
stash name: 'reports', includes: 'reports/*'
sh 'echo "<h1>Test results</h1>" > reports/results.html'
sh '(cd srfi-test && make clean build)'
sh 'tree srfi-test'
stash name: 'tests', includes: 'srfi-test/*'
}
}
stage("chibi") {
agent {
docker {
image 'schemers/chibi'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'chibi'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/chibi-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("chicken") {
agent {
docker {
image 'schemers/chicken'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'chicken'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/chicken-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("cyclone") {
agent {
docker {
image 'schemers/cyclone'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'cyclone'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/cyclone-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("gambit") {
agent {
docker {
image 'schemers/gambit'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'gambit'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/gambit-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("gauche") {
agent {
docker {
image 'schemers/gauche'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'gauche'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/gauche-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("guile") {
agent {
docker {
image 'schemers/guile'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'guile'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/guile-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("kawa") {
agent {
docker {
image 'schemers/kawa'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'kawa'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/kawa-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("loko") {
agent {
docker {
image 'schemers/loko:head'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'loko'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/loko-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("mit-scheme") {
agent {
docker {
image 'schemers/mit-scheme'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'mit-scheme'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/mit-scheme-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("sagittarius") {
agent {
docker {
image 'schemers/sagittarius'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'sagittarius'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/sagittarius-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("stklos") {
agent {
docker {
image 'schemers/stklos'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'stklos'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/stklos-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("skint") {
agent {
docker {
image 'schemers/skint'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'skint'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/skint-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("tr7") {
agent {
docker {
image 'schemers/tr7'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == 'tr7'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'
sh 'for f in *.log; do cp -- "$f" "reports/tr7-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}
stage("Report") {
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
unstash 'reports'
sh './report'
archiveArtifacts artifacts: 'reports/*.html'
publishHTML (target : [allowMissing: false,
alwaysLinkToLastBuild: false,
keepAll: true,
reportDir: 'reports',
reportFiles: '*.html,*.css',
reportName: 'R7RS-SRFI Test Report',
reportTitles: 'R7RS-SRFI Test Report'])
}
}
}
}
post {
always {
archiveArtifacts artifacts: 'reports/*.log'
archiveArtifacts artifacts: 'reports/*.html'
sh 'for f in srfi/*.sld; do snow-chibi package "$f"; done'
archiveArtifacts artifacts: '*.tgz'
archiveArtifacts artifacts: 'srfi/*.tgz'
deleteDir()
}
failure {
archiveArtifacts artifacts: 'reports/*.html'
archiveArtifacts artifacts: 'reports/*.log'
deleteDir()
}
}
}

82
Makefile Normal file
View File

@ -0,0 +1,82 @@
test-chibi-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/chibi bash -c "cd workdir && chibi-scheme -I ./snow r7rs-tests.scm"
test-chicken-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/chicken bash -c "cd workdir && ls && cp snow/chibi/optional.sld snow.chibi.optional.sld && csc -include-path ./snow/chibi -X r7rs -R r7rs -s -J snow.chibi.optional.sld && cp snow/chibi/diff.sld snow.chibi.diff.sld && csc -include-path ./snow/chibi -X r7rs -R r7rs -s -J snow.chibi.diff.sld && cp snow/chibi/test.sld snow.chibi.test.sld && csc -include-path ./snow/chibi -X r7rs -R r7rs -s -J snow.chibi.test.sld"
docker run -it -v ${PWD}:/workdir:z schemers/chicken bash -c "cd workdir && csc -include-path ./snow/chibi -X r7rs -R r7rs r7rs-tests.scm && ./r7rs-test && rm r7rs-test"
test-cyclone-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/cyclone bash -c "cd workdir && ls && cyclone -A . snow/chibi/optional.sld && cyclone -A . snow/chibi/diff.sld && cyclone -A . snow/chibi/test.sld"
docker run -it -v ${PWD}:/workdir:z schemers/cyclone bash -c "cd workdir && cyclone -A . r7rs-tests.scm && ./r7rs-test && rm r7rs-test"
test-gambit-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/gambit bash -c "cd workdir && ls && gsc . snow/chibi/optional && gsc . snow/chibi/diff && gsc . snow/chibi/test"
docker run -it -v ${PWD}:/workdir:z schemers/gambit bash -c "cd workdir && gsc -exe . -nopreload r7rs-tests.scm && ./r7rs-test && rm r7rs-test"
test-gauche-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/gauche bash -c "cd workdir && gosh -r7 -A ./snow r7rs-tests.scm"
test-guile-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/guile bash -c "cd workdir && guile --fresh-auto-compile --r7rs -L . -L ./snow r7rs-tests.scm"
test-kawa-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/kawa bash -c "cd workdir && kawa --r7rs -Dkawa.import.path=..:../snow:*.sld:./snow/chibi/*.sld:./snow/chibi/term/*.sld r7rs-tests.scm"
test-loko-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/loko bash -c "cd workdir && ls && ls snow/chibi/optional.sld && ls snow/chibi/diff.sld && ls snow/chibi/test.sld"
docker run -it -v ${PWD}:/workdir:z schemers/loko bash -c "cd workdir && LOKO_LIBRARY_PATH=./snow loko -std=r7rs --compile r7rs-tests.scm && ./r7rs-test && rm r7rs-test"
test-mit-scheme-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/mit-scheme bash -c "cd workdir && mit-scheme --load r7rs-tests.scm"
test-sagittarius-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/sagittarius bash -c "cd workdir && sash -r7 -L ./snow r7rs-tests.scm > r7rs-test.log && cat r7rs-test.log"
test-stklos-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/stklos bash -c "cd workdir && stklos -I . r7rs-tests.scm"
test-skint-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/skint bash -c "cd workdir && skint --program r7rs-tests.scm"
test-tr7-r7rs-test:
docker run -it -v ${PWD}:/workdir:z schemers/tr7 bash -c "cd workdir && tr7i r7rs-tests.scm"
clean:
find . -name "*.so" -delete
find . -name "*.c" -delete
find . -name "*.o*" -delete
find . -name "*.so" -delete
find . -name "*.dep" -delete
find . -name "*.zo" -delete
find . -name "*.meta" -delete
find . -name "compiled" -delete
find . -name "srfi.*.sld" -delete
find . -name "srfi.*.scm" -delete
find . -name "srfi-*.sld" -delete
find . -name "srfi.*.import.scm" -delete
find . -name "srfi-*.import.scm" -delete
find . -name "*.log" -delete
find . -name "test-prefix.txt" -delete

111
build.scm Normal file
View File

@ -0,0 +1,111 @@
(import (scheme base)
(scheme write)
(scheme file)
(scheme process-context)
(scheme file)
(arvyy mustache))
(include "util.scm")
(include "implementations.scm")
(include "tests.scm")
(define full-library-command
(lambda (implementation test)
(let* ((name (symbol->string (cdr (assoc 'name implementation))))
(library-command (assoc 'library-command implementation)))
(cond ((not library-command) #f)
; Note that Chicken needs to have the SRFI library as srfi-N.scm in same folder
((string=? name "chicken")
(string-append
" ls "
" && cp snow/chibi/optional.sld snow.chibi.optional.sld"
" && " (cdr library-command) " snow.chibi.optional.sld"
" && cp snow/chibi/diff.sld snow.chibi.diff.sld"
" && " (cdr library-command) " snow.chibi.diff.sld"
" && cp snow/chibi/test.sld snow.chibi.test.sld"
" && " (cdr library-command) " snow.chibi.test.sld"
))
(else (string-append
" ls "
" && " (cdr library-command) " snow/chibi/optional" (if (string=? name "gambit") "" ".sld")
" && " (cdr library-command) " snow/chibi/diff" (if (string=? name "gambit") "" ".sld")
" && " (cdr library-command) " snow/chibi/test" (if (string=? name "gambit") "" ".sld")
))))))
(define full-command
(lambda (implementation test)
(let* ((name (symbol->string (cdr (assoc 'name implementation))))
(test-name (cdr (assoc 'name test)))
(test-file (cdr (assoc 'file test)))
(command
(string-append
(cdr (assoc 'command implementation)) " " test-file))
(library-command (assoc 'library-command implementation)))
(cond
((not library-command)
(string-append command
; Sagittarius does not make .log file for some reason
; Temporary fix to get atleast something out
(if (string=? name "sagittarius")
(string-append " > " test-name ".log && cat " test-name ".log")
"")))
(else (string-append command
" && ./" test-name
" && rm " test-name))))))
(define jenkinsfile-top (compile (slurp "templates/Jenkinsfile-top")))
(define jenkinsfile-job-top (compile (slurp "templates/Jenkinsfile-job-top")))
(define jenkinsfile-job (compile (slurp "templates/Jenkinsfile-job")))
(define jenkinsfile-job-bottom (compile (slurp "templates/Jenkinsfile-job-bottom")))
(define jenkinsfile-bottom (compile (slurp "templates/Jenkinsfile-bottom")))
(call-with-output-file
"Jenkinsfile"
(lambda (out)
(execute jenkinsfile-top '() out)
(newline out)
(for-each
(lambda (implementation)
(let ((name (symbol->string (cdr (assoc 'name implementation)))))
(execute jenkinsfile-job-top
`((name . ,name)
(dockerimage . ,(if (assoc 'docker-image implementation)
(cdr (assoc 'docker-image implementation))
(string-append "schemers/" name)))) out)
(for-each
(lambda (test)
(execute jenkinsfile-job
`((command . ,(full-command implementation test))
(library-command . ,(full-library-command implementation test))
out)))
tests)
(execute jenkinsfile-job-bottom `((name . ,(cdr (assoc 'name implementation)))) out)
(newline out)))
implementations)
(execute jenkinsfile-bottom '() out)
(newline out)))
(define makefile-top (compile (slurp "templates/Makefile-top")))
(define makefile-job (compile (slurp "templates/Makefile-job")))
(define makefile-bottom (compile (slurp "templates/Makefile-bottom")))
(call-with-output-file
"Makefile"
(lambda (out)
(execute makefile-top '() out)
(for-each
(lambda (test)
(for-each
(lambda (implementation)
(let* ((name (symbol->string (cdr (assoc 'name implementation)))))
(execute makefile-job
`((name . ,name)
(test-name . ,(cdr (assoc 'name test)))
(command . ,(full-command implementation test))
(library-command . ,(full-library-command implementation test)))
out))
(newline out))
implementations))
tests)
(execute makefile-bottom '() out)
(newline out)))

3
generate Executable file
View File

@ -0,0 +1,3 @@
#!/bin/sh
gosh -r7 -A . -A ./snow build.scm

25
implementations.scm Normal file
View File

@ -0,0 +1,25 @@
(define implementations
'(((name . chibi) (command . "chibi-scheme -I ./snow"))
((name . chicken)
(command . "csc -include-path ./snow/chibi -X r7rs -R r7rs")
(library-command . "csc -include-path ./snow/chibi -X r7rs -R r7rs -s -J"))
((name . cyclone)
(command . "cyclone -A .")
(library-command . "cyclone -A ."))
((name . gambit)
(command . "gsc -exe . -nopreload")
(library-command . "gsc ."))
((name . gauche) (command . "gosh -r7 -A ./snow"))
((name . guile) (command . "guile --fresh-auto-compile --r7rs -L . -L ./snow"))
((name . kawa) (command . "kawa --r7rs -Dkawa.import.path=..:../snow:*.sld:./snow/chibi/*.sld:./snow/chibi/term/*.sld"))
((name . loko)
(docker-image . "schemers/loko:head")
(command . "LOKO_LIBRARY_PATH=./snow loko -std=r7rs --compile")
; Library command so the executable gets run
(library-command . "ls"))
((name . mit-scheme) (command . "mit-scheme --load"))
((name . sagittarius) (command . "sash -r7 -L ./snow"))
((name . stklos) (command . "stklos -I ."))
((name . skint) (command . "skint --program"))
((name . tr7) (command . "tr7i"))))

106
snow/arvyy/mustache-impl.scm Normal file
View File

@ -0,0 +1,106 @@
(define (default-writer obj out)
(when obj
(display obj out)))
(define default-lookup
(compose-lookups
alist-lookup))
(define default-collection
(compose-collections
vector-collection
stream-collection))
(define (port->string port)
(define str
(let loop ((chunks '())
(chunk (read-string 2000 port)))
(if (eof-object? chunk)
(apply string-append (reverse chunks))
(loop (cons chunk chunks)
(read-string 2000 port)))))
(close-input-port port)
str)
(define (template-get-partials template)
(define partials
(let loop ((template template)
(parts '()))
(cond
((null? template) parts)
(else (let ((t (car template))
(rest (cdr template)))
(cond
((partial? t) (loop rest
(cons (partial-name t) parts)))
((section? t) (loop rest
(append (template-get-partials (section-content t))
parts)))
(else (loop rest
parts))))))))
(delete-duplicates! partials))
(define compile
(case-lambda
((template) (compile/without-partials template))
((root partial-locator) (compile/with-partials root partial-locator))))
(define (compile/without-partials template)
(compile/with-partials #f (lambda (partial)
(if partial
#f
template))))
(define (compile/with-partials root partial-locator)
;; returns 2 values: missing partials (found in part) and compiled part template
(define (compile-part part resolved-partials)
(define source (partial-locator part))
(define in (cond
((not source) "")
((string? source) source)
((port? source) (port->string source))
(else (error "Partial locator returned unrecognized type"))))
(define template (parse (read-tokens in)))
(define partials (template-get-partials template))
(define missing-partials (lset-difference string=? partials resolved-partials))
(values missing-partials template))
(let loop ((unresolved (list root))
(resolved-map '())
(resolved-lst '()))
(cond
((null? unresolved) (cons root resolved-map))
(else (let ((part (car unresolved)))
(define-values (unresolved* template)
(compile-part part resolved-lst))
(loop (append unresolved* (cdr unresolved))
(cons (cons part template) resolved-map)
(cons part resolved-lst)))))))
(define current-lookup (make-parameter default-lookup))
(define current-collection (make-parameter default-collection))
(define current-writer (make-parameter default-writer))
(define execute
(case-lambda
((compilation data)
(let ((out (open-output-string)))
(execute compilation data out)
(get-output-string out)))
((compilation data out)
(define root (car compilation))
(define partials (cdr compilation))
(define template (cdr (assoc root partials)))
(define lookup (current-lookup))
(define collection* (current-collection))
(define writer (current-writer))
(executor-execute template
(list data)
partials
out
lookup
(collection-pred-proc collection*)
(collection-empty?-proc collection*)
(collection-for-each-proc collection*)
writer))))

73
snow/arvyy/mustache-test.sld Normal file
View File

@ -0,0 +1,73 @@
(define-library
(arvyy mustache-test)
(import (scheme base)
(scheme write)
(arvyy mustache)
(srfi 41))
(export run-tests)
(cond-expand
(chibi
(import (rename (except (chibi test) test-equal)
(test test-equal))))
((library (srfi 64))
(import (srfi 64)))
(else (error "No testing library found")))
(begin
(define-syntax test-mustache
(syntax-rules ()
((_ name data template expected)
(test-equal name expected (execute (compile "foo" (lambda args template)) data)))
((_ name data partials template expected)
(let* ((partials* (cons (cons "root" template) partials))
(fn (lambda (n)
(cond
((assoc n partials*) => cdr)
(else #f)))))
(test-equal name expected (execute (compile "root" fn) data)))))))
(include "mustache-test/comments.scm"
"mustache-test/delimiters.scm"
"mustache-test/implementation-specific.scm"
"mustache-test/interpolation.scm"
"mustache-test/inverted.scm"
"mustache-test/partials.scm"
"mustache-test/sections.scm")
(begin
(define (run-tests)
(test-begin "mustache")
(test-group
"comments"
(run-tests/comments))
(test-group
"delimiters"
(run-tests/delimiters))
(test-group
"interpolation"
(run-tests/interpolation))
(test-group
"inverted"
(run-tests/inverted))
(test-group
"partials"
(run-tests/partials))
(test-group
"sections"
(run-tests/sections))
(test-group
"implementation-specific"
(run-tests/implementation-specific))
(test-end))))

56
snow/arvyy/mustache-test/comments.scm Normal file
View File

@ -0,0 +1,56 @@
(define (run-tests/comments)
(test-mustache "Inline"
'()
"12345{{! Comment Block! }}67890"
"1234567890")
(test-mustache "Multiline"
'()
"12345{{!\n This is a\n multi-line comment...\n}}67890"
"1234567890")
(test-mustache "Standalone"
'()
"Begin.\n{{! Comment Block! }}\nEnd."
"Begin.\nEnd.")
(test-mustache "Indented Standalone"
'()
"Begin.\n {{! Comment Block! }}\nEnd."
"Begin.\nEnd.")
(test-mustache "Standalone Line Endings"
'()
"\r\n{{! Standalone Comment }}\r\n"
"\r\n")
(test-mustache "Standalone Without Previous Line"
'()
" {{! I'm Still Standalone }}\n!"
"!")
(test-mustache "Standalone Without Newline"
'()
"!\n {{! I'm Still Standalone }}"
"!\n")
(test-mustache "Multiline Standalone"
'()
"Begin.\n{{!\nSomething's going on here...\n}}\nEnd."
"Begin.\nEnd.")
(test-mustache "Indented Multiline Standalone"
'()
"Begin.\n {{!\n Something's going on here...\n }}\nEnd."
"Begin.\nEnd.")
(test-mustache "Indented Inline"
'()
" 12 {{! 34 }}\n"
" 12 \n")
(test-mustache "Surrounding Whitespace"
'()
"12345 {{! Comment Block! }} 67890"
"12345 67890"))

75
snow/arvyy/mustache-test/delimiters.scm Normal file
View File

@ -0,0 +1,75 @@
(define (run-tests/delimiters)
(test-mustache "Pair Behavior"
'((text . "Hey!"))
"{{=<% %>=}}(<%text%>)"
"(Hey!)")
(test-mustache "Special Characters"
'((text . "It worked!"))
"({{=[ ]=}}[text])"
"(It worked!)")
(test-mustache "Sections"
'((section . #t)
(data . "I got interpolated."))
"[\n{{#section}}\n {{data}}\n |data|\n{{/section}}\n\n{{= | | =}}\n|#section|\n {{data}}\n |data|\n|/section|\n]\n"
"[\n I got interpolated.\n |data|\n\n {{data}}\n I got interpolated.\n]\n")
(test-mustache "Inverted Sections"
'((section . #f)
(data . "I got interpolated."))
"[\n{{^section}}\n {{data}}\n |data|\n{{/section}}\n\n{{= | | =}}\n|^section|\n {{data}}\n |data|\n|/section|\n]\n"
"[\n I got interpolated.\n |data|\n\n {{data}}\n I got interpolated.\n]\n")
(test-mustache "Partial Inheritence"
'((value . "yes"))
'(("include" . ".{{value}}."))
"[ {{>include}} ]\n{{= | | =}}\n[ |>include| ]\n"
"[ .yes. ]\n[ .yes. ]\n")
(test-mustache "Post-Partial Behavior"
'((value . "yes"))
'(("include" . ".{{value}}. {{= | | =}} .|value|."))
"[ {{>include}} ]\n[ .{{value}}. .|value|. ]\n"
"[ .yes. .yes. ]\n[ .yes. .|value|. ]\n")
(test-mustache "Surrounding Whitespace"
'()
"| {{=@ @=}} |"
"| |")
(test-mustache "Outlying Whitespace (Inline)"
'()
" | {{=@ @=}}\n"
" | \n")
(test-mustache "Standalone Tag"
'()
"Begin.\n{{=@ @=}}\nEnd.\n"
"Begin.\nEnd.\n")
(test-mustache "Indented Standalone Tag"
'()
"Begin.\n {{=@ @=}}\nEnd.\n"
"Begin.\nEnd.\n")
(test-mustache "Standalone Line Endings"
'()
"|\r\n{{= @ @ =}}\r\n|"
"|\r\n|")
(test-mustache "Standalone Without Previous Line"
'()
" {{=@ @=}}\n="
"=")
(test-mustache "Standalone Without Newline"
'()
"=\n {{=@ @=}}"
"=\n")
(test-mustache "Pair with Padding"
'()
"|{{= @ @ =}}|"
"||"))

71
snow/arvyy/mustache-test/implementation-specific.scm Normal file
View File

@ -0,0 +1,71 @@
(define-record-type <foo> (foo bar) foo? (bar foo-bar))
(define (run-tests/implementation-specific)
(define (foo-lookup obj name found not-found)
(cond
((not (foo? obj)) (not-found))
((string=? "bar" name) (found (foo-bar obj)))
(else (not-found))))
(define alist+foo (compose-lookups alist-lookup foo-lookup))
(define (write-foo obj out)
(write-string "(foo " out)
(display (foo-bar obj) out)
(write-string ")" out))
(define-record-type <num-lst> (num-lst count) num-lst? (count num-lst-count))
(define num-lst-collection
(collection
num-lst?
(lambda (obj) (= 0 (num-lst-count obj)))
(lambda (proc obj)
(define target (num-lst-count obj))
(let loop ((i 0))
(when (< i target)
(begin
(proc i)
(loop (+ 1 i))))))))
(parameterize
((current-writer (lambda (obj out)
(cond
((not obj) #t)
((foo? obj) (write-foo obj out))
(else (display obj out))))))
(test-mustache "Custom writer"
`((obj . ,(foo "baz")))
"Test {{obj}}"
"Test (foo baz)"))
(parameterize
((current-lookup alist+foo))
(test-mustache "Custom lookup"
`((a . ((bar . "baz1")))
(b . ,(foo "baz2")))
"{{a.bar}}, {{b.bar}}"
"baz1, baz2"))
(parameterize
((current-collection num-lst-collection))
(test-mustache "Custom collection"
`((a . ,(num-lst 3)))
"{{#a}}{{.}};{{/a}}"
"0;1;2;"))
(parameterize
((current-collection list-collection)
(current-lookup foo-lookup))
(test-mustache "List collection"
(foo '(0 1 2))
"{{#bar}}{{.}};{{/bar}}"
"0;1;2;"))
(parameterize
((current-collection stream-collection)
(current-lookup foo-lookup))
(test-mustache "Stream collection"
(foo (list->stream '(0 1 2)))
"{{#bar}}{{.}};{{/bar}}"
"0;1;2;")))

199
snow/arvyy/mustache-test/interpolation.scm Normal file
View File

@ -0,0 +1,199 @@
(define (run-tests/interpolation)
(test-mustache "No Interpolation"
'()
"Hello from {Mustache}!"
"Hello from {Mustache}!")
(test-mustache "Basic Interpolation"
'((subject . "world"))
"Hello, {{subject}}!"
"Hello, world!")
(test-mustache "HTML Escaping"
'((forbidden . "& \" < >"))
"These characters should be HTML escaped: {{forbidden}}"
"These characters should be HTML escaped: &amp; &quot; &lt; &gt;")
(test-mustache "Triple Mustache"
'((forbidden . "& \" < >"))
"These characters should not be HTML escaped: {{{forbidden}}}"
"These characters should not be HTML escaped: & \" < >")
(test-mustache "Ampersand"
'((forbidden . "& \" < >"))
"These characters should not be HTML escaped: {{&forbidden}}"
"These characters should not be HTML escaped: & \" < >")
(test-mustache "Basic Integer Interpolation"
'((mph . 85))
"\"{{mph}} miles an hour!\""
"\"85 miles an hour!\"")
(test-mustache "Triple Mustache Integer Interpolation"
'((mph . 85))
"\"{{{mph}}} miles an hour!\""
"\"85 miles an hour!\"")
(test-mustache "Ampersand Mustache Integer Interpolation"
'((mph . 85))
"\"{{&mph}} miles an hour!\""
"\"85 miles an hour!\"")
(test-mustache "Basic Decimal Interpolation"
'((power . 1.210))
"\"{{power}} jiggawatts!\""
"\"1.21 jiggawatts!\"")
(test-mustache "Triple Mustache Decimal Interpolation"
'((power . 1.210))
"\"{{{power}}} jiggawatts!\""
"\"1.21 jiggawatts!\"")
(test-mustache "Ampersand Mustache Decimal Interpolation"
'((power . 1.210))
"\"{{&power}} jiggawatts!\""
"\"1.21 jiggawatts!\"")
(test-mustache "Basic Null Interpolation"
'((cannot . #f))
"I ({{cannot}}) be seen!"
"I () be seen!")
(test-mustache "Triple Mustache Null Interpolation"
'((cannot . #f))
"I ({{{cannot}}}) be seen!"
"I () be seen!")
(test-mustache "Ampersand Null Interpolation"
'((cannot . #f))
"I ({{&cannot}}) be seen!"
"I () be seen!")
(test-mustache "Basic Context Miss Interpolation"
'()
"I ({{cannot}}) be seen!"
"I () be seen!")
(test-mustache "Triple Mustache Context Miss Interpolation"
'()
"I ({{{cannot}}}) be seen!"
"I () be seen!")
(test-mustache "Ampersand Context Miss Interpolation"
'()
"I ({{&cannot}}) be seen!"
"I () be seen!")
(test-mustache "Dotted Names - Basic Interpolation"
'((person . ((name . "Joe"))))
"\"{{person.name}}\" == \"{{#person}}{{name}}{{/person}}\""
"\"Joe\" == \"Joe\"")
(test-mustache "Dotted Names - Triple Mustache Interpolation"
'((person . ((name . "Joe"))))
"\"{{{person.name}}}\" == \"{{#person}}{{{name}}}{{/person}}\""
"\"Joe\" == \"Joe\"")
(test-mustache "Dotted Names - Ampersand Interpolation"
'((person . ((name . "Joe"))))
"\"{{&person.name}}\" == \"{{#person}}{{&name}}{{/person}}\""
"\"Joe\" == \"Joe\"")
(test-mustache "Dotted Names - Arbitrary Depth"
'((a . ((b . ((c . ((d . ((e . ((name . "Phil"))))))))))))
"\"{{a.b.c.d.e.name}}\" == \"Phil\""
"\"Phil\" == \"Phil\"")
(test-mustache "Dotted Names - Broken Chains"
'((a . ()))
"\"{{a.b.c}}\" == \"\""
"\"\" == \"\"")
(test-mustache "Dotted Names - Broken Chain Resolution"
'((a . ((b . ())))
(c . ((name . "Jim"))))
"\"{{a.b.c.name}}\" == \"\""
"\"\" == \"\"")
(test-mustache "Dotted Names - Initial Resolution"
'((a . ((b . ((c . ((d . ((e . ((name . "Phil")))))))))))
(b . ((c . ((d . ((e . ((name . "Wrong"))))))))))
"\"{{#a}}{{b.c.d.e.name}}{{/a}}\" == \"Phil\""
"\"Phil\" == \"Phil\"")
(test-mustache "Dotted Names - Context Precedence"
'((a . ((b . ())))
(b . ((c . "ERROR"))))
"{{#a}}{{b.c}}{{/a}}"
"")
(test-mustache "Implicit Iterators - Basic Interpolation"
"world"
"Hello, {{.}}!"
"Hello, world!")
(test-mustache "Implicit Iterators - HTML Escaping"
"& \" < >"
"These characters should be HTML escaped: {{.}}"
"These characters should be HTML escaped: &amp; &quot; &lt; &gt;")
(test-mustache "Implicit Iterators - Triple Mustache"
"& \" < >"
"These characters should not be HTML escaped: {{{.}}}"
"These characters should not be HTML escaped: & \" < >")
(test-mustache "Implicit Iterators - Ampersand"
"& \" < >"
"These characters should not be HTML escaped: {{&.}}"
"These characters should not be HTML escaped: & \" < >")
(test-mustache "Implicit Iterators - Basic Integer Interpolation"
85
"\"{{.}} miles an hour!\""
"\"85 miles an hour!\"")
(test-mustache "Interpolation - Surrounding Whitespace"
'((string . "---"))
"| {{string}} |"
"| --- |")
(test-mustache "Triple Mustache - Surrounding Whitespace"
'((string . "---"))
"| {{{string}}} |"
"| --- |")
(test-mustache "Ampersand - Surrounding Whitespace"
'((string . "---"))
"| {{&string}} |"
"| --- |")
(test-mustache "Interpolation - Standalone"
'((string . "---"))
" {{string}}\n"
" ---\n")
(test-mustache "Triple Mustache - Standalone"
'((string . "---"))
" {{{string}}}\n"
" ---\n")
(test-mustache "Ampersand - Standalone"
'((string . "---"))
" {{&string}}\n"
" ---\n")
(test-mustache "Interpolation With Padding"
'((string . "---"))
"|{{ string }}|"
"|---|")
(test-mustache "Triple Mustache With Padding"
'((string . "---"))
"|{{{ string }}}|"
"|---|")
(test-mustache "Ampersand With Padding"
'((string . "---"))
"|{{& string }}|"
"|---|"))

147
snow/arvyy/mustache-test/inverted.scm Normal file
View File

@ -0,0 +1,147 @@
(define (run-tests/inverted)
(test-mustache "Falsey"
'((boolean . #f))
"\"{{^boolean}}This should be rendered.{{/boolean}}\""
"\"This should be rendered.\"")
(test-mustache "Truthy"
'((boolean . #t))
"\"{{^boolean}}This should not be rendered.{{/boolean}}\""
"\"\"")
;; "Null is falsey" test is skipped; no meaningful value for null
(test-mustache "Context"
'((context . ((name . "Joe"))))
"\"{{^context}}Hi {{name}}.{{/context}}\""
"\"\"")
(test-mustache "List"
'(list . #(((n . 1))
((n . 2))
((n . 3))))
"\"{{^list}}{{n}}{{/list}}\""
"\"\"")
(test-mustache "Empty List"
'(list . #())
"\"{{^list}}Yay lists!{{/list}}\""
"\"Yay lists!\"")
(test-mustache "Doubled"
'((bool . #f) (two . "second"))
"
{{^bool}}
* first
{{/bool}}
* {{two}}
{{^bool}}
* third
{{/bool}}
"
"
* first
* second
* third
")
(test-mustache "Nested (Falsey)"
'((bool . #f))
"| A {{^bool}}B {{^bool}}C{{/bool}} D{{/bool}} E |"
"| A B C D E |")
(test-mustache "Nested (Truthy)"
'((bool . #t))
"| A {{^bool}}B {{^bool}}C{{/bool}} D{{/bool}} E |"
"| A E |")
(test-mustache "Context Misses"
'(())
"[{{^missing}}Cannot find key 'missing'!{{/missing}}]"
"[Cannot find key 'missing'!]")
(test-mustache "Dotted Names - Truthy"
'((a . ((b . ((c . #t))))))
"\"{{^a.b.c}}Not Here{{/a.b.c}}\" == \"\""
"\"\" == \"\"")
(test-mustache "Dotted Names - Falsey"
'((a . ((b . ((c . #f))))))
"\"{{^a.b.c}}Not Here{{/a.b.c}}\" == \"Not Here\""
"\"Not Here\" == \"Not Here\"")
(test-mustache "Dotted Names - Broken Chains"
'((a . ()))
"\"{{^a.b.c}}Not Here{{/a.b.c}}\" == \"Not Here\""
"\"Not Here\" == \"Not Here\"")
(test-mustache "Surrounding Whitespace"
'((boolean . #f))
" | {{^boolean}}\t|\t{{/boolean}} | \n"
" | \t|\t | \n")
(test-mustache "Internal Whitespace"
'((boolean . #f))
" | {{^boolean}} {{! Important Whitespace }}\n {{/boolean}} | \n"
" | \n | \n")
(test-mustache "Indented Inline Sections"
'((boolean . #f))
" {{^boolean}}NO{{/boolean}}\n {{^boolean}}WAY{{/boolean}}\n"
" NO\n WAY\n")
(test-mustache "Standalone Lines"
'((boolean . #f))
"
|
| This Is
{{^boolean}}
|
{{/boolean}}
| A Line
"
"
|
| This Is
|
| A Line
")
(test-mustache "Standalone Indented Lines"
'((boolean . #f))
"
|
| This Is
{{^boolean}}
|
{{/boolean}}
| A Line
"
"
|
| This Is
|
| A Line
")
(test-mustache "Standalone Line Endings"
'((boolean . #f))
"|\r\n{{^boolean}}\r\n{{/boolean}}\r\n|"
"|\r\n|")
(test-mustache "Standalone Without Previous Line"
'((boolean . #f))
" {{^boolean}}\n^{{/boolean}}\n/"
"^\n/")
(test-mustache "Standalone Without Newline"
'((boolean . #f))
"^{{^boolean}}\n/\n {{/boolean}}"
"^\n/\n")
(test-mustache "Padding"
'((boolean . #f))
"|{{^ boolean }}={{/ boolean }}|"
"|=|"))

46
snow/arvyy/mustache-test/partials.scm Normal file
View File

@ -0,0 +1,46 @@
(define (run-tests/partials)
(test-mustache "Basic Behavior"
'()
'(("text" . "from partial"))
"\"{{>text}}\""
"\"from partial\"")
(test-mustache "Failed Lookup"
'()
'()
"\"{{>text}}\""
"\"\"")
(test-mustache "Context"
'((text . "content"))
'(("partial" . "*{{text}}*"))
"\"{{>partial}}\""
"\"*content*\"")
(test-mustache "Recursion"
'((content . "X")
(nodes . #(((content . "Y")
(nodes . #())))))
'(("node" . "{{content}}<{{#nodes}}{{>node}}{{/nodes}}>"))
"{{>node}}"
"X<Y<>>")
(test-mustache "Surrounding Whitespace"
'()
'(("partial" . "\t|\t"))
"| {{>partial}} |"
"| \t|\t |")
(test-mustache "Inline Indentation"
'((data . "|"))
'(("partial" . ">\n>"))
" {{data}} {{> partial}}\n"
" | >\n>\n")
(test-mustache "Standalone Line Endings"
'()
'(("partial" . ">"))
"|\r\n{{>partial}}\r\n|"
"|\r\n>|"))

84
snow/arvyy/mustache-test/sections.scm Normal file
View File

@ -0,0 +1,84 @@
(define (run-tests/sections)
(test-mustache "Truthy"
'((boolean . #t))
"\"{{#boolean}}This should be rendered.{{/boolean}}\""
"\"This should be rendered.\"")
(test-mustache "Falsey"
'((boolean . #f))
"\"{{#boolean}}This should not be rendered.{{/boolean}}\""
"\"\"")
;; "Null is falsey" test is skipped; no meaningful value for null
(test-mustache "Context"
'((context . ((name . "Joe"))))
"\"{{#context}}Hi {{name}}.{{/context}}\""
"\"Hi Joe.\"")
(test-mustache "Parent contexts"
'((a . "foo")
(b . "wrong")
(sec . ((b . "bar")))
(c . ((d . "baz"))))
"\"{{#sec}}{{a}}, {{b}}, {{c.d}}{{/sec}}\""
"\"foo, bar, baz\"")
(test-mustache "Variable test"
'((foo . "bar"))
"\"{{#foo}}{{.}} is {{foo}}{{/foo}}\""
"\"bar is bar\"")
(test-mustache "List Contexts"
'((tops . #(((tname . ((upper . "A")
(lower . "a")))
(middles . #(((mname . "1")
(bottoms . #(((bname . "x"))
((bname . "y")))))))))))
"{{#tops}}{{#middles}}{{tname.lower}}{{mname}}.{{#bottoms}}{{tname.upper}}{{mname}}{{bname}}.{{/bottoms}}{{/middles}}{{/tops}}"
"a1.A1x.A1y.")
(test-mustache "Deeply Nested Contexts"
'((a . ((one . 1)))
(b . ((two . 2)))
(c . ((three . 3)
(d . ((four . 4)
(five . 5))))))
"
{{#a}}
{{one}}
{{#b}}
{{one}}{{two}}{{one}}
{{#c}}
{{one}}{{two}}{{three}}{{two}}{{one}}
{{#d}}
{{one}}{{two}}{{three}}{{four}}{{three}}{{two}}{{one}}
{{#five}}
{{one}}{{two}}{{three}}{{four}}{{five}}{{four}}{{three}}{{two}}{{one}}
{{one}}{{two}}{{three}}{{four}}{{.}}6{{.}}{{four}}{{three}}{{two}}{{one}}
{{one}}{{two}}{{three}}{{four}}{{five}}{{four}}{{three}}{{two}}{{one}}
{{/five}}
{{one}}{{two}}{{three}}{{four}}{{three}}{{two}}{{one}}
{{/d}}
{{one}}{{two}}{{three}}{{two}}{{one}}
{{/c}}
{{one}}{{two}}{{one}}
{{/b}}
{{one}}
{{/a}}
"
"
1
121
12321
1234321
123454321
12345654321
123454321
1234321
12321
121
1
"
))

27
snow/arvyy/mustache.sld Normal file
View File

@ -0,0 +1,27 @@
(define-library
(arvyy mustache)
(import (scheme base)
(scheme case-lambda)
(scheme write)
(arvyy mustache lookup)
(arvyy mustache collection)
(prefix (arvyy mustache executor) executor-)
(arvyy mustache parser)
(arvyy mustache tokenizer)
(srfi 1))
(export
execute
compile
current-lookup
current-collection
current-writer
compose-lookups
alist-lookup
collection
compose-collections
vector-collection
list-collection
stream-collection)
(include "mustache-impl.scm"))

64
snow/arvyy/mustache/collection.sld Normal file
View File

@ -0,0 +1,64 @@
(define-library
(arvyy mustache collection)
(import (scheme base)
(srfi 41))
(export
collection
collection-pred-proc
collection-empty?-proc
collection-for-each-proc
compose-collections
vector-collection
stream-collection
list-collection)
(begin
(define-record-type <collection>
(collection pred-proc empty?-proc for-each-proc)
collection?
(pred-proc collection-pred-proc)
(empty?-proc collection-empty?-proc)
(for-each-proc collection-for-each-proc))
(define vector-collection
(collection vector?
(lambda (v) (= 0 (vector-length v)))
vector-for-each))
(define list-collection
(collection list?
null?
for-each))
(define stream-collection
(collection stream?
stream-null?
stream-for-each))
(define (compose-collections . collections)
(define (find-collection object)
(let loop ((collections collections))
(cond
((null? collections)
#f)
(((collection-pred-proc (car collections)) object)
(car collections))
(else (loop (cdr collections))))))
(collection
;; predicate
(lambda (object)
(cond
((find-collection object) #t)
(else #f)))
;; empty proc
(lambda (object)
(cond
((find-collection object) => (lambda (c) ((collection-empty?-proc c) object)))
(else (error "Collection not found"))))
;; for-each proc
(lambda (proc object)
(cond
((find-collection object) => (lambda (c) ((collection-for-each-proc c) proc object)))
(else (error "Collection not found"))))))))

94
snow/arvyy/mustache/executor-impl.scm Normal file
View File

@ -0,0 +1,94 @@
(define (html-escape writer value)
(define str-value
(let ((out (open-output-string)))
(writer value out)
(get-output-string out)))
(define out (open-output-string))
(string-for-each
(lambda (char)
(case char
((#\&) (write-string "&amp;" out))
((#\<) (write-string "&lt;" out))
((#\>) (write-string "&gt;" out))
((#\") (write-string "&quot;" out))
(else (write-char char out))))
str-value)
(get-output-string out))
(define (lookup-in-stack-single name objs-stack lookup)
(let loop ((objs objs-stack))
(if (null? objs)
(values objs #f)
(lookup (car objs)
name
(lambda (value) (values objs value))
(lambda () (loop (cdr objs)))))))
(define (lookup-in-stack name-lst objs-stack lookup)
(define-values (objs value)
(lookup-in-stack-single (car name-lst) objs-stack lookup))
(cond
((not value) #f)
((null? (cdr name-lst)) value)
(else (lookup-in-stack (cdr name-lst)
(list value)
lookup))))
(define (execute template objs-stack partials out lookup collection? collection-empty? collection-for-each writer)
(define (execute-h template indent objs-stack)
(for-each
(lambda (fragment)
(cond
((string? fragment)
(write-string fragment out))
((new-line? fragment)
(begin
(write-string (new-line-content fragment) out)
(write-string (make-string indent #\space) out)))
((interp? fragment)
(let* ((name (interp-ref fragment))
(value (if (equal? '(".") name)
(car objs-stack)
(lookup-in-stack name
objs-stack
lookup))))
(if (interp-escape? fragment)
(write-string (html-escape writer value) out)
(writer value out))))
((section? fragment)
(let ((value (lookup-in-stack (section-ref fragment)
objs-stack
lookup))
(inner-template (section-content fragment)))
(cond
((not value)
(when (section-invert? fragment)
(execute-h inner-template indent objs-stack)))
((not (collection? value))
(unless (section-invert? fragment)
(execute-h inner-template indent (cons value objs-stack))))
(else
(if (section-invert? fragment)
(when (collection-empty? value)
(execute-h inner-template indent objs-stack))
(collection-for-each
(lambda (el)
(execute-h inner-template indent (cons el objs-stack)))
value))))))
((partial? fragment)
(let ()
(define partial-tpl
(cond
((assoc (partial-name fragment) partials) => cdr)
(else #f)))
(when partial-tpl
(execute-h partial-tpl
(+ indent (partial-indent fragment))
objs-stack) )))
(else (error "Unknown fragment"))))
template))
(execute-h template 0 objs-stack))

6
snow/arvyy/mustache/executor.sld Normal file
View File

@ -0,0 +1,6 @@
(define-library
(arvyy mustache executor)
(import (scheme base)
(arvyy mustache parser))
(export execute)
(include "executor-impl.scm"))

27
snow/arvyy/mustache/lookup.sld Normal file
View File

@ -0,0 +1,27 @@
(define-library
(arvyy mustache lookup)
(import (scheme base))
(export
compose-lookups
alist-lookup)
(begin
(define (compose-lookups . lookups)
(lambda (obj name found not-found)
(let loop ((lookups lookups))
(if (null? lookups)
(not-found)
(let ((l (car lookups)))
(l obj name found (lambda ()
(loop (cdr lookups)))))))))
(define (alist-lookup obj name found not-found)
(define key (string->symbol name))
(define alist? (and (list? obj)
(or (null? obj)
(pair? (car obj)))))
(if alist?
(cond
((assoc key obj) => (lambda (pair) (found (cdr pair))))
(else (not-found)))
(not-found)))))

296
snow/arvyy/mustache/parser-impl.scm Normal file
View File

@ -0,0 +1,296 @@
(define-record-type <interp>
(interp ref escape?)
interp?
(ref interp-ref)
(escape? interp-escape?) ;; should html be escaped
)
(define-record-type <section>
(section ref invert? content raw-content)
section?
(ref section-ref)
(invert? section-invert?) ;; normal section if false, {{^ section if true
(content section-content) ;; compiled inner content
(raw-content section-raw-content) ;; uncompiled inner content as a string; used for lambdas
)
(define-record-type <partial>
(partial name indent)
partial?
(name partial-name)
(indent partial-indent))
(define-record-type <newline>
(new-line content)
new-line?
(content new-line-content))
(define (parse tokens)
(let* ((tokens (replace-standalone tokens))
(tokens (remove-non-visible tokens))
(tokens (convert-string-tokens tokens))
(tokens (parse-interp+sections tokens)))
tokens))
(define (tpl->string tokens)
(define (->string item out)
(cond
((string? item) (write-string item out))
((new-line? item) (write-string (new-line-content item) out))
((section? item)
(let ((tagname (list->tagname (section-ref item))))
(write-string (if (section-invert? item) "{{^" "{{#") out)
(write-string tagname out)
(write-string "}}" out)
(for-each
(lambda (item*)
(->string item* out))
(section-content item))
(write-string "{{/" out)
(write-string tagname out)
(write-string "}}" out)))
((interp? item)
(let ((tagname (list->tagname (interp-ref item))))
(write-string (if (interp-escape? item) "{{" "{{&") out)
(write-string tagname out)
(write-string "}}" out)))))
(define out (open-output-string))
(for-each
(lambda (item) (->string item out))
tokens)
(get-output-string out))
;;TODO remove this
(define (debug-tokens tokens)
(for-each
(lambda (t)
(cond
((token-str? t) (display (string-append "#<<token-str> " (token-str-content t) "> ")))
((token-nl? t) (display "#<<token-nl>> "))
((token-section-open? t) (display (string-append "#<<token-open> " (token-section-open-tag t) "> ")))
((token-section-close? t) (display "#<<token-close>> "))
((token-ws? t) (display (string-append "#<<token-ws> " (number->string (token-ws-count t)) "> ")))
((token-interp? t) (display (string-append "#<<token-interp> " (token-interp-tag t) "> ")))
(else (display t))))
tokens
)
)
(define (standalone/remove? token)
(or (token-comment? token)
(token-delimchager? token)))
(define (standalone/trim? token)
(or (token-section-open? token)
(token-section-close? token)))
(define (replace-standalone tokens)
(let loop ((tokens tokens)
(result/inv '())
(first #t))
(cond
((null? tokens) (reverse result/inv))
((and first
(or (match-follows tokens standalone/remove? token-ws? token-nl?)
(match-follows tokens standalone/remove? token-nl?)
(match-follows tokens token-ws? standalone/remove? token-ws? token-nl?)
(match-follows tokens token-ws? standalone/remove? token-nl?))) =>
(lambda (tokens*)
(loop tokens*
result/inv
#t)))
((and first
(or (match-follows tokens token-ws? standalone/remove? token-ws? eof-object?)
(match-follows tokens token-ws? standalone/remove? eof-object?)
(match-follows tokens standalone/remove? token-ws? eof-object?)
(match-follows tokens standalone/remove? eof-object?))) =>
(lambda (tokens*)
(loop '()
result/inv
#t)))
((and first
(or (match-follows tokens token-ws? standalone/trim? token-ws? token-nl?)
(match-follows tokens token-ws? standalone/trim? token-nl?)
(match-follows tokens token-ws? standalone/trim? token-ws? eof-object?)
(match-follows tokens token-ws? standalone/trim? eof-object?))) =>
(lambda (tokens*)
(loop tokens*
(append (list (cadr tokens))
result/inv)
#t)))
((and first
(or (match-follows tokens standalone/trim? token-ws? token-nl?)
(match-follows tokens standalone/trim? token-nl?)
(match-follows tokens standalone/trim? token-ws? eof-object?)
(match-follows tokens standalone/trim? eof-object?))) =>
(lambda (tokens*)
(loop tokens*
(append (list (car tokens))
result/inv)
#t)))
((and first
(or (match-follows tokens token-ws? token-partial? token-ws? token-nl?)
(match-follows tokens token-ws? token-partial? token-nl?)
(match-follows tokens token-ws? token-partial? token-ws? eof-object?)
(match-follows tokens token-ws? token-partial? eof-object?))) =>
(lambda (tokens*)
(loop tokens*
(append (list (partial (token-partial-tag (cadr tokens))
(token-ws-count (car tokens))))
result/inv)
#t)))
((and first
(or (match-follows tokens token-partial? token-ws? token-nl?)
(match-follows tokens token-partial? token-nl?)
(match-follows tokens token-partial? token-ws? eof-object?)
(match-follows tokens token-partial? eof-object?))) =>
(lambda (tokens*)
(loop tokens*
(append (list (partial (token-partial-tag (car tokens))
0))
result/inv)
#t)))
((match-follows tokens token-partial?) => (lambda (tokens*)
(loop tokens*
(cons (partial (token-partial-tag (car tokens))
0)
result/inv)
#f)))
(else (loop (cdr tokens)
(cons (car tokens) result/inv)
(token-nl? (car tokens)))))))
(define (convert-string-tokens tokens)
(let loop ((tokens tokens)
(out #f)
(result/inv '()))
(cond
((null? tokens)
(let ((result-final/inv (if out
(cons (get-output-string out)
result/inv)
result/inv)))
(reverse result-final/inv)))
((or (token-str? (car tokens))
(token-ws? (car tokens)))
(let* ((token (car tokens))
(out* (if out
out
(open-output-string)))
(str (if (token-str? token)
(token-str-content token)
(make-string (token-ws-count token) #\space))))
(write-string str out*)
(loop (cdr tokens)
out*
result/inv)))
(else (let* ((token (car tokens))
(value (cond
((token-nl? token) (new-line (list->string (token-nl-chars token))))
(else token)))
(new-result/inv (if out
(cons (get-output-string out)
result/inv)
result/inv)))
(loop (cdr tokens)
#f
(cons value new-result/inv)))))))
(define (parse-interp+sections tokens)
(define (parse-interp+sections* tokens expected-close-tag)
(let loop ((tokens tokens)
(result/inv '()))
(cond
((null? tokens)
(if expected-close-tag
(error "Unexpected eof")
(values '() (reverse result/inv))))
((token-section-close? (car tokens))
(if (equal? expected-close-tag (token-section-close-tag (car tokens)))
(values (cdr tokens) (reverse result/inv))
(error "Closing token mismatch")))
((token-section-open? (car tokens))
(let* ((token (car tokens))
(tag (token-section-open-tag token))
(ref (tagname->list tag)))
(define-values (tokens* result*)
(parse-interp+sections* (cdr tokens)
tag))
(define value (section ref
(token-section-open-inverted? token)
result*
#f))
(loop tokens*
(cons value result/inv))))
((token-interp? (car tokens))
(let* ((token (car tokens))
(tag (token-interp-tag token))
(ref (tagname->list tag)))
(define value (interp ref (token-interp-escape? token)))
(loop (cdr tokens)
(cons value result/inv))))
(else (loop (cdr tokens)
(cons (car tokens)
result/inv))))))
(define-values (tokens* result)
(parse-interp+sections* tokens #f))
result)
(define (remove-non-visible tokens)
(filter
(lambda (token)
(not (or (token-comment? token)
(token-delimchager? token))))
tokens))
(define (match-follows in . preds)
(let loop ((in* in)
(preds* preds))
(cond
((null? preds*) in*)
((null? in*) (and (null? (cdr preds*))
(eq? (car preds*) eof-object?)
'()))
(((car preds*) (car in*))
(loop (cdr in*)
(cdr preds*)))
(else #f))))
(define (tagname->list str)
(define (prepend-part parts part)
(when (null? part)
(error "Trailing period in tag name"))
(cons (list->string (reverse part))
parts))
(if (equal? "." str)
'(".")
(let loop ((in (string->list str))
(parts '())
(part '()))
(cond
((null? in)
(reverse (prepend-part parts part)))
((char=? #\. (car in))
(loop (cdr in)
(prepend-part parts part)
'()))
(else (loop (cdr in)
parts
(cons (car in) part)))))))
(define (list->tagname lst)
(apply string-append
(cdr (apply append
(map
(lambda (el) (list "." el))
lst)))))

14
snow/arvyy/mustache/parser.sld Normal file
View File

@ -0,0 +1,14 @@
(define-library
(arvyy mustache parser)
(import (scheme base)
(scheme write)
(scheme cxr)
(arvyy mustache tokenizer)
(srfi 1))
(export
parse
interp? interp-ref interp-escape?
section? section-ref section-invert? section-content section-raw-content
partial? partial-name partial-indent
new-line? new-line-content)
(include "parser-impl.scm"))

237
snow/arvyy/mustache/tokenizer-impl.scm Normal file
View File

@ -0,0 +1,237 @@
(define-record-type <token-ws>
(token-ws count)
token-ws?
(count token-ws-count))
(define-record-type <token-nl>
(token-nl chars)
token-nl?
(chars token-nl-chars))
(define-record-type <token-comment>
(token-comment)
token-comment?)
(define-record-type <token-str>
(token-str content)
token-str?
(content token-str-content))
(define-record-type <token-delimchanger>
(token-delimchager open close)
token-delimchager?
(open token-delimchager-open)
(close token-delimchager-close))
(define-record-type <token-interp>
(token-interp tag escape?)
token-interp?
(tag token-interp-tag)
(escape? token-interp-escape?))
(define-record-type <token-section-open>
(token-section-open tag inverted?)
token-section-open?
(tag token-section-open-tag)
(inverted? token-section-open-inverted?))
(define-record-type <token-section-close>
(token-section-close tag)
token-section-close?
(tag token-section-close-tag))
(define-record-type <token-partial>
(token-partial tag)
token-partial?
(tag token-partial-tag))
(define (read-tokens str)
(let loop ((in (string->list str))
(ws-count 0)
(str-value '())
(open-delim '(#\{ #\{))
(close-delim '(#\} #\}))
(result/inv '()))
(define (resolve-ws/str)
(cond
;; unflushed ws and str info
((and (not (null? str-value))
(> ws-count 0))
(append (list (token-ws ws-count)
(token-str (list->string (reverse str-value))))
result/inv))
;; unflushed str info
((not (null? str-value))
(cons (token-str (list->string (reverse str-value)))
result/inv))
;; unflushed ws info
((> ws-count 0)
(cons (token-ws ws-count)
result/inv))
;; no unflushed info
(else result/inv)))
;; handle when in is null; ie final function return
(define (return)
(define final-result/inv (resolve-ws/str))
(reverse final-result/inv))
;; handle after tag read
(define (continue-after-tag in token)
(loop
in
0
'()
open-delim
close-delim
(cons token (resolve-ws/str))))
(define (process-interp in)
(define-values (in* tag)
(read-tag in close-delim))
(continue-after-tag in* (token-interp tag #t)))
(define (process-triple-mustache in)
(define-values (in* tag)
(read-tag in '(#\} #\} #\})))
(continue-after-tag in* (token-interp tag #f)))
(define (process-ampersand in)
(define-values (in* tag)
(read-tag in close-delim))
(continue-after-tag in* (token-interp tag #f)))
(define (process-inverted in)
(define-values (in* tag)
(read-tag in close-delim))
(continue-after-tag in* (token-section-open tag #t)))
(define (process-section in)
(define-values (in* tag)
(read-tag in close-delim))
(continue-after-tag in* (token-section-open tag #f)))
(define (process-close in)
(define-values (in* tag)
(read-tag in close-delim))
(continue-after-tag in* (token-section-close tag)))
(define (process-partial in)
(define-values (in* tag)
(read-tag in close-delim))
(continue-after-tag in* (token-partial tag)))
(define (process-comment in)
(let loop* ((in in))
(cond
((null? in) (error "Unexpected EOF"))
((match-follows in close-delim) => (lambda (in*)
(continue-after-tag in* (token-comment))))
(else (loop* (cdr in))))))
(define (process-delim-change in)
(let*-values (((in new-open) (read-tag in #f))
((in new-close) (read-tag in (cons #\= close-delim))))
(loop in
0
'()
(string->list new-open)
(string->list new-close)
(cons (token-delimchager new-open new-close)
(resolve-ws/str)))))
(define (process-open-delim in*)
(cond
((match-follows in* '(#\&)) => process-ampersand)
((match-follows in* '(#\^)) => process-inverted)
((match-follows in* '(#\#)) => process-section)
((match-follows in* '(#\/)) => process-close)
((match-follows in* '(#\>)) => process-partial)
((match-follows in* '(#\=)) => process-delim-change)
((match-follows in* '(#\!)) => process-comment)
(else (process-interp in*))))
(define (process-space in*)
(loop in*
(+ 1 ws-count)
str-value
open-delim
close-delim
result/inv))
(define (process-eol in* chars)
(loop in*
0
'()
open-delim
close-delim
(cons (token-nl chars)
(resolve-ws/str))))
(define (process-nl in*)
(process-eol in* '(#\newline)))
(define (process-crnl in*)
(process-eol in* '(#\return #\newline)))
(define (process-char)
(loop (cdr in)
0
(append (list (car in))
(make-list ws-count #\space)
str-value)
open-delim
close-delim
result/inv))
;; loop handler
(cond
((null? in) (return))
((match-follows in '(#\{ #\{ #\{)) => process-triple-mustache)
((match-follows in open-delim) => process-open-delim)
((match-follows in '(#\space)) => process-space)
((match-follows in '(#\newline)) => process-nl)
((match-follows in '(#\return #\newline)) => process-crnl)
(else (process-char)))))
(define (match-follows in chars)
(let loop ((in* in)
(chars* chars))
(cond
((null? chars*) in*)
((null? in*) #f)
((char=? (car in*) (car chars*))
(loop (cdr in*)
(cdr chars*)))
(else #f))))
(define (skip-spaces in)
(cond
((null? in) '())
((char=? (car in) #\space) (skip-spaces (cdr in)))
(else in)))
(define (read-tag in close-delim)
(define-values
(tag in*)
(let loop ((in (skip-spaces in))
(result '()))
(define (return)
(values (list->string (reverse result))
in))
(cond
((null? in) (error "Unexpected EOF"))
((char=? (car in) #\space) (return))
((and close-delim (match-follows in close-delim))
(return))
(else (loop (cdr in)
(cons (car in) result))))))
(cond
((not close-delim) (values in* tag))
((match-follows (skip-spaces in*) close-delim) => (lambda (in**)
(values in** tag)))
(else (error "Bad tag"))))

15
snow/arvyy/mustache/tokenizer.sld Normal file
View File

@ -0,0 +1,15 @@
(define-library
(arvyy mustache tokenizer)
(import (scheme base))
(export
read-tokens
token-ws? token-ws-count
token-nl token-nl? token-nl-chars
token-comment?
token-str? token-str-content
token-delimchager? token-delimchager-open token-delimchager-close
token-interp? token-interp-tag token-interp-escape?
token-section-open? token-section-open-tag token-section-open-inverted?
token-section-close? token-section-close-tag
token-partial? token-partial-tag)
(include "tokenizer-impl.scm"))

47
snow/chibi/diff-test.sld Normal file
View File

@ -0,0 +1,47 @@
(define-library (chibi diff-test)
(import (scheme base) (chibi diff))
(export run-tests)
(cond-expand
(chibi (import (chibi test)))
(else
(import (scheme write))
;; inline (chibi test) to avoid circular dependencies in snow
;; installations
(begin
(define-syntax test
(syntax-rules ()
((test expect expr)
(test 'expr expect expr))
((test name expect expr)
(guard (exn (else (display "!\nERROR: ") (write name) (newline)
(write exn) (newline)))
(let* ((res expr)
(pass? (equal? expect expr)))
(display (if pass? "." "x"))
(cond
((not pass?)
(display "\nFAIL: ") (write name) (newline))))))))
(define (test-begin name)
(display name))
(define (test-end)
(newline)))))
(begin
(define (run-tests)
(test-begin "diff")
(test '((#\A 1 0) (#\C 2 2))
(lcs-with-positions '(#\G #\A #\C) '(#\A #\G #\C #\A #\T)))
(test '(#\A #\C)
(lcs '(#\G #\A #\C) '(#\A #\G #\C #\A #\T)))
(test '((#\G #\A #\C) (#\A #\G #\C #\A #\T) ((#\A 1 0) (#\C 2 2)))
(diff "GAC" "AGCAT" read-char))
(let ((d (diff "GAC" "AGCAT" read-char)))
(test " »G« AC"
(edits->string (car d) (car (cddr d)) 1))
(test "A «G» C «AT» "
(edits->string (cadr d) (car (cddr d)) 2))
(test "\x1b;[31mG\x1b;[39mAC"
(edits->string/color (car d) (car (cddr d)) 1))
(test "A\x1b;[32mG\x1b;[39mC\x1b;[32mAT\x1b;[39m"
(edits->string/color (cadr d) (car (cddr d)) 2)))
(test-end))))

75
snow/chibi/diff.html Normal file
View File

@ -0,0 +1,75 @@
<html><head>
<style type="text/css">
body {color: #000; background-color: #FFFFF8;}
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 250px; height: 100%}
div#menu a:link {text-decoration: none}
div#main {font-size: large; position: absolute; top: 0; left: 260px; max-width: 590px; height: 100%}
div#notes {position: relative; top: 2em; left: 620px; width: 200px; height: 0px; font-size: smaller;}
div#footer {padding-bottom: 50px}
div#menu ol {list-style-position:inside; padding-left: 5px; margin-left: 5px}
div#menu ol ol {list-style: lower-alpha; padding-left: 15px; margin-left: 15px}
div#menu ol ol ol {list-style: decimal; padding-left: 5px; margin-left: 5px}
h2 { color: #888888; border-top: 3px solid #4588ba; }
h3 { color: #666666; border-top: 2px solid #4588ba; }
h4 { color: #222288; border-top: 1px solid #4588ba; }
.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
.output { color: #000; background-color: beige; width: 100%; padding: 3px}
.error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px}
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
.keyword { color: #800080; background-color: inherit; }
.type { color: #008000; background-color: inherit; }
.function { color: #0000FF; background-color: inherit; }
.variable { color: #B8860B; background-color: inherit; }
.comment { color: #FF0000; background-color: inherit; }
.string { color: #BC8F8F; background-color: inherit; }
.attribute { color: #FF5000; background-color: inherit; }
.preprocessor { color: #FF00FF; background-color: inherit; }
.builtin { color: #FF00FF; background-color: inherit; }
.character { color: #0055AA; background-color: inherit; }
.syntaxerror { color: #FF0000; background-color: inherit; }
.diff-deleted { color: #5F2121; background-color: inherit; }
.diff-added { color: #215F21; background-color: inherit; }
span.paren1 { color: #AAAAAA; background-color: inherit; }
span.paren2 { color: #888888; background-color: inherit; }
span.paren3 { color: #666666; background-color: inherit; }
span.paren4 { color: #444444; background-color: inherit; }
span.paren5 { color: #222222; background-color: inherit; }
span.paren6 { color: #000000; background-color: inherit; }
</style>
</head><body><div id="menu"><ol><li><a href="#h4_lcs">lcs</a></li><li><a href="#h4_lcs-with-positions">lcs-with-positions</a></li><li><a href="#h4_diff">diff</a></li><li><a href="#h4_write-diff">write-diff</a></li><li><a href="#h4_diff->string">diff->string</a></li><li><a href="#h4_write-line-diffs">write-line-diffs</a></li><li><a href="#h4_write-line-diffs/color">write-line-diffs/color</a></li><li><a href="#h4_write-char-diffs">write-char-diffs</a></li><li><a href="#h4_write-char-diffs/color">write-char-diffs/color</a></li><li><a href="#h4_write-edits">write-edits</a></li><li><a href="#h4_edits->string">edits->string</a></li><li><a href="#h4_edits->string/color">edits->string/color</a></li></ol></div><div id="main"><div><a name="h1_(chibidiff)"></a><h1>(chibi diff)</h1></div><div><a name="h4_lcs"></a><h4><code>(lcs a-ls b-ls [eq])</code></h4></div>Finds the Longest Common Subsequence between <code>a-ls</code> and
<code>b-ls</code>, comparing elements with <code>eq</code> (default
<code><span>equal?</span></code>. Returns this sequence as a list, using the
elements from <code>a-ls</code>. Uses quadratic time and space.<div><a name="h4_lcs-with-positions"></a><h4><code>(lcs-with-positions a-ls b-ls [eq])</code></h4></div>Variant of <code><span>lcs</span></code> which returns the annotated sequence. The
result is a list of the common elements, each represented as a
list of 3 values: the element, the zero-indexed position in
<code>a-ls</code> where the element occurred, and the position in
<code>b-ls</code>.<div><a name="h4_diff"></a><h4><code>(diff a b [reader eq])</code></h4></div>Utility to run lcs on text. <code>a</code> and <code>b</code> can be strings or
ports, which are tokenized into a sequence by calling <code>reader</code>
until <code>eof-object</code> is found. Returns a list of three values,
the sequences read from <code>a</code> and <code>b</code>, and the <code><span>lcs</span></code>
result.<div><a name="h4_write-diff"></a><h4><code>(write-diff diff [writer out])</code></h4></div>Utility to format the result of a <code>diff</code> to output port
<code>out</code> (default <code>(current-output-port)</code>). Applies
<code>writer</code> to successive diff chunks. <code>writer</code> should be a
procedure of three arguments: <code>(writer <span>subsequence</span> <span>type</span>
<span>out</span>)<span>.</span> <code><span>subsequence</span></code> <span>is</span> <span>a</span> <span>subsequence</span> <span>from</span> <span>the</span> <span>original</span> <span>input</span>,
<code><span>type</span></code> <span>is</span> <span>a</span> <span>symbol</span> <span>indicating</span> <span>the</span> <span>type</span> <span>of</span> <span>diff:</span> <code>'<span><span>same</span></span></code>
<span>if</span> <span>this</span> <span>is</span> <span>part</span> <span>of</span> <span>the</span> <span>lcs</span>, <code>'<span><span>add</span></span></code> <span>if</span> <span>it</span> <span>is</span> <span>unique</span> <span>to</span> <span>the</span>
<span>second</span> <span>input</span>, <span>or</span> <code>'<span><span>remove</span></span></code> <span>if</span> <span>it</span> <span>is</span> <span>unique</span> <span>to</span> <span>the</span> <span>first</span>
<span>input.</span> <code><span>writer</span></code> <span>defaults</span> <span>to</span> <code><span><span>write-line-diffs</span></span></code>,
<span>assuming</span> <span>the</span> <span>default</span> <span>line</span> <span>diffs.</span></code><div><a name="h4_diff->string"></a><h4><code>(diff->string diff . o)</code></h4></div>Equivalent to <code><span>write-diff</span></code> but collects the output to a string.<div><a name="h4_write-line-diffs"></a><h4><code>(write-line-diffs lines type out)</code></h4></div>The default writer for <code><span>write-diff</span></code>, annotates simple +/-
prefixes for added/removed lines.<div><a name="h4_write-line-diffs/color"></a><h4><code>(write-line-diffs/color lines type out)</code></h4></div>A variant of <code><span>write-line-diffs</span></code> which adds red/green ANSI
coloring to the +/- prefix.<div><a name="h4_write-char-diffs"></a><h4><code>(write-char-diffs chars type out)</code></h4></div>A diff writer for sequences of characters (when a diff was
generated with <code><span>read-char</span></code>), enclosing added characters in
«...» brackets and removed characters in »...«.<div><a name="h4_write-char-diffs/color"></a><h4><code>(write-char-diffs/color chars type out)</code></h4></div>A diff writer for sequences of characters (when a diff was
generated with <code><span>read-char</span></code>), formatting added characters in
green and removed characters in red.<div><a name="h4_write-edits"></a><h4><code>(write-edits ls lcs [index writer out])</code></h4></div>Utility to format the result of a <code><span>diff</span></code> with respect to a
single input sequence <code>ls</code>. <code>lcs</code> is the annotated common
sequence from <code><span>diff</span></code> or <code><span>lcs-with-positions</span></code>, and
<code>index</code> is the index (0 or 1, default 1) of <code>ls</code> in the
original call. Since we have no information about the other
input, we can only format what is the same and what is different,
formatting the differences as either added (if <code>index</code> is 0)
or removed (if <code>index</code> is 1).<div><a name="h4_edits->string"></a><h4><code>(edits->string ls lcs [type writer])</code></h4></div>Equivalent to <code><span>write-edits</span></code> but collects the output to a string.<div><a name="h4_edits->string/color"></a><h4><code>(edits->string/color ls lcs [type writer])</code></h4></div>Equivalent to <code><span>write-edits</span></code> but collects the output to a
string and uses a color-aware writer by default. Note with a
character diff this returns the original input string as-is, with
only ANSI escapes indicating what changed.<div id="footer"></div></div></body></html>

239
snow/chibi/diff.scm Normal file
View File

@ -0,0 +1,239 @@
;; utility for lcs-with-positions
(define (max-seq . o)
(if (null? o)
(list 0 '())
(let loop ((a (car o)) (ls (cdr o)))
(if (null? ls)
a
(let ((b (car ls)))
(if (>= (car a) (car b))
(loop a (cdr ls))
(loop b (cdr ls))))))))
;;> Finds the Longest Common Subsequence between \var{a-ls} and
;;> \var{b-ls}, comparing elements with \var{eq} (default
;;> \scheme{equal?}. Returns this sequence as a list, using the
;;> elements from \var{a-ls}. Uses quadratic time and space.
(define (lcs a-ls b-ls . o)
(let ((eq (if (pair? o) (car o) equal?)))
(map car (lcs-with-positions a-ls b-ls eq))))
;;> Variant of \scheme{lcs} which returns the annotated sequence. The
;;> result is a list of the common elements, each represented as a
;;> list of 3 values: the element, the zero-indexed position in
;;> \var{a-ls} where the element occurred, and the position in
;;> \var{b-ls}.
(define (lcs-with-positions a-ls b-ls . o)
(let* ((eq (if (pair? o) (car o) equal?))
(a-len (+ 1 (length a-ls)))
(b-len (+ 1 (length b-ls)))
(results (make-vector (* a-len b-len) #f)))
(let loop ((a a-ls) (a-pos 0) (b b-ls) (b-pos 0))
;; cache this step if not already done
(let ((i (+ (* a-pos b-len) b-pos)))
(or (vector-ref results i)
(let ((res
(if (or (null? a) (null? b))
(list 0 '()) ;; base case
(let ((a1 (car a))
(b1 (car b))
(a-tail (loop (cdr a) (+ a-pos 1) b b-pos))
(b-tail (loop a a-pos (cdr b) (+ b-pos 1))))
(cond
((eq a1 b1)
;; match found, we either use it or we don't
(let* ((a-b-tail (loop (cdr a) (+ a-pos 1)
(cdr b) (+ b-pos 1)))
(a-b-res (list (+ 1 (car a-b-tail))
(cons (list a1 a-pos b-pos)
(cadr a-b-tail)))))
(max-seq a-b-res a-tail b-tail)))
(else
;; not a match
(max-seq a-tail b-tail)))))))
(vector-set! results i res)
res))))
(cadr (vector-ref results 0))))
(define (source->list x reader)
(port->list
reader
(cond ((port? x) x)
((string? x) (open-input-string x))
(else (error "don't know how to diff from:" x)))))
;;> Utility to run lcs on text. \var{a} and \var{b} can be strings or
;;> ports, which are tokenized into a sequence by calling \var{reader}
;;> until \var{eof-object} is found. Returns a list of three values,
;;> the sequences read from \var{a} and \var{b}, and the \scheme{lcs}
;;> result.
(define (diff a b . o)
(let-optionals o ((reader read-line)
(eq equal?))
(let ((a-ls (source->list a reader))
(b-ls (source->list b reader)))
(list a-ls b-ls (lcs-with-positions a-ls b-ls eq)))))
;;> Utility to format the result of a \var{diff} to output port
;;> \var{out} (default \scheme{(current-output-port)}). Applies
;;> \var{writer} to successive diff chunks. \var{writer} should be a
;;> procedure of three arguments: \scheme{(writer subsequence type
;;> out). \var{subsequence} is a subsequence from the original input,
;;> \var{type} is a symbol indicating the type of diff: \scheme{'same}
;;> if this is part of the lcs, \scheme{'add} if it is unique to the
;;> second input, or \scheme{'remove} if it is unique to the first
;;> input. \var{writer} defaults to \scheme{write-line-diffs},
;;> assuming the default line diffs.
(define (write-diff diff . o)
(let-optionals o ((writer write-line-diffs)
(out (current-output-port)))
(let* ((a-ls (car diff))
(b-ls (cadr diff))
(d-ls (car (cddr diff))))
;; context diff
(let lp ((d d-ls) (a a-ls) (a-pos 0) (b b-ls) (b-pos 0))
(unless (null? d)
(let* ((d1 (car d))
(a-off (cadr d1))
(a-skip (- a-off a-pos))
(b-off (car (cddr d1)))
(b-skip (- b-off b-pos)))
(let-values (((a-head a-tail) (split-at a a-skip))
((b-head b-tail) (split-at b b-skip)))
;; elements only in a have been removed
(if (pair? a-head)
(writer (cdr a-head) 'remove out))
;; elements only in b have been added
(if (pair? b-head)
(writer (cdr b-head) 'add out))
;; reprint this common element
(writer (list (car d1)) 'same out)
;; recurse
(lp (cdr d) a-tail a-off b-tail b-off))))))))
;;> Equivalent to \scheme{write-diff} but collects the output to a string.
(define (diff->string diff . o)
(let ((out (open-output-string)))
(write-diff diff (if (pair? o) (car o) write-line-diffs) out)
(get-output-string out)))
;;> The default writer for \scheme{write-diff}, annotates simple +/-
;;> prefixes for added/removed lines.
(define (write-line-diffs lines type out)
(for-each
(lambda (line)
(case type
((add)
(write-char #\+ out))
((remove)
(write-char #\- out))
((same)
(write-char #\space out))
(else (error "unknown diff type:" type)))
(write-string line out)
(newline out))
lines))
;;> A variant of \scheme{write-line-diffs} which adds red/green ANSI
;;> coloring to the +/- prefix.
(define (write-line-diffs/color lines type out)
(for-each
(lambda (line)
(case type
((add)
(write-string (green "+") out)
(write-string (green line) out))
((remove)
(write-string (red "-") out)
(write-string (red line out)))
((same)
(write-char #\space out)
(write-string line out))
(else (error "unknown diff type:" type)))
(newline out))
lines))
;;> A diff writer for sequences of characters (when a diff was
;;> generated with \scheme{read-char}), enclosing added characters in
;;> «...» brackets and removed characters in »...«.
(define (write-char-diffs chars type out)
(case type
((add)
(write-string " «" out)
(write-string (list->string chars) out)
(write-string "» " out))
((remove)
(write-string " »" out)
(write-string (list->string chars) out)
(write-string "« " out))
((same)
(write-string (list->string chars) out))
(else (error "unknown diff type:" type))))
;;> A diff writer for sequences of characters (when a diff was
;;> generated with \scheme{read-char}), formatting added characters in
;;> green and removed characters in red.
(define (write-char-diffs/color chars type out)
(case type
((add)
(write-string (green (list->string chars)) out))
((remove)
(write-string (red (list->string chars)) out))
((same)
(write-string (list->string chars) out))
(else (error "unknown diff type:" type))))
;;> Utility to format the result of a \scheme{diff} with respect to a
;;> single input sequence \var{ls}. \var{lcs} is the annotated common
;;> sequence from \scheme{diff} or \scheme{lcs-with-positions}, and
;;> \var{index} is the index (0 or 1, default 1) of \var{ls} in the
;;> original call. Since we have no information about the other
;;> input, we can only format what is the same and what is different,
;;> formatting the differences as either added (if \var{index} is 0)
;;> or removed (if \var{index} is 1).
(define (write-edits ls lcs . o)
(let-optionals o ((index 1)
(writer write-line-diffs)
(out (current-output-port)))
(let ((type (if (eq? index 1) 'remove 'add)))
(let lp ((ls ls) (lcs lcs) (buf '(#f)) (i 0))
(define (output ch type)
(cond
((eq? type (car buf))
(cons type (cons ch (cdr buf))))
(else
(if (car buf)
(writer (reverse (cdr buf)) (car buf) out))
(list type ch))))
(cond
((null? ls) (output #f 'done))
((null? lcs)
(lp (cdr ls) lcs (output (car ls) type) (+ i 1)))
((= i (list-ref (car lcs) index))
(lp (cdr ls) (cdr lcs) (output (car ls) 'same) (+ i 1)))
(else
(lp (cdr ls) lcs (output (car ls) type) (+ i 1))))))))
;;> Equivalent to \scheme{write-edits} but collects the output to a string.
(define (edits->string ls lcs . o)
(let-optionals o ((type 'add)
(writer (if (and (pair? ls) (char? (car ls)))
write-char-diffs
write-line-diffs)))
(let ((out (open-output-string)))
(write-edits ls lcs type writer out)
(get-output-string out))))
;;> Equivalent to \scheme{write-edits} but collects the output to a
;;> string and uses a color-aware writer by default. Note with a
;;> character diff this returns the original input string as-is, with
;;> only ANSI escapes indicating what changed.
(define (edits->string/color ls lcs . o)
(let-optionals o ((type 'add)
(writer (if (and (pair? ls) (char? (car ls)))
write-char-diffs/color
write-line-diffs/color)))
(let ((out (open-output-string)))
(write-edits ls lcs type writer out)
(get-output-string out))))

21
snow/chibi/diff.sld Normal file
View File

@ -0,0 +1,21 @@
(define-library (chibi diff)
(import (scheme base) (srfi 1) (chibi optional) (chibi term ansi))
(export lcs lcs-with-positions
diff write-diff diff->string
write-edits edits->string edits->string/color
write-line-diffs
write-line-diffs/color
write-char-diffs
write-char-diffs/color)
(cond-expand
(chibi (import (only (chibi io) port->list)))
(else
(begin
(define (port->list reader port)
(let lp ((res '()))
(let ((x (reader port)))
(if (eof-object? x)
(reverse res)
(lp (cons x res)))))))))
(include "diff.scm"))

72
snow/chibi/optional-test.sld Normal file
View File

@ -0,0 +1,72 @@
(define-library (chibi optional-test)
(import (scheme base) (chibi optional))
(cond-expand
(chibi (import (chibi test)))
(else
(import (scheme write))
;; inline (chibi test) to avoid circular dependencies in snow
;; installations
(begin
(define-syntax test
(syntax-rules ()
((test expect expr)
(test 'expr expect expr))
((test name expect expr)
(guard (exn (else (display "!\nERROR: ") (write name) (newline)
(write exn) (newline)))
(let* ((res expr)
(pass? (equal? expect expr)))
(display (if pass? "." "x"))
(cond
((not pass?)
(display "\nFAIL: ") (write name) (newline))))))))
(define-syntax test-assert
(syntax-rules ()
((test-assert expr) (test #t expr))))
(define-syntax test-error
(syntax-rules ()
((test-error expr)
(test-assert (guard (exn (else #t)) expr #f)))))
(define (test-begin name)
(display name))
(define (test-end)
(newline)))))
(export run-tests)
(begin
(define (run-tests)
(test-begin "optional")
(test '(0 11 12)
(let-optionals '(0) ((a 10) (b 11) (c 12))
(list a b c)))
(test '(0 11 12)
((opt-lambda ((a 10) (b 11) (c 12))
(list a b c))
0))
(test '(0 11 12)
((opt-lambda (a (b 11) (c 12))
(list a b c))
0))
(test '(0 1 (2 3 4))
(let-optionals* '(0 1 2 3 4) ((a 10) (b 11) . c)
(list a b c)))
(test '(0 1 (2 3 4))
(let-optionals '(0 1 2 3 4) ((a 10) (b 11) . c)
(list a b c)))
(cond-expand
(gauche) ; gauche detects this at compile-time, can't catch
(else (test-error '(0 11 12)
((opt-lambda (a (b 11) (c 12))
(list a b c))))))
(let ()
(define-opt (f a (b 11) (c 12))
(list a b c))
(cond-expand
(gauche)
(else
(test-error (f))))
(test '(0 11 12) (f 0))
(test '(0 1 12) (f 0 1))
(test '(0 1 2) (f 0 1 2))
(test '(0 1 2) (f 0 1 2 3)))
(test-end))))

137
snow/chibi/optional.html Normal file
View File

@ -0,0 +1,137 @@
<html><head>
<style type="text/css">
body {color: #000; background-color: #FFFFF8;}
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 250px; height: 100%}
div#menu a:link {text-decoration: none}
div#main {font-size: large; position: absolute; top: 0; left: 260px; max-width: 590px; height: 100%}
div#notes {position: relative; top: 2em; left: 620px; width: 200px; height: 0px; font-size: smaller;}
div#footer {padding-bottom: 50px}
div#menu ol {list-style-position:inside; padding-left: 5px; margin-left: 5px}
div#menu ol ol {list-style: lower-alpha; padding-left: 15px; margin-left: 15px}
div#menu ol ol ol {list-style: decimal; padding-left: 5px; margin-left: 5px}
h2 { color: #888888; border-top: 3px solid #4588ba; }
h3 { color: #666666; border-top: 2px solid #4588ba; }
h4 { color: #222288; border-top: 1px solid #4588ba; }
.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
.output { color: #000; background-color: beige; width: 100%; padding: 3px}
.error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px}
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
.keyword { color: #800080; background-color: inherit; }
.type { color: #008000; background-color: inherit; }
.function { color: #0000FF; background-color: inherit; }
.variable { color: #B8860B; background-color: inherit; }
.comment { color: #FF0000; background-color: inherit; }
.string { color: #BC8F8F; background-color: inherit; }
.attribute { color: #FF5000; background-color: inherit; }
.preprocessor { color: #FF00FF; background-color: inherit; }
.builtin { color: #FF00FF; background-color: inherit; }
.character { color: #0055AA; background-color: inherit; }
.syntaxerror { color: #FF0000; background-color: inherit; }
.diff-deleted { color: #5F2121; background-color: inherit; }
.diff-added { color: #215F21; background-color: inherit; }
span.paren1 { color: #AAAAAA; background-color: inherit; }
span.paren2 { color: #888888; background-color: inherit; }
span.paren3 { color: #666666; background-color: inherit; }
span.paren4 { color: #444444; background-color: inherit; }
span.paren5 { color: #222222; background-color: inherit; }
span.paren6 { color: #000000; background-color: inherit; }
</style>
</head><body><div id="menu"><ol><li><a href="#h4_(let-optionalsls((vardefault)...[rest])body...)">let-optionals</a></li><li><a href="#h4_(let-optionals*ls((vardefault)...[rest])body...)">let-optionals*</a></li><li><a href="#h4_(opt-lambda((vardefault)...[rest])body...)">opt-lambda</a></li><li><a href="#h4_(define-opt(name(vardefault)...[rest])body...)">define-opt</a></li><li><a href="#h4_(keyword-reflskey[default])">keyword-ref</a></li><li><a href="#h4_(keyword-ref*lskeydefault)">keyword-ref*</a></li><li><a href="#h4_(let-keywordsls((var[keyword]default)...[rest])body...)">let-keywords</a></li><li><a href="#h4_(let-keywords*ls((var[keyword]default)...[rest])body...)">let-keywords*</a></li></ol></div><div id="main"><div><a name="h1_(chibioptional)"></a><h1>(chibi optional)</h1></div><p>Syntax to support optional and named keyword arguments.
<code><span>let-optionals</span>[<span>*</span>]</code> is originally from SCSH, and
<code><span>let-keywords</span>[<span>*</span>]</code> derived from Gauche.<div><a name="h4_(let-optionalsls((vardefault)...[rest])body...)"></a><h4><code>(let-optionals ls ((var default) ... [rest]) body ...)</code></h4></div>
Binding construct similar to <code><span>let</span></code>. The <code>var</code>s are
bound to fresh locations holding values taken in order from the
list <code>ls</code>, <code>body</code> is evaluated in the resulting
environment, and the value(s) of the last expression of <code>body</code>
returned. If the length of <code>ls</code> is shorter than the number of
<code>var</code>s, then the remaining <code>var</code>s taken their values from
their corresponding <code>default</code>s, evaluated in an unspecified
order. Unused <code>default</code>s are not evaluated. If a final
<code>rest</code> var is specified, then it is bound to any remaining
elements of <code>ls</code> beyond the length of <code>ls</code>, otherwise any
extra values are unused.
Typically used on the dotted rest list at the start of a lambda,
<code><span>let-optionals</span></code> is more concise and more efficient than
<code><span>case-lambda</span></code> for simple optional argument uses.
<em>Example:</em>
<pre><code>(<span class="keyword">define</span> (<span class="function">copy-port</span> <span>.</span> <span>o</span>)
(<span class="keyword">let-optionals</span> <span>o</span> ((in (current-input-port))
(out (current-output-port))
(n-bytes #f))
(<span class="keyword">do</span> ((i <span>0</span> (+ <span>i</span> <span>1</span>))
(n (read-u8 <span>in</span>) (read-u8 <span>in</span>)))
((or (and <span>n-bytes</span> (>= <span>i</span> <span>n-bytes</span>))
(eof-object? <span>b</span>)))
(write-u8 <span>b</span> <span>out</span>)))</code></pre>
<em>Example:</em>
<div><pre><code>(<span class="keyword">let-optionals</span> '(0) ((a <span>10</span>) (b <span>11</span>) (c <span>12</span>))
(list <span>a</span> <span>b</span> <span>c</span>))</code></pre><div class="result"><code>=> (0 11 12)</code></div></div><div><a name="h4_(let-optionals*ls((vardefault)...[rest])body...)"></a><h4><code>(let-optionals* ls ((var default) ... [rest]) body ...)</code></h4></div>
<code><span>let*</span></code> equivalent to <code><span>let-optionals</span></code>. Any required
<code>default</code> values are evaluated in left-to-right order, with
all preceding <code>var</code>s in scope.
<div><a name="h4_(opt-lambda((vardefault)...[rest])body...)"></a><h4><code>(opt-lambda ((var default) ... [rest]) body ...)</code></h4></div>
Shorthand for
<pre><code>(<span class="keyword">lambda</span> (required <span>...</span> <span>.</span> <span>o</span>)
(<span class="keyword">let-optionals</span> <span>o</span> ((var <span>default</span>) <span>...</span> [<span>rest</span>])
<span>body</span> <span>...</span>))</code></pre><div><a name="h4_(define-opt(name(vardefault)...[rest])body...)"></a><h4><code>(define-opt (name (var default) ... [rest]) body ...)</code></h4></div>
Shorthand for
<pre><code>(<span class="keyword">define</span> <span class="function">name</span> (opt-lambda (var <span>default</span>) <span>...</span> [<span>rest</span>]) <span>body</span> <span>...</span>)</code></pre><div><a name="h4_(keyword-reflskey[default])"></a><h4><code>(keyword-ref ls key [default])</code></h4></div>
Search for the identifier <code>key</code> in the list <code>ls</code>, treating
it as a property list of the form <code>(key1 <span>val1</span> <span>key2</span> <span>val2</span>
<span>...</span>)</code>, and return the associated <code>val</code>. If not found, return
<code>default</code>, or <code>#f</code>.<div><a name="h4_(keyword-ref*lskeydefault)"></a><h4><code>(keyword-ref* ls key default)</code></h4></div>
Macro equivalent of <code><span>keyword-ref</span></code>, where <code>default</code> is
only evaluated if <code>key</code> is not found.<div><a name="h4_(let-keywordsls((var[keyword]default)...[rest])body...)"></a><h4><code>(let-keywords ls ((var [keyword] default) ... [rest]) body ...)</code></h4></div>
Analogous to <code><span>let-optionals</span></code>, except instead of binding the
<code>var</code>s by position they are bound by name, by searching in
<code>ls</code> with <code><span>keyword-ref*</span></code>. If an optional <code>keyword</code>
argument is provided it must be an identifier to use as the name,
otherwise <code>var</code> is used, appending a ":" (colon). If the name
is not found, <code>var</code> is bound to <code>default</code>, even if unused
names remain in <code>ls</code>.
If an optional trailing identifier <code>rest</code> is provided, it is
bound to the list of unused arguments not bound to any <code>var</code>.
Note R7RS does not have a disjoint keyword type or auto-quoting
syntax for keywords - they are simply identifiers. Thus when
passing keyword arguments they must be quoted (or otherwise
dynamically evaluated).
<em>Example:</em>
<div><pre><code>(<span class="keyword">define</span> (<span class="function">make-person</span> <span>.</span> <span>o</span>)
(<span class="keyword">let-keywords</span> <span>o</span> ((name <span class="string">"John Doe"</span>)
(age <span>0</span>)
(occupation <span>job:</span> '<span>unemployed</span>))
(vector <span>name</span> <span>age</span> <span>occupation</span>))<span class="syntaxerror">)</span>
(list (make-person)
(make-person '<span>name:</span> <span class="string">"Methuselah"</span> '<span>age:</span> <span>969</span>)
(make-person '<span>name:</span> <span class="string">"Dr. Who"</span> '<span>job:</span> '<span>time-lord</span> '<span>age:</span> <span>1500</span>))
</code></pre><div class="result"><code>=> (#("John Doe" 0 unemployed) #("Methuselah" 969 unemployed) #("Dr. Who" 1500 time-lord))</code></div></div>
<em>Example:</em>
<div><pre><code>(<span class="keyword">let-keywords</span> '(b: <span>2</span> <span>a:</span> <span>1</span> <span>other:</span> <span>9</span>)
((a <span>0</span>) (b <span>0</span>) (c <span>0</span>) <span>rest</span>)
(list <span>a</span> <span>b</span> <span>c</span> <span>rest</span>))
</code></pre><div class="result"><code>=> (1 2 0 (other: 9))</code></div></div><div><a name="h4_(let-keywords*ls((var[keyword]default)...[rest])body...)"></a><h4><code>(let-keywords* ls ((var [keyword] default) ... [rest]) body ...)</code></h4></div>
<code><span>let*</span></code> equivalent to <code><span>let-keywords*</span></code>. Any required
<code>default</code> values are evaluated in left-to-right order, with
all preceding <code>var</code>s in scope.
<em>Example:</em>
<div><pre><code>(<span class="keyword">let-keywords*</span> '(b: <span>5</span>)
((a <span>1</span>) (b (* <span>a</span> <span>2</span>)) (c (* <span>b</span> <span>3</span>)))
(list <span>a</span> <span>b</span> <span>c</span>))
</code></pre><div class="result"><code>=> (1 5 15)</code></div></div></p><div id="footer"></div></div></body></html>

227
snow/chibi/optional.scm Normal file
View File

@ -0,0 +1,227 @@
;;> Syntax to support optional and named keyword arguments.
;;> \scheme{let-optionals[*]} is originally from SCSH, and
;;> \scheme{let-keywords[*]} derived from Gauche.
;; Wrap bindings in temp variables to convert a let* definition to a
;; let definition.
(define-syntax let*-to-let
(syntax-rules ()
((let*-to-let letstar ls (vars ...) ((v . d) . rest) . body)
(let*-to-let letstar ls (vars ... (v tmp . d)) rest . body))
((let*-to-let letstar ls ((var tmp . d) ...) rest . body)
(letstar ls ((tmp . d) ... . rest)
(let ((var tmp) ...) . body)))))
;;> \macro{(let-optionals ls ((var default) ... [rest]) body ...)}
;;>
;;> Binding construct similar to \scheme{let}. The \var{var}s are
;;> bound to fresh locations holding values taken in order from the
;;> list \var{ls}, \var{body} is evaluated in the resulting
;;> environment, and the value(s) of the last expression of \var{body}
;;> returned. If the length of \var{ls} is shorter than the number of
;;> \var{var}s, then the remaining \var{var}s taken their values from
;;> their corresponding \var{default}s, evaluated in an unspecified
;;> order. Unused \var{default}s are not evaluated. If a final
;;> \var{rest} var is specified, then it is bound to any remaining
;;> elements of \var{ls} beyond the length of \var{ls}, otherwise any
;;> extra values are unused.
;;>
;;> Typically used on the dotted rest list at the start of a lambda,
;;> \scheme{let-optionals} is more concise and more efficient than
;;> \scheme{case-lambda} for simple optional argument uses.
;;>
;;> \emph{Example:}
;;> \schemeblock{
;;> (define (copy-port . o)
;;> (let-optionals o ((in (current-input-port))
;;> (out (current-output-port))
;;> (n-bytes #f))
;;> (do ((i 0 (+ i 1))
;;> (n (read-u8 in) (read-u8 in)))
;;> ((or (and n-bytes (>= i n-bytes))
;;> (eof-object? b)))
;;> (write-u8 b out)))}
;;>
;;> \emph{Example:}
;;> \example{
;;> (let-optionals '(0) ((a 10) (b 11) (c 12))
;;> (list a b c))}
(define-syntax let-optionals
(syntax-rules ()
((let-optionals ls ((var default) ... . rest) body ...)
(let*-to-let let-optionals* ls () ((var default) ... . rest) body ...))))
;;> \macro{(let-optionals* ls ((var default) ... [rest]) body ...)}
;;>
;;> \scheme{let*} equivalent to \scheme{let-optionals}. Any required
;;> \var{default} values are evaluated in left-to-right order, with
;;> all preceding \var{var}s in scope.
;;> \macro{(opt-lambda ((var default) ... [rest]) body ...)}
;;>
;;> Shorthand for
;;> \schemeblock{
;;> (lambda (required ... . o)
;;> (let-optionals o ((var default) ... [rest])
;;> body ...))}
(define-syntax opt-lambda
(syntax-rules ()
((opt-lambda vars . body)
(opt-lambda/aux () vars . body))))
(define-syntax opt-lambda/aux
(syntax-rules ()
((opt-lambda/aux (args ...) ((var . default) . vars) . body)
(lambda (args ... . o)
(let-optionals o ((var . default) . vars) . body)))
((opt-lambda/aux (args ...) (var . vars) . body)
(opt-lambda/aux (args ... var) vars . body))
((opt-lambda/aux (args ...) () . body)
(lambda (args ... . o)
. body))))
;;> \macro{(define-opt (name (var default) ... [rest]) body ...)}
;;>
;;> Shorthand for
;;> \schemeblock{
;;> (define name (opt-lambda (var default) ... [rest]) body ...)}
(define-syntax define-opt
(syntax-rules ()
((define-opt (name . vars) . body)
(define name (opt-lambda vars . body)))))
;;> \procedure{(keyword-ref ls key [default])}
;;>
;;> Search for the identifier \var{key} in the list \var{ls}, treating
;;> it as a property list of the form \scheme{(key1 val1 key2 val2
;;> ...)}, and return the associated \var{val}. If not found, return
;;> \var{default}, or \scheme{#f}.
(define (keyword-ref ls key . o)
(let lp ((ls ls))
(if (and (pair? ls) (pair? (cdr ls)))
(if (eq? key (car ls))
(cadr ls)
(lp (cddr ls)))
(and (pair? o) (car o)))))
;;> \macro{(keyword-ref* ls key default)}
;;>
;;> Macro equivalent of \scheme{keyword-ref}, where \var{default} is
;;> only evaluated if \var{key} is not found.
(define-syntax keyword-ref*
(syntax-rules ()
((keyword-ref* ls key default)
(cond ((memq key ls) => cadr) (else default)))))
(define (symbol->keyword sym)
(string->symbol (string-append (symbol->string sym) ":")))
(define-syntax let-key*-to-let
(syntax-rules ()
((let-key*-to-let ls (vars ...) ((v d) . rest) . body)
(let-key*-to-let ls (vars ... (v tmp ,(symbol->keyword 'v) d)) rest
. body))
((let-key*-to-let ls (vars ...) ((v k d) . rest) . body)
(let-key*-to-let ls (vars ... (v tmp k d)) rest . body))
((let-key*-to-let ls ((var tmp k d) ...) rest . body)
(let-keywords* ls ((tmp k d) ... . rest)
(let ((var tmp) ...) . body)))))
;;> \macro{(let-keywords ls ((var [keyword] default) ... [rest]) body ...)}
;;>
;;> Analogous to \scheme{let-optionals}, except instead of binding the
;;> \var{var}s by position they are bound by name, by searching in
;;> \var{ls} with \scheme{keyword-ref*}. If an optional \var{keyword}
;;> argument is provided it must be an identifier to use as the name,
;;> otherwise \var{var} is used, appending a ":" (colon). If the name
;;> is not found, \var{var} is bound to \var{default}, even if unused
;;> names remain in \var{ls}.
;;>
;;> If an optional trailing identifier \var{rest} is provided, it is
;;> bound to the list of unused arguments not bound to any \var{var}.
;;>
;;> Note R7RS does not have a disjoint keyword type or auto-quoting
;;> syntax for keywords - they are simply identifiers. Thus when
;;> passing keyword arguments they must be quoted (or otherwise
;;> dynamically evaluated).
;;>
;;> \emph{Example:}
;;> \example{
;;> (define (make-person . o)
;;> (let-keywords o ((name "John Doe")
;;> (age 0)
;;> (occupation job: 'unemployed))
;;> (vector name age occupation)))
;;>
;;> (list (make-person)
;;> (make-person 'name: "Methuselah" 'age: 969)
;;> (make-person 'name: "Dr. Who" 'job: 'time-lord 'age: 1500))
;;> }
;;>
;;> \emph{Example:}
;;> \example{
;;> (let-keywords '(b: 2 a: 1 other: 9)
;;> ((a 0) (b 0) (c 0) rest)
;;> (list a b c rest))
;;> }
(define-syntax let-keywords
(syntax-rules ()
((let-keywords ls vars . body)
(let-key*-to-let ls () vars . body))))
(define (remove-keywords ls keywords)
(let lp ((ls ls) (res '()))
(if (and (pair? ls) (pair? (cdr ls)))
(if (memq (car ls) keywords)
(lp (cddr ls) res)
(lp (cddr ls) (cons (cadr ls) (cons (car ls) res))))
(reverse res))))
(define-syntax remove-keywords*
(syntax-rules ()
((remove-keywords* opt-ls (keys ...) ((var key default) . rest))
(remove-keywords* opt-ls (keys ... key) rest))
((remove-keywords* opt-ls (keys ...) ((var default) . rest))
(remove-keywords* opt-ls (keys ... ,(symbol->keyword* 'var)) rest))
((remove-keywords* opt-ls (keys ...) ())
(remove-keywords opt-ls `(keys ...)))))
;;> \macro{(let-keywords* ls ((var [keyword] default) ... [rest]) body ...)}
;;>
;;> \scheme{let*} equivalent to \scheme{let-keywords*}. Any required
;;> \var{default} values are evaluated in left-to-right order, with
;;> all preceding \var{var}s in scope.
;;>
;;> \emph{Example:}
;;> \example{
;;> (let-keywords* '(b: 5)
;;> ((a 1) (b (* a 2)) (c (* b 3)))
;;> (list a b c))
;;> }
(define-syntax let-keywords*
(syntax-rules ()
((let-keywords* opt-ls () . body)
(begin . body))
((let-keywords* (op . args) vars . body)
(let ((tmp (op . args)))
(let-keywords* tmp vars . body)))
((let-keywords* opt-ls ((var) (vars . x) ...) . body)
(let-keywords* opt-ls ((var #f) (vars . x) ...) . body))
((let-keywords* opt-ls ((var default) (vars . x) ...) . body)
(let ((var (keyword-ref* opt-ls (symbol->keyword* 'var) default)))
(let-keywords* opt-ls ((vars . x) ...) . body)))
((let-keywords* opt-ls ((var key default) (vars . x) ...) . body)
(let ((var (keyword-ref* opt-ls `key default)))
(let-keywords* opt-ls ((vars . x) ...) . body)))
((let-keywords* opt-ls ((vars . x) ... tail) . body)
(let ((tail (remove-keywords* opt-ls () ((vars . x) ...))))
(let-keywords* opt-ls ((vars . x) ...) . body)))))

42
snow/chibi/optional.sld Normal file
View File

@ -0,0 +1,42 @@
(define-library (chibi optional)
(export let-optionals let-optionals* opt-lambda define-opt
let-keywords let-keywords* keyword-ref keyword-ref*)
(cond-expand
(chibi
(import (chibi))
(begin
(define-syntax symbol->keyword*
(er-macro-transformer
(lambda (expr rename compare)
(if (and (pair? (cdr expr)) (pair? (cadr expr))
(compare 'quote (car (cadr expr))))
`(,(rename 'quote)
,(string->symbol
(string-append
(symbol->string
(identifier->symbol (cadr (cadr expr)))) ":")))
`(string->symbol
(string-append (symbol->string ,(cadr expr)) ":"))))))))
(else
(import (scheme base))
(begin
(define-syntax let-optionals*
(syntax-rules ()
((let-optionals* opt-ls () . body)
(begin . body))
((let-optionals* (op . args) vars . body)
(let ((tmp (op . args)))
(let-optionals* tmp vars . body)))
((let-optionals* tmp ((var default) . rest) . body)
(let ((var (if (pair? tmp) (car tmp) default))
(tmp2 (if (pair? tmp) (cdr tmp) '())))
(let-optionals* tmp2 rest . body)))
((let-optionals* tmp tail . body)
(let ((tail tmp)) . body))))
(define-syntax symbol->keyword*
(syntax-rules ()
((symbol->keyword* sym)
(string->symbol (string-append (symbol->string sym) ":")))
)))))
(include "optional.scm"))

219
snow/chibi/term/ansi-test.sld Normal file
View File

@ -0,0 +1,219 @@
(define-library (chibi term ansi-test)
(export run-tests)
(import (scheme base)
(scheme write)
(chibi term ansi))
(begin
;; inline (chibi test) to avoid circular dependencies in snow
;; installations
(define-syntax test
(syntax-rules ()
((test expect expr)
(test 'expr expect expr))
((test name expect expr)
(guard (exn
(else
(display "!\nERROR: ")
(write name)
(newline)
(write exn)
(newline)))
(let* ((res expr)
(pass? (equal? expect expr)))
(display (if pass? "." "x"))
(cond
((not pass?)
(display "\nFAIL: ")
(write name)
(newline))))))))
(define-syntax test-assert
(syntax-rules ()
((test-assert expr) (test #t expr))))
(define-syntax test-error
(syntax-rules ()
((test-error expr)
(test-assert (guard (exn (else #t)) expr #f)))))
(define-syntax test-escape-procedure
(syntax-rules ()
((test-escape-procedure p s)
(begin
(test-assert (procedure? p))
;;(test-error (p #f))
(test s (p))))))
(define-syntax test-wrap-procedure
(syntax-rules ()
((test-wrap-procedure p s)
(begin
(test-assert (procedure? p))
;; (test-error (p))
;; (test-error (p #f))
;; (test-error (p "" #f))
(test (p "FOO")
"FOO"
(parameterize ((ansi-escapes-enabled? #f)) (p "FOO")))
(test (p "FOO")
s
(parameterize ((ansi-escapes-enabled? #t)) (p "FOO")))))))
(define (test-begin name)
(display name))
(define (test-end)
(newline))
(define (run-tests)
(test-begin "term.ansi")
(test-assert (procedure? ansi-escapes-enabled?))
(test-assert
(let ((tag (cons #t #t)))
(eqv? tag
(parameterize ((ansi-escapes-enabled? tag))
(ansi-escapes-enabled?)))))
(test-escape-procedure black-escape "\x1b;[30m")
(test-escape-procedure red-escape "\x1b;[31m")
(test-escape-procedure green-escape "\x1b;[32m")
(test-escape-procedure yellow-escape "\x1b;[33m")
(test-escape-procedure blue-escape "\x1b;[34m")
(test-escape-procedure cyan-escape "\x1b;[36m")
(test-escape-procedure magenta-escape "\x1b;[35m")
(test-escape-procedure white-escape "\x1b;[37m")
(test-escape-procedure reset-color-escape "\x1b;[39m")
(test-assert (procedure? rgb-escape))
(test-error (rgb-escape))
(test-error (rgb-escape 0))
(test-error (rgb-escape 0 0))
(test-error (rgb-escape 0 0 0 0))
(test-error (rgb-escape 0.0 0 0))
(test-error (rgb-escape 0 0.0 0))
(test-error (rgb-escape 0 0 0.0))
(test-error (rgb-escape -1 0 0))
(test-error (rgb-escape 0 -1 0))
(test-error (rgb-escape 0 0 -1))
(test-error (rgb-escape 6 0 0))
(test-error (rgb-escape 0 6 0))
(test-error (rgb-escape 0 0 6))
(test-escape-procedure (lambda () (rgb-escape 0 0 0)) "\x1B;[38;5;16m")
(test-escape-procedure (lambda () (rgb-escape 5 0 0)) "\x1B;[38;5;196m")
(test-escape-procedure (lambda () (rgb-escape 0 5 0)) "\x1B;[38;5;46m")
(test-escape-procedure (lambda () (rgb-escape 0 0 5)) "\x1B;[38;5;21m")
(test-escape-procedure (lambda () (rgb-escape 1 1 1)) "\x1B;[38;5;59m")
(test-escape-procedure (lambda () (rgb-escape 2 2 2)) "\x1B;[38;5;102m")
(test-escape-procedure (lambda () (rgb-escape 3 3 3)) "\x1B;[38;5;145m")
(test-escape-procedure (lambda () (rgb-escape 4 4 4)) "\x1B;[38;5;188m")
(test-escape-procedure (lambda () (rgb-escape 5 5 5)) "\x1B;[38;5;231m")
(test-escape-procedure (lambda () (rgb-escape 1 3 5)) "\x1B;[38;5;75m")
(test-escape-procedure (lambda () (rgb-escape 5 1 3)) "\x1B;[38;5;205m")
(test-escape-procedure (lambda () (rgb-escape 3 5 1)) "\x1B;[38;5;155m")
(test-assert (procedure? gray-escape))
(test-error (gray-escape))
(test-error (gray-escape 0 0))
(test-error (gray-escape 0.0))
(test-error (gray-escape -1))
(test-error (gray-escape 24))
(test-escape-procedure (lambda () (gray-escape 0)) "\x1B;[38;5;232m")
(test-escape-procedure (lambda () (gray-escape 23)) "\x1B;[38;5;255m")
(test-escape-procedure (lambda () (gray-escape 12)) "\x1B;[38;5;244m")
(test-wrap-procedure black "\x1b;[30mFOO\x1b;[39m")
(test-wrap-procedure red "\x1b;[31mFOO\x1b;[39m")
(test-wrap-procedure green "\x1b;[32mFOO\x1b;[39m")
(test-wrap-procedure yellow "\x1b;[33mFOO\x1b;[39m")
(test-wrap-procedure blue "\x1b;[34mFOO\x1b;[39m")
(test-wrap-procedure cyan "\x1b;[36mFOO\x1b;[39m")
(test-wrap-procedure magenta "\x1b;[35mFOO\x1b;[39m")
(test-wrap-procedure white "\x1b;[37mFOO\x1b;[39m")
(test-wrap-procedure (rgb 0 0 0) "\x1B;[38;5;16mFOO\x1b;[39m")
(test-wrap-procedure (rgb 5 5 5) "\x1B;[38;5;231mFOO\x1b;[39m")
(test-wrap-procedure (gray 0) "\x1B;[38;5;232mFOO\x1b;[39m")
(test-wrap-procedure (gray 23) "\x1B;[38;5;255mFOO\x1b;[39m")
(test-wrap-procedure (rgb24 #xA6 #x7B #x5B) "\x1B;[38;2;166;123;91mFOO\x1b;[39m")
(test-escape-procedure black-background-escape "\x1b;[40m")
(test-escape-procedure red-background-escape "\x1b;[41m")
(test-escape-procedure green-background-escape "\x1b;[42m")
(test-escape-procedure yellow-background-escape "\x1b;[43m")
(test-escape-procedure blue-background-escape "\x1b;[44m")
(test-escape-procedure cyan-background-escape "\x1b;[46m")
(test-escape-procedure magenta-background-escape "\x1b;[45m")
(test-escape-procedure white-background-escape "\x1b;[47m")
(test-escape-procedure reset-background-color-escape "\x1b;[49m")
(test-assert (procedure? rgb-background-escape))
(test-error (rgb-background-escape))
(test-error (rgb-background-escape 0))
(test-error (rgb-background-escape 0 0))
(test-error (rgb-background-escape 0 0 0 0))
(test-error (rgb-background-escape 0.0 0 0))
(test-error (rgb-background-escape 0 0.0 0))
(test-error (rgb-background-escape 0 0 0.0))
(test-error (rgb-background-escape -1 0 0))
(test-error (rgb-background-escape 0 -1 0))
(test-error (rgb-background-escape 0 0 -1))
(test-error (rgb-background-escape 6 0 0))
(test-error (rgb-background-escape 0 6 0))
(test-error (rgb-background-escape 0 0 6))
(test-escape-procedure
(lambda () (rgb-background-escape 0 0 0)) "\x1B;[48;5;16m")
(test-escape-procedure
(lambda () (rgb-background-escape 5 0 0)) "\x1B;[48;5;196m")
(test-escape-procedure
(lambda () (rgb-background-escape 0 5 0)) "\x1B;[48;5;46m")
(test-escape-procedure
(lambda () (rgb-background-escape 0 0 5)) "\x1B;[48;5;21m")
(test-escape-procedure
(lambda () (rgb-background-escape 1 1 1)) "\x1B;[48;5;59m")
(test-escape-procedure
(lambda () (rgb-background-escape 2 2 2)) "\x1B;[48;5;102m")
(test-escape-procedure
(lambda () (rgb-background-escape 3 3 3)) "\x1B;[48;5;145m")
(test-escape-procedure
(lambda () (rgb-background-escape 4 4 4)) "\x1B;[48;5;188m")
(test-escape-procedure
(lambda () (rgb-background-escape 5 5 5)) "\x1B;[48;5;231m")
(test-escape-procedure
(lambda () (rgb-background-escape 1 3 5)) "\x1B;[48;5;75m")
(test-escape-procedure
(lambda () (rgb-background-escape 5 1 3)) "\x1B;[48;5;205m")
(test-escape-procedure
(lambda () (rgb-background-escape 3 5 1)) "\x1B;[48;5;155m")
(test-assert (procedure? gray-background-escape))
(test-error (gray-background-escape))
(test-error (gray-background-escape 0 0))
(test-error (gray-background-escape 0.0))
(test-error (gray-background-escape -1))
(test-error (gray-background-escape 24))
(test-escape-procedure
(lambda () (gray-background-escape 0)) "\x1B;[48;5;232m")
(test-escape-procedure
(lambda () (gray-background-escape 23)) "\x1B;[48;5;255m")
(test-escape-procedure
(lambda () (gray-background-escape 12)) "\x1B;[48;5;244m")
(test-wrap-procedure black-background "\x1b;[40mFOO\x1b;[49m")
(test-wrap-procedure red-background "\x1b;[41mFOO\x1b;[49m")
(test-wrap-procedure green-background "\x1b;[42mFOO\x1b;[49m")
(test-wrap-procedure yellow-background "\x1b;[43mFOO\x1b;[49m")
(test-wrap-procedure blue-background "\x1b;[44mFOO\x1b;[49m")
(test-wrap-procedure cyan-background "\x1b;[46mFOO\x1b;[49m")
(test-wrap-procedure magenta-background "\x1b;[45mFOO\x1b;[49m")
(test-wrap-procedure white-background "\x1b;[47mFOO\x1b;[49m")
(test-wrap-procedure (rgb-background 0 0 0) "\x1B;[48;5;16mFOO\x1b;[49m")
(test-wrap-procedure (rgb-background 5 5 5) "\x1B;[48;5;231mFOO\x1b;[49m")
(test-wrap-procedure (gray-background 0) "\x1B;[48;5;232mFOO\x1b;[49m")
(test-wrap-procedure (gray-background 23) "\x1B;[48;5;255mFOO\x1b;[49m")
(test-escape-procedure bold-escape "\x1b;[1m")
(test-escape-procedure reset-bold-escape "\x1b;[22m")
(test-wrap-procedure bold "\x1b;[1mFOO\x1b;[22m")
(test-escape-procedure underline-escape "\x1b;[4m")
(test-escape-procedure reset-underline-escape "\x1b;[24m")
(test-wrap-procedure underline "\x1b;[4mFOO\x1b;[24m")
(test-escape-procedure negative-escape "\x1b;[7m")
(test-escape-procedure reset-negative-escape "\x1b;[27m")
(test-wrap-procedure negative "\x1b;[7mFOO\x1b;[27m")
(test-end))))

206
snow/chibi/term/ansi.html Normal file
View File

@ -0,0 +1,206 @@
<html><head>
<style type="text/css">
body {color: #000; background-color: #FFF}
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 190px; height: 100%}
div#main {position: absolute; top: 0; left: 200px; width: 540px; height: 100%}
div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: 0px; font-size: smaller;}
div#footer {padding-bottom: 50px}
.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
.output { color: #000; background-color: beige; width: 100%; padding: 3px}
.error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px}
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
.keyword { color: #800080; background-color: inherit; }
.type { color: #008000; background-color: inherit; }
.function { color: #0000FF; background-color: inherit; }
.variable { color: #B8860B; background-color: inherit; }
.comment { color: #FF0000; background-color: inherit; }
.string { color: #BC8F8F; background-color: inherit; }
.attribute { color: #FF5000; background-color: inherit; }
.preprocessor { color: #FF00FF; background-color: inherit; }
.builtin { color: #FF00FF; background-color: inherit; }
.character { color: #0055AA; background-color: inherit; }
.syntaxerror { color: #FF0000; background-color: inherit; }
.diff-deleted { color: #5F2121; background-color: inherit; }
.diff-added { color: #215F21; background-color: inherit; }
span.paren1 { color: #AAAAAA; background-color: inherit; }
span.paren2 { color: #888888; background-color: inherit; }
span.paren3 { color: #666666; background-color: inherit; }
span.paren4 { color: #444444; background-color: inherit; }
span.paren5 { color: #222222; background-color: inherit; }
span.paren6 { color: #000000; background-color: inherit; }
</style>
</head><body><div id="menu"><ol><li><a href="#h2_Library">Library</a><ol><li><a href="#h3_black-escape">black-escape</a></li><li><a href="#h3_red-escape">red-escape</a></li><li><a href="#h3_green-escape">green-escape</a></li><li><a href="#h3_yellow-escape">yellow-escape</a></li><li><a href="#h3_blue-escape">blue-escape</a></li><li><a href="#h3_magenta-escape">magenta-escape</a></li><li><a href="#h3_cyan-escape">cyan-escape</a></li><li><a href="#h3_white-escape">white-escape</a></li><li><a href="#h3_rgb-escape">rgb-escape</a></li><li><a href="#h3_gray-escape">gray-escape</a></li><li><a href="#h3_rgb24-escape">rgb24-escape</a></li><li><a href="#h3_reset-color-escape">reset-color-escape</a></li><li><a href="#h3_black">black</a></li><li><a href="#h3_red">red</a></li><li><a href="#h3_green">green</a></li><li><a href="#h3_yellow">yellow</a></li><li><a href="#h3_blue">blue</a></li><li><a href="#h3_magenta">magenta</a></li><li><a href="#h3_cyan">cyan</a></li><li><a href="#h3_white">white</a></li><li><a href="#h3_rgb">rgb</a></li><li><a href="#h3_gray">gray</a></li><li><a href="#h3_rgb24">rgb24</a></li><li><a href="#h3_black-background-escape">black-background-escape</a></li><li><a href="#h3_red-background-escape">red-background-escape</a></li><li><a href="#h3_green-background-escape">green-background-escape</a></li><li><a href="#h3_yellow-background-escape">yellow-background-escape</a></li><li><a href="#h3_blue-background-escape">blue-background-escape</a></li><li><a href="#h3_magenta-background-escape">magenta-background-escape</a></li><li><a href="#h3_cyan-background-escape">cyan-background-escape</a></li><li><a href="#h3_white-background-escape">white-background-escape</a></li><li><a href="#h3_rgb-background-escape">rgb-background-escape</a></li><li><a href="#h3_gray-background-escape">gray-background-escape</a></li><li><a href="#h3_rgb24-background-escape">rgb24-background-escape</a></li><li><a href="#h3_(reset-background-color-escape)">reset-background-color-escape</a></li><li><a href="#h3_black-background">black-background</a></li><li><a href="#h3_red-background">red-background</a></li><li><a href="#h3_green-background">green-background</a></li><li><a href="#h3_yellow-background">yellow-background</a></li><li><a href="#h3_blue-background">blue-background</a></li><li><a href="#h3_magenta-background">magenta-background</a></li><li><a href="#h3_cyan-background">cyan-background</a></li><li><a href="#h3_white-background">white-background</a></li><li><a href="#h3_rgb-background">rgb-background</a></li><li><a href="#h3_gray-background">gray-background</a></li><li><a href="#h3_rgb24-background">rgb24-background</a></li><li><a href="#h3_bold-escape">bold-escape</a></li><li><a href="#h3_reset-bold-escape">reset-bold-escape</a></li><li><a href="#h3_bold">bold</a></li><li><a href="#h3_underline-escape">underline-escape</a></li><li><a href="#h3_reset-underline-escape">reset-underline-escape</a></li><li><a href="#h3_underline">underline</a></li><li><a href="#h3_italic-escape">italic-escape</a></li><li><a href="#h3_reset-italic-escape">reset-italic-escape</a></li><li><a href="#h3_italic">italic</a></li><li><a href="#h3_strikethrough-escape">strikethrough-escape</a></li><li><a href="#h3_reset-strikethrough-escape">reset-strikethrough-escape</a></li><li><a href="#h3_strikethrough">strikethrough</a></li><li><a href="#h3_negative-escape">negative-escape</a></li><li><a href="#h3_reset-negative-escape">reset-negative-escape</a></li><li><a href="#h3_negative">negative</a></li><li><a href="#h3_ansi-escapes-enabled?">ansi-escapes-enabled?</a></li></ol></li><li><a href="#h2_Notes">Notes</a></li></ol></div><div id="main"><div><a name="h1_(chibitermansi)"></a><h1>(chibi term ansi)</h1></div><p>A library to use ANSI escape codes to format text and background
color, font weigh, and underlining.<div><a name="h2_Library"></a><h2>Library</h2></div><div><a name="h3_black-escape"></a><h3><code>(black-escape)</code></h3></div><div><a name="h3_red-escape"></a><h3><code>(red-escape)</code></h3></div><div><a name="h3_green-escape"></a><h3><code>(green-escape)</code></h3></div><div><a name="h3_yellow-escape"></a><h3><code>(yellow-escape)</code></h3></div><div><a name="h3_blue-escape"></a><h3><code>(blue-escape)</code></h3></div><div><a name="h3_magenta-escape"></a><h3><code>(magenta-escape)</code></h3></div><div><a name="h3_cyan-escape"></a><h3><code>(cyan-escape)</code></h3></div><div><a name="h3_white-escape"></a><h3><code>(white-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select the
specified text color.<div><a name="h3_rgb-escape"></a><h3><code>(rgb-escape red-level green-level blue-level)</code></h3></div>Return a string consisting of an ANSI escape code to select the
text color specified by the <code>red-level</code>, <code>green-level</code>,
and <code>blue-level</code> arguments, each of which must be an exact
integer in the range [0, 5].
The caller is resonsible for verifying that the terminal supports
256 colors.<div><a name="h3_gray-escape"></a><h3><code>(gray-escape gray-level)</code></h3></div>Return a string consisting of an ANSI escape code to select the
text color specified by the <code>gray-level</code> argument, which must
be an exact integer in the range [0, 23].
The caller is resonsible for verifying that the terminal supports
256 colors.<div><a name="h3_rgb24-escape"></a><h3><code>(rgb24-escape red-level green-level blue-level)</code></h3></div>The true-color equivalent of <code><span>rgb-escape</span></code>. Return a string
consisting of an ANSI escape code to select the text color
specified by the <code>red-level</code>, <code>green-level</code>, and
<code>blue-level</code> arguments, each of which must be an exact integer
in the range [0, 255].<div><a name="h3_reset-color-escape"></a><h3><code>(reset-color-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select the
default text color.<div><a name="h3_black"></a><h3><code>(black str)</code></h3></div><div><a name="h3_red"></a><h3><code>(red str)</code></h3></div><div><a name="h3_green"></a><h3><code>(green str)</code></h3></div><div><a name="h3_yellow"></a><h3><code>(yellow str)</code></h3></div><div><a name="h3_blue"></a><h3><code>(blue str)</code></h3></div><div><a name="h3_magenta"></a><h3><code>(magenta str)</code></h3></div><div><a name="h3_cyan"></a><h3><code>(cyan str)</code></h3></div><div><a name="h3_white"></a><h3><code>(white str)</code></h3></div>If ANSI escapes are enabled, return a string consisting of the
string <code>str</code> with a prefix that selects specified text color
and a suffix that selects the default text color.
If ANSI escapes are not enabled, return <code>str</code>.<div><a name="h3_rgb"></a><h3><code>(rgb red-level green-level blue-level)</code></h3></div>Returns a procedure which takes a single argument, a string, and
which when called behaves as follows.
If ANSI escapes are enabled, the procedure returns a string
consisting of its argument with a prefix that selects specified
text color (obtained by calling the <code><span>rgb-escape</span></code> procedure
with the values of the <code>red-level</code>, <code>green-level</code>, and
<code>blue-level</code> arguments) and a suffix that selects the default
text color.
If ANSI escapes are not enabled, the procedure returns its argument.
The caller is resonsible for verifying that the terminal supports
256 colors.<div><a name="h3_gray"></a><h3><code>(gray gray-level)</code></h3></div>Returns a procedure which takes a single argument, a string, and
which when called behaves as follows.
If ANSI escapes are enabled, the procedure returns a string
consisting of its argument with a prefix that selects specified
text color (obtained by calling the <code><span>gray-escape</span></code> procedure
with the values of the <code>gray-level</code> argument) and a suffix
that selects the default text color.
If ANSI escapes are not enabled, the procedure returns its argument.
The caller is resonsible for verifying that the terminal supports
256 colors.<div><a name="h3_rgb24"></a><h3><code>(rgb24 red-level green-level blue-level)</code></h3></div>The true-color equivalent of <code><span>rbg</span></code>, extending the ranges
to [0, 255].<div><a name="h3_black-background-escape"></a><h3><code>(black-background-escape)</code></h3></div><div><a name="h3_red-background-escape"></a><h3><code>(red-background-escape)</code></h3></div><div><a name="h3_green-background-escape"></a><h3><code>(green-background-escape)</code></h3></div><div><a name="h3_yellow-background-escape"></a><h3><code>(yellow-background-escape)</code></h3></div><div><a name="h3_blue-background-escape"></a><h3><code>(blue-background-escape)</code></h3></div><div><a name="h3_magenta-background-escape"></a><h3><code>(magenta-background-escape)</code></h3></div><div><a name="h3_cyan-background-escape"></a><h3><code>(cyan-background-escape)</code></h3></div><div><a name="h3_white-background-escape"></a><h3><code>(white-background-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select the
specified background color.<div><a name="h3_rgb-background-escape"></a><h3><code>(rgb-background-escape red-level green-level blue-level)</code></h3></div>Return a string consisting of an ANSI escape code to select the
background color specified by the <code>red-level</code>, <code>green-level</code>,
and <code>blue-level</code> arguments, each of which must be an exact
integer in the range [0, 5].
The caller is resonsible for verifying that the terminal supports
256 colors.<div><a name="h3_gray-background-escape"></a><h3><code>(gray-background-escape gray-level)</code></h3></div>Return a string consisting of an ANSI escape code to select the
background color specified by the <code>gray-level</code> argument, which
must be an exact integer in the range [0, 23].
The caller is resonsible for verifying that the terminal supports
256 colors.<div><a name="h3_rgb24-background-escape"></a><h3><code>(rgb24-background-escape red-level green-level blue-level)</code></h3></div>The true-color equivalent of <code><span>rgb-background-escape</span></code>.
Return a string consisting of an ANSI escape code to select the
text color specified by the <code>red-level</code>, <code>green-level</code>,
and <code>blue-level</code> arguments, each of which must be an exact
integer in the range [0, 255].<div><a name="h3_(reset-background-color-escape)"></a><h3><code>(reset-background-color-escape)</code></h3></div>
Return a string consisting of an ANSI escape code to select the
default background color.<div><a name="h3_black-background"></a><h3><code>(black-background str)</code></h3></div><div><a name="h3_red-background"></a><h3><code>(red-background str)</code></h3></div><div><a name="h3_green-background"></a><h3><code>(green-background str)</code></h3></div><div><a name="h3_yellow-background"></a><h3><code>(yellow-background str)</code></h3></div><div><a name="h3_blue-background"></a><h3><code>(blue-background str)</code></h3></div><div><a name="h3_magenta-background"></a><h3><code>(magenta-background str)</code></h3></div><div><a name="h3_cyan-background"></a><h3><code>(cyan-background str)</code></h3></div><div><a name="h3_white-background"></a><h3><code>(white-background str)</code></h3></div>If ANSI escapes are enabled, return a string consisting of the
string <code>str</code> with a prefix that selects specified background
color and a suffix that selects the default background color.
If ANSI escapes are not enabled, return <code>str</code>.<div><a name="h3_rgb-background"></a><h3><code>(rgb-background red-level green-level blue-level)</code></h3></div>Returns a procedure which takes a single argument, a string, and
which when called behaves as follows.
If ANSI escapes are enabled, the procedure returns a string
consisting of its argument with a prefix that selects specified
background color (obtained by calling the <code><span>rgb-background-escape</span></code>
procedure with the values of the <code>red-level</code>, <code>green-level</code>,
and <code>blue-level</code> arguments) and a suffix that selects the
default background color.
If ANSI escapes are not enabled, the procedure returns its argument.
The caller is resonsible for verifying that the terminal supports
256 colors.<div><a name="h3_gray-background"></a><h3><code>(gray-background gray-level)</code></h3></div>Returns a procedure which takes a single argument, a string, and
which when called behaves as follows.
If ANSI escapes are enabled, the procedure returns a string
consisting of its argument with a prefix that selects specified
background color (obtained by calling the <code><span>gray-background-escape</span></code>
procedure with the values of the <code>gray-level</code> argument) and a
suffix that selects the default background color.
If ANSI escapes are not enabled, the procedure returns its argument.
The caller is resonsible for verifying that the terminal supports
256 colors.<div><a name="h3_rgb24-background"></a><h3><code>(rgb24-background red-level green-level blue-level)</code></h3></div>The true-color equivalent of <code><span>rbg-background</span></code>, extending
the ranges to [0, 255].<div><a name="h3_bold-escape"></a><h3><code>(bold-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select bold
style.<div><a name="h3_reset-bold-escape"></a><h3><code>(reset-bold-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select non-bold
style.<div><a name="h3_bold"></a><h3><code>(bold str)</code></h3></div>If ANSI escapes are enabled, return a string consisting of the
string <code>str</code> with a prefix that selects bold style and a suffix
that selects non-bold style.
If ANSI escapes are not enabled, return <code>str</code>.<div><a name="h3_underline-escape"></a><h3><code>(underline-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select
underlined style.<div><a name="h3_reset-underline-escape"></a><h3><code>(reset-underline-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select
non-underlined style.<div><a name="h3_underline"></a><h3><code>(underline str)</code></h3></div>If ANSI escapes are enabled, return a string consisting of the
string <code>str</code> with a prefix that selects underlined style and
a suffix that selects non-underlined style.
If ANSI escapes are not enabled, return <code>str</code>.<div><a name="h3_italic-escape"></a><h3><code>(italic-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select
italic style.<div><a name="h3_reset-italic-escape"></a><h3><code>(reset-italic-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select
non-italic style.<div><a name="h3_italic"></a><h3><code>(italic str)</code></h3></div>Returns <code>str</code> optionally wrapped in italic escapes.<div><a name="h3_strikethrough-escape"></a><h3><code>(strikethrough-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select
strikethrough style.<div><a name="h3_reset-strikethrough-escape"></a><h3><code>(reset-strikethrough-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select
non-strikethrough style.<div><a name="h3_strikethrough"></a><h3><code>(strikethrough str)</code></h3></div>Returns <code>str</code> optionally wrapped in strikethrough escapes.<div><a name="h3_negative-escape"></a><h3><code>(negative-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select negative
style (text in the background color and background in the text
color).<div><a name="h3_reset-negative-escape"></a><h3><code>(reset-negative-escape)</code></h3></div>Return a string consisting of an ANSI escape code to select positive
style (text in the text color and background in the background
color).<div><a name="h3_negative"></a><h3><code>(negative str)</code></h3></div>If ANSI escapes are enabled, return a string consisting of the
string <code>str</code> with a prefix that selects negative style (text
in the background color and background in the text color) and a
suffix that selects positive style (text in the text color and
background in the background color).
If ANSI escapes are not enabled, return <code>str</code>.<div><a name="h3_ansi-escapes-enabled?"></a><h3><code>ansi-escapes-enabled?</code></h3></div>A parameter object that determines whether ANSI escapes are enabled
in some of the preceding procedures. They are disabled if
<code>(ansi-escapes-enabled?)</code> returns <code>#f</code>, and otherwise
they are enabled.
The initial value returned by <code>(ansi-escapes-enabled?)</code> is
determined by the environment.
If the environment variable <code><span>ANSI_ESCAPES_ENABLED</span></code> is set,
its value determines the initial value returned by
<code>(ansi-escapes-enabled?)</code>. If the value of
<code><span>ANSI_ESCAPES_ENABLED</span></code> is <code><span class="string">"0"</span></code>, the initial value
is <code>#f</code>, otherwise the initial value is <code>#t</code>.
If the environment variable <code><span>ANSI_ESCAPES_ENABLED</span></code> is not
set, but the environment variable <code><span>TERM</span></code> is set, the value
of the latter determines the initial value returned by
<code>(ansi-escapes-enabled?)</code>. If the value of <code><span>TERM</span></code>
is <code><span class="string">"xterm"</span></code>, <code><span class="string">"xterm-color"</span></code>, <code><span class="string">"xterm-256color"</span></code>,
<code><span class="string">"rxvt"</span></code>, <code><span class="string">"rxvt-unicode-256color"</span></code>, <code><span class="string">"kterm"</span></code>,
<code><span class="string">"linux"</span></code>, <code><span class="string">"screen"</span></code>, <code><span class="string">"screen-256color"</span></code>,
or <code><span class="string">"vt100"</span></code>, the initial value is <code>#t</code>, otherwise
the initial value is <code>#f</code>.
If neither of the environment variables <code><span>ANSI_ESCAPES_ENABLED</span></code>
and <code><span>TERM</span></code> are set, the initial value returned by
<code>(ansi-escapes-enabled?)</code> is <code>#f</code>.<div><a name="h2_Notes"></a><h2>Notes</h2></div>
It is important to remember that the formatting procedures apply
a prefix to set a particular graphics parameter and a suffix to
reset the parameter to its default value. This can lead to surprises.
For example, on an ANSI terminal, one might mistakenly expect the
following to display GREEN in green text and then RED in red text:
<pre><code>(display (red (string-append (green <span class="string">"GREEN"</span>) <span class="string">"RED"</span>)))</code></pre>
However, it will actually display GREEN in green text and then RED
in the default text color. This is a limitation of ANSI control
codes; graphics attributes are not saved to and restored from a
stack, but instead are simply set. One way to display GREEN in
green text and then RED in red text is:
<pre><code>(display (string-append (green <span class="string">"GREEN"</span>) (red <span class="string">"RED"</span>)))</code></pre>
On the other hand, text color, background color, font weight (bold
or default), underline (on or off), image (positive or negative)
are orthogonal. So, for example, on an ANSI terminal the following
should display GREEN in green text and then RED in red text, with
both in bold and GREEN underlined.
<pre><code>(display (bold (string-append (underline (green <span class="string">"GREEN"</span>)) (red <span class="string">"RED"</span>))))</code></pre>
</p><div id="footer"></div></div></body></html>

524
snow/chibi/term/ansi.scm Normal file
View File

@ -0,0 +1,524 @@
;; Copyright (c) 2010-2014 Alex Shinn. All rights reserved. BSD-style
;; license: http://synthcode.com/license.txt
;;> A library to use ANSI escape codes to format text and background
;;> color, font weigh, and underlining.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-simple-escape-procedure parameter)
(let ((code (string-append "\x1B;[" (number->string parameter) "m")))
(lambda () code)))
(define (make-wrap-procedure start-escape end-escape)
(lambda (str)
(if (not (string? str))
(error "argument must be a string" str))
(if (ansi-escapes-enabled?)
(string-append start-escape str end-escape)
str)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Some definitions are wrapped in begin in order to avoid Scribble
;; generating duplicate signatures.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> \section{Library}
(define black-escape
(make-simple-escape-procedure 30))
(define red-escape
(make-simple-escape-procedure 31))
(define green-escape
(make-simple-escape-procedure 32))
(define yellow-escape
(make-simple-escape-procedure 33))
(define blue-escape
(make-simple-escape-procedure 34))
(define magenta-escape
(make-simple-escape-procedure 35))
(define cyan-escape
(make-simple-escape-procedure 36))
(define white-escape
(make-simple-escape-procedure 37))
;;> Return a string consisting of an ANSI escape code to select the
;;> specified text color.
;;/
;;> Return a string consisting of an ANSI escape code to select the
;;> text color specified by the \var{red-level}, \var{green-level},
;;> and \var{blue-level} arguments, each of which must be an exact
;;> integer in the range [0, 5].
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (rgb-escape red-level green-level blue-level)
(when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 5)))
(error "invalid green-level value" green-level))
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[38;5;"
(number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
"m"))
;;> Return a string consisting of an ANSI escape code to select the
;;> text color specified by the \var{gray-level} argument, which must
;;> be an exact integer in the range [0, 23].
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (gray-escape gray-level)
(when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
(error "invalid gray-level value" gray-level))
(string-append "\x1B;[38;5;"
(number->string (+ gray-level 232))
"m"))
;;> The true-color equivalent of \scheme{rgb-escape}. Return a string
;;> consisting of an ANSI escape code to select the text color
;;> specified by the \var{red-level}, \var{green-level}, and
;;> \var{blue-level} arguments, each of which must be an exact integer
;;> in the range [0, 255].
(define (rgb24-escape red-level green-level blue-level)
(when (not (and (exact-integer? red-level) (<= 0 red-level 255)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 255)))
(error "invalid green-level value" green-level))
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 255)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[38;2;"
(number->string red-level) ";"
(number->string green-level) ";"
(number->string blue-level)
"m"))
;;> Return a string consisting of an ANSI escape code to select the
;;> default text color.
(define reset-color-escape
(make-simple-escape-procedure 39))
(define black
(make-wrap-procedure (black-escape)
(reset-color-escape)))
(define red
(make-wrap-procedure (red-escape)
(reset-color-escape)))
(define green
(make-wrap-procedure (green-escape)
(reset-color-escape)))
(define yellow
(make-wrap-procedure (yellow-escape)
(reset-color-escape)))
(define blue
(make-wrap-procedure (blue-escape)
(reset-color-escape)))
(define magenta
(make-wrap-procedure (magenta-escape)
(reset-color-escape)))
(define cyan
(make-wrap-procedure (cyan-escape)
(reset-color-escape)))
(define white
(make-wrap-procedure (white-escape)
(reset-color-escape)))
;;> If ANSI escapes are enabled, return a string consisting of the
;;> string \var{str} with a prefix that selects specified text color
;;> and a suffix that selects the default text color.
;;>
;;> If ANSI escapes are not enabled, return \var{str}.
;;/
;;> Returns a procedure which takes a single argument, a string, and
;;> which when called behaves as follows.
;;>
;;> If ANSI escapes are enabled, the procedure returns a string
;;> consisting of its argument with a prefix that selects specified
;;> text color (obtained by calling the \scheme{rgb-escape} procedure
;;> with the values of the \var{red-level}, \var{green-level}, and
;;> \var{blue-level} arguments) and a suffix that selects the default
;;> text color.
;;>
;;> If ANSI escapes are not enabled, the procedure returns its argument.
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (rgb red-level green-level blue-level)
(make-wrap-procedure (rgb-escape red-level green-level blue-level)
(reset-color-escape)))
;;> Returns a procedure which takes a single argument, a string, and
;;> which when called behaves as follows.
;;>
;;> If ANSI escapes are enabled, the procedure returns a string
;;> consisting of its argument with a prefix that selects specified
;;> text color (obtained by calling the \scheme{gray-escape} procedure
;;> with the values of the \var{gray-level} argument) and a suffix
;;> that selects the default text color.
;;>
;;> If ANSI escapes are not enabled, the procedure returns its argument.
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (gray gray-level)
(make-wrap-procedure (gray-escape gray-level)
(reset-color-escape)))
;;> The true-color equivalent of \scheme{rbg}, extending the ranges
;;> to [0, 255].
(define (rgb24 red-level green-level blue-level)
(make-wrap-procedure (rgb24-escape red-level green-level blue-level)
(reset-color-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define black-background-escape
(make-simple-escape-procedure 40))
(define red-background-escape
(make-simple-escape-procedure 41))
(define green-background-escape
(make-simple-escape-procedure 42))
(define yellow-background-escape
(make-simple-escape-procedure 43))
(define blue-background-escape
(make-simple-escape-procedure 44))
(define magenta-background-escape
(make-simple-escape-procedure 45))
(define cyan-background-escape
(make-simple-escape-procedure 46))
(define white-background-escape
(make-simple-escape-procedure 47))
;;> Return a string consisting of an ANSI escape code to select the
;;> specified background color.
;;/
;;> Return a string consisting of an ANSI escape code to select the
;;> background color specified by the \var{red-level}, \var{green-level},
;;> and \var{blue-level} arguments, each of which must be an exact
;;> integer in the range [0, 5].
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (rgb-background-escape red-level green-level blue-level)
(when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 5)))
(error "invalid green-level value" green-level))
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[48;5;"
(number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
"m"))
;;> Return a string consisting of an ANSI escape code to select the
;;> background color specified by the \var{gray-level} argument, which
;;> must be an exact integer in the range [0, 23].
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (gray-background-escape gray-level)
(when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
(error "invalid gray-level value" gray-level))
(string-append "\x1B;[48;5;"
(number->string (+ gray-level 232))
"m"))
;;> The true-color equivalent of \scheme{rgb-background-escape}.
;;> Return a string consisting of an ANSI escape code to select the
;;> text color specified by the \var{red-level}, \var{green-level},
;;> and \var{blue-level} arguments, each of which must be an exact
;;> integer in the range [0, 255].
(define (rgb24-background-escape red-level green-level blue-level)
(when (not (and (exact-integer? red-level) (<= 0 red-level 255)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 255)))
(error "invalid green-level value" green-level))
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 255)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[48;5;"
(number->string red-level) ";"
(number->string green-level) ";"
(number->string blue-level)
"m"))
;;> \procedure{(reset-background-color-escape)}
;;>
;;> Return a string consisting of an ANSI escape code to select the
;;> default background color.
(define reset-background-color-escape
(make-simple-escape-procedure 49))
(define black-background
(make-wrap-procedure (black-background-escape)
(reset-background-color-escape)))
(define red-background
(make-wrap-procedure (red-background-escape)
(reset-background-color-escape)))
(define green-background
(make-wrap-procedure (green-background-escape)
(reset-background-color-escape)))
(define yellow-background
(make-wrap-procedure (yellow-background-escape)
(reset-background-color-escape)))
(define blue-background
(make-wrap-procedure (blue-background-escape)
(reset-background-color-escape)))
(define magenta-background
(make-wrap-procedure (magenta-background-escape)
(reset-background-color-escape)))
(define cyan-background
(make-wrap-procedure (cyan-background-escape)
(reset-background-color-escape)))
(define white-background
(make-wrap-procedure (white-background-escape)
(reset-background-color-escape)))
;;> If ANSI escapes are enabled, return a string consisting of the
;;> string \var{str} with a prefix that selects specified background
;;> color and a suffix that selects the default background color.
;;>
;;> If ANSI escapes are not enabled, return \var{str}.
;;/
;;> Returns a procedure which takes a single argument, a string, and
;;> which when called behaves as follows.
;;>
;;> If ANSI escapes are enabled, the procedure returns a string
;;> consisting of its argument with a prefix that selects specified
;;> background color (obtained by calling the \scheme{rgb-background-escape}
;;> procedure with the values of the \var{red-level}, \var{green-level},
;;> and \var{blue-level} arguments) and a suffix that selects the
;;> default background color.
;;>
;;> If ANSI escapes are not enabled, the procedure returns its argument.
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (rgb-background red-level green-level blue-level)
(make-wrap-procedure (rgb-background-escape red-level green-level blue-level)
(reset-background-color-escape)))
;;> Returns a procedure which takes a single argument, a string, and
;;> which when called behaves as follows.
;;>
;;> If ANSI escapes are enabled, the procedure returns a string
;;> consisting of its argument with a prefix that selects specified
;;> background color (obtained by calling the \scheme{gray-background-escape}
;;> procedure with the values of the \var{gray-level} argument) and a
;;> suffix that selects the default background color.
;;>
;;> If ANSI escapes are not enabled, the procedure returns its argument.
;;>
;;> The caller is resonsible for verifying that the terminal supports
;;> 256 colors.
(define (gray-background gray-level)
(make-wrap-procedure (gray-background-escape gray-level)
(reset-background-color-escape)))
;;> The true-color equivalent of \scheme{rbg-background}, extending
;;> the ranges to [0, 255].
(define (rgb24-background red-level green-level blue-level)
(make-wrap-procedure
(rgb24-background-escape red-level green-level blue-level)
(reset-background-color-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> Return a string consisting of an ANSI escape code to select bold
;;> style.
(define bold-escape
(make-simple-escape-procedure 1))
;;> Return a string consisting of an ANSI escape code to select non-bold
;;> style.
(define reset-bold-escape
(make-simple-escape-procedure 22))
;;> If ANSI escapes are enabled, return a string consisting of the
;;> string \var{str} with a prefix that selects bold style and a suffix
;;> that selects non-bold style.
;;>
;;> If ANSI escapes are not enabled, return \var{str}.
(define bold (make-wrap-procedure (bold-escape)
(reset-bold-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> Return a string consisting of an ANSI escape code to select
;;> underlined style.
(define underline-escape
(make-simple-escape-procedure 4))
;;> Return a string consisting of an ANSI escape code to select
;;> non-underlined style.
(define reset-underline-escape
(make-simple-escape-procedure 24))
;;> If ANSI escapes are enabled, return a string consisting of the
;;> string \var{str} with a prefix that selects underlined style and
;;> a suffix that selects non-underlined style.
;;>
;;> If ANSI escapes are not enabled, return \var{str}.
(define underline
(make-wrap-procedure (underline-escape) (reset-underline-escape)))
;;> Return a string consisting of an ANSI escape code to select
;;> italic style.
(define italic-escape
(make-simple-escape-procedure 3))
;;> Return a string consisting of an ANSI escape code to select
;;> non-italic style.
(define reset-italic-escape
(make-simple-escape-procedure 23))
;;> Returns \var{str} optionally wrapped in italic escapes.
(define italic
(make-wrap-procedure (italic-escape) (reset-italic-escape)))
;;> Return a string consisting of an ANSI escape code to select
;;> strikethrough style.
(define strikethrough-escape
(make-simple-escape-procedure 9))
;;> Return a string consisting of an ANSI escape code to select
;;> non-strikethrough style.
(define reset-strikethrough-escape
(make-simple-escape-procedure 29))
;;> Returns \var{str} optionally wrapped in strikethrough escapes.
(define strikethrough
(make-wrap-procedure (strikethrough-escape) (reset-strikethrough-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> Return a string consisting of an ANSI escape code to select negative
;;> style (text in the background color and background in the text
;;> color).
(define negative-escape
(make-simple-escape-procedure 7))
;;> Return a string consisting of an ANSI escape code to select positive
;;> style (text in the text color and background in the background
;;> color).
(define reset-negative-escape
(make-simple-escape-procedure 27))
;;> If ANSI escapes are enabled, return a string consisting of the
;;> string \var{str} with a prefix that selects negative style (text
;;> in the background color and background in the text color) and a
;;> suffix that selects positive style (text in the text color and
;;> background in the background color).
;;>
;;> If ANSI escapes are not enabled, return \var{str}.
(define negative (make-wrap-procedure (negative-escape)
(reset-negative-escape)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> A parameter object that determines whether ANSI escapes are enabled
;;> in some of the preceding procedures. They are disabled if
;;> \scheme{(ansi-escapes-enabled?)} returns \scheme{#f}, and otherwise
;;> they are enabled.
;;>
;;> The initial value returned by \scheme{(ansi-escapes-enabled?)} is
;;> determined by the environment.
;;>
;;> If the environment variable \scheme{ANSI_ESCAPES_ENABLED} is set,
;;> its value determines the initial value returned by
;;> \scheme{(ansi-escapes-enabled?)}. If the value of
;;> \scheme{ANSI_ESCAPES_ENABLED} is \scheme{"0"}, the initial value
;;> is \scheme{#f}, otherwise the initial value is \scheme{#t}.
;;>
;;> If the environment variable \scheme{ANSI_ESCAPES_ENABLED} is not
;;> set, but the environment variable \scheme{TERM} is set, the value
;;> of the latter determines the initial value returned by
;;> \scheme{(ansi-escapes-enabled?)}. If the value of \scheme{TERM}
;;> is \scheme{"xterm"}, \scheme{"xterm-color"}, \scheme{"xterm-256color"},
;;> \scheme{"rxvt"}, \scheme{"rxvt-unicode-256color"}, \scheme{"kterm"},
;;> \scheme{"linux"}, \scheme{"screen"}, \scheme{"screen-256color"},
;;> or \scheme{"vt100"}, the initial value is \scheme{#t}, otherwise
;;> the initial value is \scheme{#f}.
;;>
;;> If neither of the environment variables \scheme{ANSI_ESCAPES_ENABLED}
;;> and \scheme{TERM} are set, the initial value returned by
;;> \scheme{(ansi-escapes-enabled?)} is \scheme{#f}.
(define ansi-escapes-enabled?
(make-parameter
(cond
((get-environment-variable "ANSI_ESCAPES_ENABLED")
=> (lambda (s) (not (equal? s "0"))))
(else
(member (get-environment-variable "TERM")
'("xterm" "xterm-color" "xterm-256color" "rxvt" "kterm"
"linux" "screen" "screen-256color" "vt100"
"tmux-256color" "rxvt-unicode-256color"))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> \section{Notes}
;;>
;;> It is important to remember that the formatting procedures apply
;;> a prefix to set a particular graphics parameter and a suffix to
;;> reset the parameter to its default value. This can lead to surprises.
;;> For example, on an ANSI terminal, one might mistakenly expect the
;;> following to display GREEN in green text and then RED in red text:
;;>
;;> \codeblock{(display (red (string-append (green "GREEN") "RED")))}
;;>
;;> However, it will actually display GREEN in green text and then RED
;;> in the default text color. This is a limitation of ANSI control
;;> codes; graphics attributes are not saved to and restored from a
;;> stack, but instead are simply set. One way to display GREEN in
;;> green text and then RED in red text is:
;;>
;;> \codeblock{(display (string-append (green "GREEN") (red "RED")))}
;;>
;;> On the other hand, text color, background color, font weight (bold
;;> or default), underline (on or off), image (positive or negative)
;;> are orthogonal. So, for example, on an ANSI terminal the following
;;> should display GREEN in green text and then RED in red text, with
;;> both in bold and GREEN underlined.
;;>
;;> \codeblock{(display (bold (string-append (underline (green "GREEN")) (red "RED"))))}
;;>

42
snow/chibi/term/ansi.sld Normal file
View File

@ -0,0 +1,42 @@
(define-library (chibi term ansi)
(export
black-escape red-escape yellow-escape green-escape
blue-escape cyan-escape magenta-escape white-escape
rgb-escape
gray-escape
rgb24-escape
reset-color-escape
black-background-escape red-background-escape
yellow-background-escape green-background-escape
blue-background-escape cyan-background-escape
magenta-background-escape white-background-escape
rgb-background-escape
gray-background-escape
rgb24-background-escape
reset-background-color-escape
black red yellow green
blue cyan magenta white
black-background red-background yellow-background green-background
blue-background cyan-background magenta-background white-background
bold
underline
negative
italic
strikethrough
rgb rgb-background
gray gray-background
rgb24 rgb24-background
bold-escape reset-bold-escape
underline-escape reset-underline-escape
negative-escape reset-negative-escape
italic-escape reset-italic-escape
strikethrough-escape reset-strikethrough-escape
ansi-escapes-enabled?)
(import (scheme base)
(scheme write)
(scheme process-context))
(include "ansi.scm"))

131
snow/chibi/test.html Normal file
View File

@ -0,0 +1,131 @@
<html><head>
<style type="text/css">
body {color: #000; background-color: #FFF}
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 190px; height: 100%}
div#main {position: absolute; top: 0; left: 200px; width: 540px; height: 100%}
div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: 0px; font-size: smaller;}
div#footer {padding-bottom: 50px}
.result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px}
.output { color: #000; background-color: beige; width: 100%; padding: 3px}
.error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px}
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
.keyword { color: #800080; background-color: inherit; }
.type { color: #008000; background-color: inherit; }
.function { color: #0000FF; background-color: inherit; }
.variable { color: #B8860B; background-color: inherit; }
.comment { color: #FF0000; background-color: inherit; }
.string { color: #BC8F8F; background-color: inherit; }
.attribute { color: #FF5000; background-color: inherit; }
.preprocessor { color: #FF00FF; background-color: inherit; }
.builtin { color: #FF00FF; background-color: inherit; }
.character { color: #0055AA; background-color: inherit; }
.syntaxerror { color: #FF0000; background-color: inherit; }
.diff-deleted { color: #5F2121; background-color: inherit; }
.diff-added { color: #215F21; background-color: inherit; }
span.paren1 { color: #AAAAAA; background-color: inherit; }
span.paren2 { color: #888888; background-color: inherit; }
span.paren3 { color: #666666; background-color: inherit; }
span.paren4 { color: #444444; background-color: inherit; }
span.paren5 { color: #222222; background-color: inherit; }
span.paren6 { color: #000000; background-color: inherit; }
</style>
</head><body><div id="menu"><ol><li><a href="#h2_Testing">Testing</a><ol><li><a href="#h3_(test[name]expectexpr)">test</a></li><li><a href="#h3_(test-equalequal[name]expectexpr)">test-equal</a></li><li><a href="#h3_(test-assert[name]expr)">test-assert</a></li><li><a href="#h3_(test-not[name]expr)">test-not</a></li><li><a href="#h3_(test-values[name]expectexpr)">test-values</a></li><li><a href="#h3_(test-error[name]expr)">test-error</a></li><li><a href="#h3_test-propagate-info">test-propagate-info</a></li><li><a href="#h3_test-run">test-run</a></li><li><a href="#h3_test-equal?">test-equal?</a></li></ol></li><li><a href="#h2_TestGroups">Test Groups</a><ol><li><a href="#h3_test-group">test-group</a></li><li><a href="#h3_test-begin">test-begin</a></li><li><a href="#h3_test-end">test-end</a></li><li><a href="#h3_test-exit">test-exit</a></li><li><a href="#h3_test-syntax-error">test-syntax-error</a></li></ol></li><li><a href="#h2_Accessors">Accessors</a><ol><li><a href="#h3_test-group-name">test-group-name</a></li><li><a href="#h3_test-group-ref">test-group-ref</a></li><li><a href="#h3_test-group-set!">test-group-set!</a></li><li><a href="#h3_test-group-inc!">test-group-inc!</a></li><li><a href="#h3_test-group-push!">test-group-push!</a></li><li><a href="#h3_test-get-name!">test-get-name!</a></li></ol></li><li><a href="#h2_Parameters">Parameters</a><ol><li><a href="#h3_current-test-group">current-test-group</a></li><li><a href="#h3_current-test-verbosity">current-test-verbosity</a></li><li><a href="#h3_current-test-epsilon">current-test-epsilon</a></li><li><a href="#h3_current-test-comparator">current-test-comparator</a></li><li><a href="#h3_current-test-applier">current-test-applier</a></li><li><a href="#h3_current-test-skipper">current-test-skipper</a></li><li><a href="#h3_current-test-reporter">current-test-reporter</a></li><li><a href="#h3_current-test-group-reporter">current-test-group-reporter</a></li><li><a href="#h3_test-failure-count">test-failure-count</a></li><li><a href="#h3_current-test-group-filters">current-test-group-filters</a></li><li><a href="#h3_current-test-group-removers">current-test-group-removers</a></li><li><a href="#h3_current-test-filters">current-test-filters</a></li><li><a href="#h3_current-test-removers">current-test-removers</a></li><li><a href="#h3_current-column-width">current-column-width</a></li></ol></li></ol></div><div id="main"><div><a name="h1_(chibitest)"></a><h1>(chibi test)</h1></div><p>Simple but extensible testing framework with advanced reporting.<div><a name="h2_Testing"></a><h2>Testing</h2></div>
<div><a name="h3_(test[name]expectexpr)"></a><h3><code>(test [name] expect expr)</code></h3></div>
The primary interface to testing. Evaluate <code>expr</code> and check
that it is equal to <code>expect</code>, and report the result, using
<code>name</code> or a printed summary of <code>expr</code>.
If used inside a group this will contribute to the overall group
reporting, but can be used standalone:
<div><pre><code>(test <span>4</span> (+ <span>2</span> <span>2</span>))</code></pre><div class="output"><pre>(+ 2 2) .............................................................. [ PASS]
</pre></div><div class="result"><code>=> PASS</code></div></div>
<div><pre><code>(test <span class="string">"add two and two"</span> <span>4</span> (+ <span>2</span> <span>2</span>))</code></pre><div class="output"><pre>add two and two ...................................................... [ PASS]
</pre></div><div class="result"><code>=> PASS</code></div></div>
<div><pre><code>(test <span>3</span> (+ <span>2</span> <span>2</span>))</code></pre><div class="output"><pre><span>(+ 2 2) .............................................................. [ <span style="color:red">FAIL</span>]
expected <span style="color:red">3</span> but got <span style="color:green">4</span>
</span></pre></div><div class="result"><code>=> FAIL</code></div></div>
<div><pre><code>(test <span>4</span> (+ <span>2</span> <span class="string">"2"</span>))</code></pre><div class="output"><pre><span>(+ 2 "2") ............................................................ [<u><span style="color:red">ERROR</span></u>]
ERROR: invalid type, expected Number: "2"
</span></pre></div><div class="result"><code>=> ERROR</code></div></div>
The equality comparison is made with
<code><span>current-test-comparator</span></code>, defaulting to
<code><span>test-equal?</span></code>, which is the same as <code><span>equal?</span></code> but
more permissive on floating point comparisons). Returns the
status of the test (one of the symbols <code>'<span>PASS</span></code>,
<code>'<span>FAIL</span></code>, <code>'<span>SKIP</span></code>, <code>'<span>ERROR</span></code>).<div><a name="h3_(test-equalequal[name]expectexpr)"></a><h3><code>(test-equal equal [name] expect expr)</code></h3></div>
Equivalent to test, using <code>equal</code> for comparison instead of
<code><span>equal?</span></code>.<div><a name="h3_(test-assert[name]expr)"></a><h3><code>(test-assert [name] expr)</code></h3></div>
Like <code><span>test</span></code> but evaluates <code>expr</code> and checks that it's true.<div><a name="h3_(test-not[name]expr)"></a><h3><code>(test-not [name] expr)</code></h3></div>
Like <code><span>test</span></code> but evaluates <code>expr</code> and checks that it's false.<div><a name="h3_(test-values[name]expectexpr)"></a><h3><code>(test-values [name] expect expr)</code></h3></div>
Like <code><span>test</span></code> but <code>expect</code> and <code>expr</code> can both
return multiple values.<div><a name="h3_(test-error[name]expr)"></a><h3><code>(test-error [name] expr)</code></h3></div>
Like <code><span>test</span></code> but evaluates <code>expr</code> and checks that it
raises an error.<div><a name="h3_test-propagate-info"></a><h3><code>(test-propagate-info name expect expr info)</code></h3></div>Low-level macro to pass alist info to the underlying <code>test-run</code>.<div><a name="h3_test-run"></a><h3><code>(test-run expect expr info)</code></h3></div>The procedural interface to testing. <code>expect</code> and <code>expr</code>
should be thunks, and <code>info</code> is an alist of properties used in
test reporting.<div><a name="h3_test-equal?"></a><h3><code>(test-equal? expect res)</code></h3></div>Returns true if either <code>(equal? <span>expect</span> <span>res</span>)</code>, or
<code>expect</code> is inexact and <code>res</code> is within
<code><span>current-test-epsilon</span></code> of <code>expect</code>.<div><a name="h2_TestGroups"></a><h2>Test Groups</h2></div><div><a name="h3_test-group"></a><h3><code>(test-group name-expr body ...)</code></h3></div>
Tests can be collected in groups for
Wraps <code>body</code> as a single test group, which can be filtered
and summarized separately.
<div><pre><code>(test-group <span class="string">"pi"</span>
(test <span>3.14159</span> (acos <span>-1</span>))
(test <span>3</span> (acos <span>-1</span>))
(test <span>3.14159</span> (acos <span class="string">"-1"</span>)))
</code></pre><div class="output"><pre><span><b>pi: </b>.<span style="color:red">x</span><u><span style="color:red">!</span></u>
1 out of 3 (33.3%) test passed in 0.00030422210693359375 seconds.
<span style="color:red">1 failure (33.3%).
</span><u><span style="color:red">1 error (33.3%).
</span></u><span style="color:red">FAIL: </span>(acos -1)
expected 3 but got 3<span style="color:green">.141592653589793</span>
<span style="color:red">ERROR: </span>(acos "-1")
ERROR in "acos": invalid type, expected Number: "-1"
</span></pre></div></div><div><a name="h3_test-begin"></a><h3><code>(test-begin [name])</code></h3></div>Begin testing a new group until the closing <code>(test-end)</code>.<div><a name="h3_test-end"></a><h3><code>(test-end [name])</code></h3></div>Ends testing group introduced with <code>(test-begin)</code>, and
summarizes the results. The <code>name</code> is optional, but if
present should match the corresponding <code><span>test-begin</span></code> name,
or a warning is printed.<div><a name="h3_test-exit"></a><h3><code>(test-exit)</code></h3></div>Exits with a failure status if any tests have failed,
and a successful status otherwise.<div><a name="h3_test-syntax-error"></a><h3><code>(test-syntax-error)</code></h3></div><div><a name="h2_Accessors"></a><h2>Accessors</h2></div><div><a name="h3_test-group-name"></a><h3><code>(test-group-name group)</code></h3></div>Returns the name of a test group info object.<div><a name="h3_test-group-ref"></a><h3><code>(test-group-ref group field . o)</code></h3></div>Returns the value of a <code>field</code> in a test var{group} info
object. <code>field</code> should be a symbol, and predefined fields
include <code><span>parent</span></code>, <code><span>verbose</span></code>, <code><span>level</span></code>,
<code><span>start-time</span></code>, <code><span>skip-group?</span></code>, <code><span>count</span></code>,
<code><span>total-pass</span></code>, <code><span>total-fail</span></code>, <code><span>total-error</span></code>.<div><a name="h3_test-group-set!"></a><h3><code>(test-group-set! group field value)</code></h3></div>Sets the value of a <code>field</code> in a test <code>group</code> info object.<div><a name="h3_test-group-inc!"></a><h3><code>(test-group-inc! group field [amount])</code></h3></div>Increments the value of a <code>field</code> in a test <code>group</code> info
object by <code>amount</code>, defaulting to 1.<div><a name="h3_test-group-push!"></a><h3><code>(test-group-push! group field value)</code></h3></div>Updates a <code>field</code> in a test group info object by consing
<code>value</code> onto it.<div><a name="h3_test-get-name!"></a><h3><code>(test-get-name! info)</code></h3></div><div><a name="h2_Parameters"></a><h2>Parameters</h2></div><div><a name="h3_current-test-group"></a><h3><code>current-test-group</code></h3></div>
The current test group as started by <code><span>test-group</span></code> or
<code><span>test-begin</span></code>.<div><a name="h3_current-test-verbosity"></a><h3><code>current-test-verbosity</code></h3></div>If true, show more verbose output per test. Inferred from the
environment variable TEST_VERBOSE.<div><a name="h3_current-test-epsilon"></a><h3><code>current-test-epsilon</code></h3></div>The epsilon used for floating point comparisons.<div><a name="h3_current-test-comparator"></a><h3><code>current-test-comparator</code></h3></div>The underlying comparator used in testing, defaults to
<code><span>test-equal?</span></code>.<div><a name="h3_current-test-applier"></a><h3><code>current-test-applier</code></h3></div>The test applier - what we do with non-skipped tests. Takes the
same signature as <code><span>test-run</span></code>, should be responsible for
evaluating the thunks, determining the status of the test, and
passing this information to <code><span>current-test-reporter</span></code>.<div><a name="h3_current-test-skipper"></a><h3><code>current-test-skipper</code></h3></div>The test skipper - what we do with non-skipped tests. This should
not evaluate the thunks and simply pass off to
<code><span>current-test-reporter</span></code>.<div><a name="h3_current-test-reporter"></a><h3><code>current-test-reporter</code></h3></div>Takes two arguments, the symbol status of the test and the info
alist. Reports the result of the test and updates bookkeeping in
the current test group for reporting.<div><a name="h3_current-test-group-reporter"></a><h3><code>current-test-group-reporter</code></h3></div>Takes one argument, a test group, and prints a summary of the test
results for that group.<div><a name="h3_test-failure-count"></a><h3><code>test-failure-count</code></h3></div>A running count of all test failures and errors across all groups
(and threads). Used by <code><span>test-exit</span></code>.<div><a name="h3_current-test-group-filters"></a><h3><code>current-test-group-filters</code></h3></div><div><a name="h3_current-test-group-removers"></a><h3><code>current-test-group-removers</code></h3></div>Parameters controlling which test groups are skipped. Each
parameter is a list of procedures of one argument, a test group
info, which can be queried with <code>test-group-name</code> and
<code>test-group-ref</code>. Analogous to SRFI 1, a filter selects a
group for inclusion and a removers for exclusion. The defaults
are set automatically from the environment variables
TEST_GROUP_FILTER and TEST_GROUP_REMOVE, which should be
comma-delimited lists of strings which are checked for a substring
match in the test group name. A test group is skipped if it does
not match any filter and:
<ul><li>its parent group is skipped, or</li><li>it matches a remover, or</li><li>no removers are specified but some filters are</li></ul><div><a name="h3_current-test-filters"></a><h3><code>current-test-filters</code></h3></div><div><a name="h3_current-test-removers"></a><h3><code>current-test-removers</code></h3></div>Parameters controlling which tests are skipped. Each parameter is
a list of procedures of one argument, a test info alist, which can
be queried with <code><span>test-get-name!</span></code> or <code><span>assq</span></code>.
Analogous to SRFI 1, a filter selects a test for inclusion and a
removers for exclusion. The defaults are set automatically from
the environment variables TEST_FILTER and TEST_REMOVE, which
should be comma-delimited lists of strings which are checked for a
substring match in the test name. A test is skipped if its group
is skipped, or if it does not match a filter and:
<ul><li>it matches a remover, or</li><li>no removers are specified but some filters are</li></ul><div><a name="h3_current-column-width"></a><h3><code>current-column-width</code></h3></div>Parameter controlling the current column width for test output,
can be set from the environment variable TEST_COLUMN_WIDTH,
otherwise defaults to 78. For portability of implementation (and
resulting output), does not attempt to use termios to determine
the actual available width.</p><div id="footer"></div></div></body></html>

985
snow/chibi/test.scm Normal file
View File

@ -0,0 +1,985 @@
;; Copyright (c) 2010-2020 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> Simple but extensible testing framework with advanced reporting.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; list utilities
;; Simplified version of SRFI-1 any.
(define (any pred ls)
(and (pair? ls)
(or (pred (car ls))
(any pred (cdr ls)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exception utilities
(define (warning msg . args)
(display msg (current-error-port))
(for-each (lambda (x)
(write-char #\space (current-error-port))
(write x (current-error-port)))
args)
(newline (current-error-port)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; string utilities
(define (string-search pat str)
(let* ((pat-len (string-length pat))
(limit (- (string-length str) pat-len)))
(let lp1 ((i 0))
(cond
((>= i limit) #f)
(else
(let lp2 ((j i) (k 0))
(cond ((>= k pat-len) #t)
((not (eqv? (string-ref str j) (string-ref pat k)))
(lp1 (+ i 1)))
(else (lp2 (+ j 1) (+ k 1))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; test interface
;;> \section{Testing}
;;> \macro{(test [name] expect expr)}
;;> The primary interface to testing. Evaluate \var{expr} and check
;;> that it is equal to \var{expect}, and report the result, using
;;> \var{name} or a printed summary of \var{expr}.
;;>
;;> If used inside a group this will contribute to the overall group
;;> reporting, but can be used standalone:
;;>
;;> \example{(test 4 (+ 2 2))}
;;> \example{(test "add two and two" 4 (+ 2 2))}
;;> \example{(test 3 (+ 2 2))}
;;> \example{(test 4 (+ 2 "2"))}
;;>
;;> The equality comparison is made with
;;> \scheme{current-test-comparator}, defaulting to
;;> \scheme{test-equal?}, which is the same as \scheme{equal?} but
;;> more permissive on floating point comparisons). Returns the
;;> status of the test (one of the symbols \scheme{'PASS},
;;> \scheme{'FAIL}, \scheme{'SKIP}, \scheme{'ERROR}).
(define-syntax test
(syntax-rules (quote)
((test expect expr)
(test #f expect expr))
((test name expect (expr ...))
(test-propagate-info name expect (expr ...) ()))
((test name 'expect expr)
(test-propagate-info name 'expect expr ()))
((test name (expect ...) expr)
(test-syntax-error
'test
"the test expression should come last: (test <expected> (<expr> ...)) "
(test name (expect ...) expr)))
((test name expect expr)
(test-propagate-info name expect expr ()))
((test a ...)
(test-syntax-error 'test "test requires 2 or 3 arguments" (test a ...)))))
;;> \macro{(test-equal equal [name] expect expr)}
;;> Equivalent to test, using \var{equal} for comparison instead of
;;> \scheme{equal?}.
(define-syntax test-equal
(syntax-rules ()
((test-equal equal . args)
(parameterize ((current-test-comparator equal))
(test . args)))))
;;> \macro{(test-assert [name] expr)}
;;> Like \scheme{test} but evaluates \var{expr} and checks that it's true.
(define-syntax test-assert
(syntax-rules ()
((_ expr)
(test-assert #f expr))
((_ name expr)
(test-propagate-info name #f expr ((assertion . #t))))
((test a ...)
(test-syntax-error 'test-assert "1 or 2 arguments required"
(test a ...)))))
;;> \macro{(test-not [name] expr)}
;;> Like \scheme{test} but evaluates \var{expr} and checks that it's false.
(define-syntax test-not
(syntax-rules ()
((_ expr) (test-assert (not expr)))
((_ name expr) (test-assert name (not expr)))))
;;> \macro{(test-values [name] expect expr)}
;;> Like \scheme{test} but \var{expect} and \var{expr} can both
;;> return multiple values.
(define-syntax test-values
(syntax-rules ()
((_ expect expr)
(test-values #f expect expr))
((_ name expect expr)
(test name (call-with-values (lambda () expect) (lambda results results))
(call-with-values (lambda () expr) (lambda results results))))))
;;> \macro{(test-error [name] expr)}
;;> Like \scheme{test} but evaluates \var{expr} and checks that it
;;> raises an error.
(define-syntax test-error
(syntax-rules ()
((_ expr)
(test-error #f expr))
((_ name expr)
(test-propagate-info name #f expr ((expect-error . #t))))
((test a ...)
(test-syntax-error 'test-error "1 or 2 arguments required"
(test a ...)))))
;;> Low-level macro to pass alist info to the underlying \var{test-run}.
(define-syntax test-propagate-info
(syntax-rules ()
;; TODO: Extract interesting variables so we can show their values
;; on failure. Vars are empty for now.
((test-propagate-info name expect expr info)
(test-vars () name expect expr info))))
(define-syntax test-vars
(syntax-rules ()
((_ (vars ...) n expect expr ((key . val) ...))
(test-run (lambda () expect)
(lambda () expr)
`((name . ,n)
(source . expr)
(var-names . (vars ...))
(var-values . ,(list vars ...))
(key . val) ...)))))
;;> The procedural interface to testing. \var{expect} and \var{expr}
;;> should be thunks, and \var{info} is an alist of properties used in
;;> test reporting.
(define (test-run expect expr info)
(let ((info (test-expand-info info)))
(if (and (cond ((current-test-group)
=> (lambda (g) (not (test-group-ref g 'skip-group?))))
(else #t))
(or (and (not (any (lambda (f) (f info)) (current-test-removers)))
(or (pair? (current-test-removers))
(null? (current-test-filters))))
(any (lambda (f) (f info)) (current-test-filters))))
((current-test-applier) expect expr info)
((current-test-skipper) info))))
;;> Returns true if either \scheme{(equal? expect res)}, or
;;> \var{expect} is inexact and \var{res} is within
;;> \scheme{current-test-epsilon} of \var{expect}.
(define (test-equal? expect res)
(or (equal? expect res)
(if (real? expect)
(and (inexact? expect)
(real? res)
;; tests which expect an inexact value can
;; accept an equivalent exact value
;; (inexact? res)
(approx-equal? expect res (current-test-epsilon)))
(and (complex? res)
(complex? expect)
(test-equal? (real-part expect) (real-part res))
(test-equal? (imag-part expect) (imag-part res))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; group interface
;;> \section{Test Groups}
;;> Tests can be collected in groups for
;;> Wraps \var{body} as a single test group, which can be filtered
;;> and summarized separately.
;;> \example{
;;> (test-group "pi"
;;> (test 3.14159 (acos -1))
;;> (test 3 (acos -1))
;;> (test 3.14159 (acos "-1")))
;;> }
(define-syntax test-group
(syntax-rules ()
((_ name-expr body ...)
(let ((name name-expr)
(old-group (current-test-group)))
(when (not (string? name))
(error "a name is required, got " 'name-expr name))
(test-begin name)
(guard
(exn
(else
(warning "error in group outside of tests")
(print-exception exn (current-error-port))
(test-group-inc! (current-test-group) 'count)
(test-group-inc! (current-test-group) 'ERROR)
(test-failure-count (+ 1 (test-failure-count)))))
body ...)
(test-end name)
(current-test-group old-group)))))
;;> Begin testing a new group until the closing \scheme{(test-end)}.
(define (test-begin . o)
(let* ((name (if (pair? o) (car o) ""))
(parent (current-test-group))
(group (make-test-group name parent)))
;; include a newline if we are directly nested in a parent with no
;; tests yet
(when (and parent
(zero? (test-group-ref parent 'subgroups-count 0))
(not (test-group-ref parent 'verbose)))
(newline))
;; header
(cond
((test-group-ref group 'skip-group?)
(display (make-string (or (test-group-indent-width group) 0) #\space))
(display (strikethrough (bold (string-append name ":"))))
(display " SKIP"))
((test-group-ref group 'verbose)
(display
(test-header-line
(string-append "testing " name)
(or (test-group-indent-width group) 0))))
(else
(display
(string-append
(make-string (or (test-group-indent-width group) 0)
#\space)
(bold (string-append name ": "))))))
;; set the current test group
(current-test-group group)))
;;> Ends testing group introduced with \scheme{(test-begin)}, and
;;> summarizes the results. The \var{name} is optional, but if
;;> present should match the corresponding \scheme{test-begin} name,
;;> or a warning is printed.
(define (test-end . o)
(let ((name (and (pair? o) (car o))))
(cond
((current-test-group)
=> (lambda (group)
(when (and name (not (equal? name (test-group-name group))))
(warning "mismatched test-end:" name (test-group-name group)))
(let ((parent (test-group-ref group 'parent)))
(when (and (test-group-ref group 'skip-group?)
(zero? (test-group-ref group 'subgroups-count 0)))
(newline))
;; only report if there's something to say
((current-test-group-reporter) group)
(when parent
(test-group-inc! parent 'subgroups-count)
(cond
((test-group-ref group 'skip-group?)
(test-group-inc! parent 'subgroups-skip))
((and (zero? (test-group-ref group 'FAIL 0))
(zero? (test-group-ref group 'ERROR 0))
(= (test-group-ref group 'subgroups-pass 0)
(test-group-ref group 'subgroups-count 0)))
(test-group-inc! parent 'subgroups-pass))))
(current-test-group parent)
group))))))
;;> Exits with a failure status if any tests have failed,
;;> and a successful status otherwise.
(define (test-exit)
(when (current-test-group)
(warning "calling test-exit with unfinished test group:"
(test-group-name (current-test-group))))
(exit (zero? (test-failure-count))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utilities
(define-syntax test-syntax-error
(syntax-rules ()
((_) (syntax-error "invalid use of test-syntax-error"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; test-group representation
;;> \section{Accessors}
;; (name (prop value) ...)
(define (make-test-group name . o)
(let ((parent (and (pair? o) (car o)))
(group (list name (cons 'start-time (current-second)))))
(test-group-set! group 'parent parent)
(test-group-set! group 'verbose
(if parent
(test-group-ref parent 'verbose)
(current-test-verbosity)))
(test-group-set! group 'level
(if parent
(+ 1 (test-group-ref parent 'level 0))
0))
(test-group-set!
group
'skip-group?
(and (or (and parent (test-group-ref parent 'skip-group?))
(any (lambda (f) (f group)) (current-test-group-removers))
(and (null? (current-test-group-removers))
(pair? (current-test-group-filters))))
(not (any (lambda (f) (f group)) (current-test-group-filters)))))
group))
;;> Returns the name of a test group info object.
(define (test-group-name group) (car group))
;;> Returns the value of a \var{field} in a test var{group} info
;;> object. \var{field} should be a symbol, and predefined fields
;;> include \scheme{parent}, \scheme{verbose}, \scheme{level},
;;> \scheme{start-time}, \scheme{skip-group?}, \scheme{count},
;;> \scheme{total-pass}, \scheme{total-fail}, \scheme{total-error}.
(define (test-group-ref group field . o)
(if group
(apply assq-ref (cdr group) field o)
(and (pair? o) (car o))))
;;> Sets the value of a \var{field} in a test \var{group} info object.
(define (test-group-set! group field value)
(cond
((assq field (cdr group))
=> (lambda (x) (set-cdr! x value)))
(else (set-cdr! group (cons (cons field value) (cdr group))))))
;;> Increments the value of a \var{field} in a test \var{group} info
;;> object by \var{amount}, defaulting to 1.
(define (test-group-inc! group field . o)
(let ((amount (if (pair? o) (car o) 1)))
(cond
((assq field (cdr group))
=> (lambda (x) (set-cdr! x (+ amount (cdr x)))))
(else (set-cdr! group (cons (cons field amount) (cdr group)))))))
;;> Updates a \var{field} in a test group info object by consing
;;> \var{value} onto it.
(define (test-group-push! group field value)
(cond
((assq field (cdr group))
=> (lambda (x) (set-cdr! x (cons value (cdr x)))))
(else (set-cdr! group (cons (cons field (list value)) (cdr group))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utilities
(define (assq-ref ls key . o)
(cond ((assq key ls) => cdr)
((pair? o) (car o))
(else #f)))
(define (approx-equal? a b epsilon)
(cond
((> (abs a) (abs b))
(approx-equal? b a epsilon))
((zero? a)
(< (abs b) epsilon))
(else
(< (abs (/ (- a b) b)) epsilon))))
(define (call-with-output-string proc)
(let ((out (open-output-string)))
(proc out)
(get-output-string out)))
;; partial pretty printing to abbreviate `quote' forms and the like
(define (write-to-string x)
(call-with-output-string
(lambda (out)
(let wr ((x x))
(if (pair? x)
(cond
((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))
(assq (car x)
'((quote . "'") (quasiquote . "`")
(unquote . ",") (unquote-splicing . ",@"))))
=> (lambda (s) (display (cdr s) out) (wr (cadr x))))
(else
(display "(" out)
(wr (car x))
(let lp ((ls (cdr x)))
(cond ((pair? ls)
(display " " out)
(wr (car ls))
(lp (cdr ls)))
((not (null? ls))
(display " . " out)
(write ls out))))
(display ")" out)))
(write x out))))))
(define (display-to-string x)
(if (string? x) x (call-with-output-string (lambda (out) (display x out)))))
;; if we need to truncate, try first dropping let's to get at the
;; heart of the expression
(define (truncate-source x width . o)
(let* ((str (write-to-string x))
(len (string-length str)))
(cond
((<= len width)
str)
((and (pair? x) (eq? 'let (car x)))
(if (and (pair? o) (car o))
(truncate-source (car (reverse x)) width #t)
(string-append "..."
(truncate-source (car (reverse x)) (- width 3) #t))))
((and (pair? x) (eq? 'call-with-current-continuation (car x)))
(truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
((and (pair? x) (eq? 'call-with-values (car x)))
(string-append
"..."
(truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (car (cadr x))))
(car (reverse (cadr x)))
(cadr x))
(- width 3)
#t)))
(else
(string-append
(substring str 0 (min (max 0 (- width 3)) (string-length str)))
"...")))))
(define (test-get-name! info)
(or
(assq-ref info 'name)
(assq-ref info 'gen-name)
(let ((name
(cond
((assq 'source info)
=> (lambda (src)
(truncate-source (cdr src) (- (current-column-width) 12))))
((current-test-group)
=> (lambda (g)
(display "no source in: " (current-error-port))
(write info (current-error-port))
(display "\n" (current-error-port))
(string-append
"test-"
(number->string (test-group-ref g 'count 0)))))
(else ""))))
(if (pair? info)
(set-cdr! info (cons (cons 'gen-name name) (cdr info))))
name)))
(define (test-print-name info . indent)
(let ((width (- (current-column-width)
(or (and (pair? indent) (car indent)) 0)))
(name (test-get-name! info)))
(display name)
(display " ")
(let ((diff (- width 9 (string-length name))))
(cond
((positive? diff)
(display (make-string diff #\.)))))
(display " ")
(flush-output-port)))
(define (test-group-indent-width group)
(let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0)
(test-first-indentation))))))
(* 4 (min level (test-max-indentation)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-expand-info info)
(let ((expr (assq-ref info 'source)))
(if (and (pair? expr)
(pair-source expr)
(not (assq-ref info 'line-number)))
`((file-name . ,(car (pair-source expr)))
(line-number . ,(cdr (pair-source expr)))
,@info)
info)))
(define (test-default-applier expect expr info)
(let* ((group (current-test-group))
(indent (and group (test-group-indent-width group))))
(cond
((or (not group) (test-group-ref group 'verbose))
(if (and indent (positive? indent))
(display (make-string indent #\space)))
(test-print-name info indent)))
(let ((expect-val
(guard
(exn
(else
(warning "bad expect value")
(print-exception exn (current-error-port))
#f))
(expect))))
(guard
(exn
(else
((current-test-reporter)
(if (assq-ref info 'expect-error) 'PASS 'ERROR)
(append `((exception . ,exn)) info))))
(let ((res (expr)))
(let ((status
(if (and (not (assq-ref info 'expect-error))
(if (assq-ref info 'assertion)
res
((current-test-comparator) expect-val res)))
'PASS
'FAIL))
(info `((result . ,res) (expected . ,expect-val) ,@info)))
((current-test-reporter) status info)))))))
(define (test-default-skipper info)
((current-test-reporter) 'SKIP info))
(define (test-status-color status)
(case status
((ERROR) (lambda (x) (underline (red x))))
((FAIL) red)
((SKIP) yellow)
(else (lambda (x) x))))
(define (test-status-message status)
((test-status-color status) (symbol->string status)))
(define (test-status-code status)
((test-status-color status)
;; alternatively: ❗, ✗, ‒, ✓
;; unfortunately, these have ambiguous width
(case status
((ERROR) "!")
((FAIL) "x")
((SKIP) "-")
(else "."))))
(define (display-expected/actual expected actual)
(let* ((e-str (write-to-string expected))
(a-str (write-to-string actual))
(diff (diff e-str a-str read-char)))
(write-string "expected ")
(write-string (edits->string/color (car diff) (car (cddr diff)) 1))
(write-string " but got ")
(write-string (edits->string/color (cadr diff) (car (cddr diff)) 2))))
(define (test-print-explanation indent status info)
(cond
((eq? status 'ERROR)
(display indent)
(cond ((assq 'exception info)
=> (lambda (e)
(print-exception (cdr e) (current-output-port))))))
((and (eq? status 'FAIL) (assq-ref info 'assertion))
(display indent)
(display "assertion failed\n"))
((and (eq? status 'FAIL) (assq-ref info 'expect-error))
(display indent)
(display "expected an error but got ")
(write (assq-ref info 'result)) (newline))
((eq? status 'FAIL)
(display indent)
(display-expected/actual (assq-ref info 'expected) (assq-ref info 'result))
(newline)))
;; print variables
(cond
((and (memq status '(FAIL ERROR)) (assq-ref info 'var-names))
=> (lambda (names)
(let ((values (assq-ref info 'var-values)))
(if (and (pair? names)
(pair? values)
(= (length names) (length values)))
(let ((indent2
(string-append indent (make-string 2 #\space))))
(for-each
(lambda (name value)
(display indent2) (write name) (display ": ")
(write value) (newline))
names values))))))))
(define (test-print-source indent status info)
(case status
((FAIL ERROR)
(cond
((assq-ref info 'line-number)
=> (lambda (line)
(display " on line ")
(write line)
(cond ((assq-ref info 'file-name)
=> (lambda (file) (display " of file ") (write file))))
(newline))))
(cond
((assq-ref info 'source)
=> (lambda (s)
(cond
((or (assq-ref info 'name)
(> (string-length (write-to-string s))
(current-column-width)))
(display (write-to-string s))
(newline))))))
(cond
((assq-ref info 'values)
=> (lambda (v)
(for-each
(lambda (v)
(display " ") (display (car v))
(display ": ") (write (cdr v)) (newline))
v)))))))
(define (test-print-failure indent status info)
;; display status explanation
(test-print-explanation indent status info)
;; display line, source and values info
(test-print-source indent status info))
(define (test-header-line str . indent)
(let* ((header (string-append
(make-string (if (pair? indent) (car indent) 0) #\space)
"-- " str " "))
(len (string-length header)))
(string-append (bold header)
(make-string (max 0 (- (current-column-width) len)) #\-))))
(define (test-default-handler status info)
(define indent
(make-string
(+ 4 (cond ((current-test-group)
=> (lambda (group) (or (test-group-indent-width group) 0)))
(else 0)))
#\space))
;; update group info
(cond
((current-test-group)
=> (lambda (group)
(if (not (eq? 'SKIP status))
(test-group-inc! group 'count))
(test-group-inc! group status)
;; maybe wrap long status lines
(let ((width (max (- (current-column-width)
(or (test-group-indent-width group) 0))
4))
(column
(+ (string-length (or (test-group-name group) ""))
(or (test-group-ref group 'count) 0)
1)))
(if (and (zero? (modulo column width))
(not (test-group-ref group 'verbose)))
(display (string-append "\n" (string-copy indent 4))))))))
;; update global failure count for exit status
(cond
((or (eq? status 'FAIL) (eq? status 'ERROR))
(test-failure-count (+ 1 (test-failure-count)))))
(cond
((or (not (current-test-group))
(test-group-ref (current-test-group) 'verbose))
;; display status
(display "[")
(if (not (eq? status 'ERROR)) (display " ")) ; pad
(display (test-status-message status))
(display "]")
(newline)
(test-print-failure indent status info))
((eq? status 'SKIP))
(else
(display (test-status-code status))
(cond
((and (memq status '(FAIL ERROR)) (current-test-group))
=> (lambda (group)
(test-group-push! group 'failures (list indent status info)))))
(cond ((current-test-group)
=> (lambda (group) (test-group-set! group 'trailing #t))))))
(flush-output-port)
status)
(define (test-default-group-reporter group)
(define (plural word n)
(if (= n 1) word (string-append word "s")))
(define (percent n d)
(string-append " (" (number->string (/ (round (* 1000.0 (/ n d))) 10))
"%)"))
(let* ((end-time (current-second))
(start-time (test-group-ref group 'start-time))
(duration (- end-time start-time))
(base-count (or (test-group-ref group 'count) 0))
(base-pass (or (test-group-ref group 'PASS) 0))
(base-fail (or (test-group-ref group 'FAIL) 0))
(base-err (or (test-group-ref group 'ERROR) 0))
(skip (or (test-group-ref group 'SKIP) 0))
(pass (+ base-pass (or (test-group-ref group 'total-pass) 0)))
(fail (+ base-fail (or (test-group-ref group 'total-fail) 0)))
(err (+ base-err (or (test-group-ref group 'total-error) 0)))
(count (+ pass fail err))
(subgroups-count (or (test-group-ref group 'subgroups-count) 0))
(subgroups-skip (or (test-group-ref group 'subgroups-skip) 0))
(subgroups-run (- subgroups-count subgroups-skip))
(subgroups-pass (or (test-group-ref group 'subgroups-pass) 0))
(indent (make-string (or (test-group-indent-width group) 0) #\space)))
(if (and (not (test-group-ref group 'verbose))
(test-group-ref group 'trailing))
(newline))
(cond
((or (positive? count) (positive? subgroups-count))
(if (not (= base-count (+ base-pass base-fail base-err)))
(warning "inconsistent count:"
base-count base-pass base-fail base-err))
(cond
((positive? count)
(display indent)
(display
((if (= pass count) green (lambda (x) x))
(string-append
(number->string pass) " out of " (number->string count)
(percent pass count))))
(display
(string-append
(plural " test" pass) " passed in "
(number->string duration) " seconds"
(cond
((zero? skip) "")
(else (string-append " (" (number->string skip)
(plural " test" skip) " skipped)")))
".\n"))))
(cond ((positive? fail)
(display indent)
(display
(red
(string-append
(number->string fail) (plural " failure" fail)
(percent fail count) ".\n")))))
(cond ((positive? err)
(display indent)
(display
((lambda (x) (underline (red x)))
(string-append
(number->string err) (plural " error" err)
(percent err count) ".\n")))))
(cond
((not (test-group-ref group 'verbose))
(for-each
(lambda (failure)
(display indent)
(display (red
(string-append (display-to-string (cadr failure)) ": ")))
(display (test-get-name! (car (cddr failure))))
(newline)
(apply test-print-failure failure))
(reverse (or (test-group-ref group 'failures) '())))))
(cond
((positive? subgroups-run)
(display indent)
(display
((if (= subgroups-pass subgroups-run)
green (lambda (x) x))
(string-append
(number->string subgroups-pass) " out of "
(number->string subgroups-run)
(percent subgroups-pass subgroups-run))))
(display (plural " subgroup" subgroups-pass))
(display " passed.\n")))))
(cond
((test-group-ref group 'verbose)
(display
(test-header-line
(string-append "done testing " (or (test-group-name group) ""))
(or (test-group-indent-width group) 0)))
(newline)))
(cond
((test-group-ref group 'parent)
=> (lambda (parent)
(test-group-set! parent 'trailing #f)
(test-group-inc! parent 'total-pass pass)
(test-group-inc! parent 'total-fail fail)
(test-group-inc! parent 'total-error err))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parameters
;;> \section{Parameters}
;;> The current test group as started by \scheme{test-group} or
;;> \scheme{test-begin}.
(define current-test-group (make-parameter #f))
;;> If true, show more verbose output per test. Inferred from the
;;> environment variable TEST_VERBOSE.
(define current-test-verbosity
(make-parameter
(cond ((get-environment-variable "TEST_VERBOSE")
=> (lambda (s) (not (member s '("" "0")))))
(else #f))))
;;> The epsilon used for floating point comparisons.
(define current-test-epsilon (make-parameter 1e-5))
;;> The underlying comparator used in testing, defaults to
;;> \scheme{test-equal?}.
(define current-test-comparator (make-parameter test-equal?))
;;> The test applier - what we do with non-skipped tests. Takes the
;;> same signature as \scheme{test-run}, should be responsible for
;;> evaluating the thunks, determining the status of the test, and
;;> passing this information to \scheme{current-test-reporter}.
(define current-test-applier (make-parameter test-default-applier))
;;> The test skipper - what we do with non-skipped tests. This should
;;> not evaluate the thunks and simply pass off to
;;> \scheme{current-test-reporter}.
(define current-test-skipper (make-parameter test-default-skipper))
;;> Takes two arguments, the symbol status of the test and the info
;;> alist. Reports the result of the test and updates bookkeeping in
;;> the current test group for reporting.
(define current-test-reporter (make-parameter test-default-handler))
;;> Takes one argument, a test group, and prints a summary of the test
;;> results for that group.
(define current-test-group-reporter
(make-parameter test-default-group-reporter))
;;> A running count of all test failures and errors across all groups
;;> (and threads). Used by \scheme{test-exit}.
(define test-failure-count (make-parameter 0))
(define test-first-indentation
(make-parameter
(or (cond ((get-environment-variable "TEST_FIRST_INDENTATION")
=> string->number)
(else #f))
1)))
(define test-max-indentation
(make-parameter
(or (cond ((get-environment-variable "TEST_MAX_INDENTATION")
=> string->number)
(else #f))
5)))
(define (string->info-matcher str)
(lambda (info)
(cond ((test-get-name! info)
=> (lambda (n) (string-search str n)))
(else #f))))
(define (string->group-matcher str)
(lambda (group) (string-search str (test-group-name group))))
;; simplified version from SRFI 130
(define (string-split str ch)
(let ((end (string-length str)))
(let lp ((from 0) (to 0) (res '()))
(cond
((>= to end)
(reverse (if (> to from) (cons (substring str from to) res) res)))
((eqv? ch (string-ref str to))
(lp (+ to 1) (+ to 1) (cons (substring str from to) res)))
(else
(lp from (+ to 1) res))))))
(define (getenv-filter-list proc name)
(cond
((get-environment-variable name)
=> (lambda (s)
(let lp ((ls (string-split s #\,))
(res '()))
(cond
((null? ls) (reverse res))
(else
(let* ((s (car ls))
(f (guard
(exn
(else
(warning
(string-append "invalid filter '" s
"' from environment variable: "
name))
(print-exception exn (current-error-port))
#f))
(proc s))))
(lp (cdr ls) (if f (cons f res) res))))))))
(else '())))
(define current-test-group-filters
(make-parameter
(getenv-filter-list string->group-matcher "TEST_GROUP_FILTER")))
(define current-test-group-removers
(make-parameter
(getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE")))
;;> Parameters controlling which test groups are skipped. Each
;;> parameter is a list of procedures of one argument, a test group
;;> info, which can be queried with \var{test-group-name} and
;;> \var{test-group-ref}. Analogous to SRFI 1, a filter selects a
;;> group for inclusion and a removers for exclusion. The defaults
;;> are set automatically from the environment variables
;;> TEST_GROUP_FILTER and TEST_GROUP_REMOVE, which should be
;;> comma-delimited lists of strings which are checked for a substring
;;> match in the test group name. A test group is skipped if it does
;;> not match any filter and:
;;> \itemlist[
;;> \item{its parent group is skipped, or}
;;> \item{it matches a remover, or}
;;> \item{no removers are specified but some filters are}
;;> ]
;;/
(define current-test-filters
(make-parameter (getenv-filter-list string->info-matcher "TEST_FILTER")))
(define current-test-removers
(make-parameter (getenv-filter-list string->info-matcher "TEST_REMOVE")))
;;> Parameters controlling which tests are skipped. Each parameter is
;;> a list of procedures of one argument, a test info alist, which can
;;> be queried with \scheme{test-get-name!} or \scheme{assq}.
;;> Analogous to SRFI 1, a filter selects a test for inclusion and a
;;> removers for exclusion. The defaults are set automatically from
;;> the environment variables TEST_FILTER and TEST_REMOVE, which
;;> should be comma-delimited lists of strings which are checked for a
;;> substring match in the test name. A test is skipped if its group
;;> is skipped, or if it does not match a filter and:
;;> \itemlist[
;;> \item{it matches a remover, or}
;;> \item{no removers are specified but some filters are}
;;> ]
;;/
;;> Parameter controlling the current column width for test output,
;;> can be set from the environment variable TEST_COLUMN_WIDTH,
;;> otherwise defaults to 78. For portability of implementation (and
;;> resulting output), does not attempt to use termios to determine
;;> the actual available width.
(define current-column-width
(make-parameter
(or (cond ((get-environment-variable "TEST_COLUMN_WIDTH")
=> string->number)
(else #f))
78)))

39
snow/chibi/test.sld Normal file
View File

@ -0,0 +1,39 @@
(define-library (chibi test)
(export
;; basic interface
test test-equal test-error test-assert test-not test-values
test-group current-test-group
test-begin test-end test-syntax-error test-propagate-info
test-run test-exit test-equal?
;; test and group data
test-get-name! test-group-name test-group-ref
test-group-set! test-group-inc! test-group-push!
;; parameters
current-test-verbosity
current-test-applier current-test-skipper current-test-reporter
current-test-group-reporter test-failure-count
current-test-epsilon current-test-comparator
current-test-filters current-test-removers
current-test-group-filters current-test-group-removers
current-column-width)
(import (scheme base)
(scheme write)
(scheme complex)
(scheme process-context)
(scheme time)
(chibi diff)
(chibi term ansi))
(cond-expand
(chibi
(import (only (chibi) pair-source print-exception)))
(chicken
(import (only (chicken) print-error-message))
(begin
(define (pair-source x) #f)
(define print-exception print-error-message)))
(else
(begin
(define (pair-source x) #f)
(define print-exception write))))
(include "test.scm"))

1647
snow/srfi/1.scm Normal file
View File

File diff suppressed because it is too large Load Diff

156
snow/srfi/1.sld Normal file
View File

@ -0,0 +1,156 @@
(define-library
(srfi 1)
(import (scheme base)
(scheme cxr)
(srfi 8))
(export
;cons
;list
xcons
cons*
;make-list
list-tabulate
;list-copy
circular-list
iota
;pair?
;null?
proper-list?
circular-list?
dotted-list?
not-pair?
null-list?
list=
;car
;cdr
;cdar
;cddr
;caar
;caadr
;cadar
;caddr
;cdaar
;cdadr
;cddar
;cddr
;caaaar
;caaadr
;caadar
;caaddr
;cadaar
;cadadr
;caddar
;cadddr
;cdaaar
;cdaadr
;cdadar
;cdaddr
;cddaar
;cddadr
;cdddar
;cddddr
;list-ref
first
second
third
fourth
fifth
sixth
seventh
eighth
ninth
tenth
car+cdr
take
drop
take-right
drop-right
take!
drop-right!
split-at
split-at!
last
last-pair
;length
length+
;append
concatenate
;reverse
append!
concatenate!
reverse!
append-reverse
append-reverse!
zip
unzip1
unzip2
unzip3
unzip4
unzip5
count
;map
;for-each
fold
unfold
pair-fold
reduce
fold-right
unfold-right
pair-fold-right
reduce-right
append-map
append-map!
map!
pair-for-each
filter-map
map-in-order
filter
partition
remove
filter!
partition!
remove!
;member
;memq
;memv
find
find-tail
any
every
list-index
take-while
drop-while
take-while!
span
break
span!
break!
delete
delete-duplicates
delete!
delete-duplicates!
;assoc
;assq
;assv
alist-cons
alist-copy
alist-delete
alist-delete!
lset<=
lset=
lset-adjoin
lset-union
lset-union!
lset-intersection
lset-intersection!
lset-difference
lset-difference!
lset-xor
lset-xor!
lset-diff+intersection
lset-diff+intersection!
;set-car!
;set-cdr!
)
(begin
(include "1.scm")))

5
snow/srfi/8.scm Normal file
View File

@ -0,0 +1,5 @@
(define-syntax receive
(syntax-rules ()
((receive formals expression body ...)
(call-with-values (lambda () expression)
(lambda formals body ...)))))

6
snow/srfi/8.sld Normal file
View File

@ -0,0 +1,6 @@
(define-library
(srfi 8)
(import (scheme base))
(export receive)
(begin
(include "8.scm")))

35
templates/Jenkinsfile-bottom Normal file
View File

@ -0,0 +1,35 @@
stage("Report") {
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
unstash 'reports'
sh './report'
archiveArtifacts artifacts: 'reports/*.html'
publishHTML (target : [allowMissing: false,
alwaysLinkToLastBuild: false,
keepAll: true,
reportDir: 'reports',
reportFiles: '*.html,*.css',
reportName: 'R7RS-SRFI Test Report',
reportTitles: 'R7RS-SRFI Test Report'])
}
}
}
}
post {
always {
archiveArtifacts artifacts: 'reports/*.log'
archiveArtifacts artifacts: 'reports/*.html'
sh 'for f in srfi/*.sld; do snow-chibi package "$f"; done'
archiveArtifacts artifacts: '*.tgz'
archiveArtifacts artifacts: 'srfi/*.tgz'
deleteDir()
}
failure {
archiveArtifacts artifacts: 'reports/*.html'
archiveArtifacts artifacts: 'reports/*.log'
deleteDir()
}
}
}

2
templates/Jenkinsfile-job Normal file
View File

@ -0,0 +1,2 @@
{{#library-command}}sh '{{{library-command}}}'{{/library-command}}
sh '{{{command}}}'

7
templates/Jenkinsfile-job-bottom Normal file
View File

@ -0,0 +1,7 @@
sh 'for f in *.log; do cp -- "$f" "reports/{{name}}-$f"; done'
sh 'ls reports'
stash name: 'reports', includes: 'reports/*'
archiveArtifacts artifacts: 'reports/*.log'
}
}
}

23
templates/Jenkinsfile-job-top Normal file
View File

@ -0,0 +1,23 @@
stage("{{name}}") {
agent {
docker {
image '{{{dockerimage}}}'
reuseNode true
}
}
when {
expression {
params.BUILD_IMPLEMENTATION == 'all' || params.BUILD_IMPLEMENTATION == '{{name}}'
}
}
environment {
MITSCHEME_LIBRARY_PATH = "${env.MITSCHEME_LIBRARY_PATH}:${env.PWD}:${env.PWD}/srfi"
TR7_LIB_PATH = "${env.TR7_LIB_PATH}:${env.PWD}:${env.PWD}/srfi"
}
steps {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh 'find . -maxdepth 1 -name "*.log" -delete'
sh 'find . -name "*.so" -delete'
sh 'find . -name "*.o" -delete'
sh 'find . -name "*.o" -delete'
unstash 'tests'

49
templates/Jenkinsfile-top Normal file
View File

@ -0,0 +1,49 @@
pipeline {
agent {
dockerfile {
filename 'Dockerfile.jenkins'
dir '.'
args '--privileged -v /var/run/docker.sock:/var/run/docker.sock'
}
}
options {
buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10'))
}
parameters {
choice(name: 'BUILD_IMPLEMENTATION',
description: 'Build',
choices: [
'all',
'chibi',
'chicken',
'cyclone',
'gambit',
'gauche',
'guile',
'kawa',
'loko',
'mit-scheme',
'sagittarius',
'stklos',
'skint',
'tr7',
])
}
stages {
stage("Init") {
steps {
sh 'rm -rf srfi-test && git clone https://github.com/srfi-explorations/srfi-test.git'
sh 'mkdir -p reports'
sh 'touch reports/placeholder'
stash name: 'reports', includes: 'reports/*'
sh 'echo "<h1>Test results</h1>" > reports/results.html'
sh '(cd srfi-test && make clean build)'
sh 'tree srfi-test'
stash name: 'tests', includes: 'srfi-test/*'
}
}

16
templates/Makefile-bottom Normal file
View File

@ -0,0 +1,16 @@
clean:
find . -name "*.so" -delete
find . -name "*.c" -delete
find . -name "*.o*" -delete
find . -name "*.so" -delete
find . -name "*.dep" -delete
find . -name "*.zo" -delete
find . -name "*.meta" -delete
find . -name "compiled" -delete
find . -name "srfi.*.sld" -delete
find . -name "srfi.*.scm" -delete
find . -name "srfi-*.sld" -delete
find . -name "srfi.*.import.scm" -delete
find . -name "srfi-*.import.scm" -delete
find . -name "*.log" -delete
find . -name "test-prefix.txt" -delete

4
templates/Makefile-job Normal file
View File

@ -0,0 +1,4 @@
test-{{name}}-{{test-name}}:
{{#library-command}}docker run -it -v ${PWD}:/workdir:z schemers/{{name}} bash -c "cd workdir && {{{library-command}}}"{{/library-command}}
docker run -it -v ${PWD}:/workdir:z schemers/{{name}} bash -c "cd workdir && {{{command}}}"

0
templates/Makefile-top Normal file
View File

17
templates/Report-bottom Normal file
View File

@ -0,0 +1,17 @@
</table>
<ul>
Numbers
<li># of expected passes</li>
<li># of expected failures</li>
<li># of unexpected failures</li>
<li># of skipped tests</li>
</ul>
<ul>
Colors
<li>Red: # of unexpected failures > 0</li>
<li>Yellow: # of skipped tests > 0</li>
<li>Green: none of the above</li>
</ul>
</body>
</html>

6
templates/Report-row Normal file
View File

@ -0,0 +1,6 @@
<td style="background-color:{{color}}">
{{expected-passes}}
{{expected-failures}}
{{unexpected-failures}}
{{skipped-tests}}
</td>

16
templates/Report-top Normal file
View File

@ -0,0 +1,16 @@
<!DOCTYPE html>
<html>
<head>
<title>R7RS-SRFI Test results</title>
<style>
tr:nth-child(even) {
background-color: #D6EEEE;
}
td {
border: 1px solid black;
}
</style>
</head>
<body>
<table>
<caption>R7RS-SRFI Test results</caption>

985
test.scm Normal file
View File

@ -0,0 +1,985 @@
;; Copyright (c) 2010-2020 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> Simple but extensible testing framework with advanced reporting.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; list utilities
;; Simplified version of SRFI-1 any.
(define (any pred ls)
(and (pair? ls)
(or (pred (car ls))
(any pred (cdr ls)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exception utilities
(define (warning msg . args)
(display msg (current-error-port))
(for-each (lambda (x)
(write-char #\space (current-error-port))
(write x (current-error-port)))
args)
(newline (current-error-port)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; string utilities
(define (string-search pat str)
(let* ((pat-len (string-length pat))
(limit (- (string-length str) pat-len)))
(let lp1 ((i 0))
(cond
((>= i limit) #f)
(else
(let lp2 ((j i) (k 0))
(cond ((>= k pat-len) #t)
((not (eqv? (string-ref str j) (string-ref pat k)))
(lp1 (+ i 1)))
(else (lp2 (+ j 1) (+ k 1))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; test interface
;;> \section{Testing}
;;> \macro{(test [name] expect expr)}
;;> The primary interface to testing. Evaluate \var{expr} and check
;;> that it is equal to \var{expect}, and report the result, using
;;> \var{name} or a printed summary of \var{expr}.
;;>
;;> If used inside a group this will contribute to the overall group
;;> reporting, but can be used standalone:
;;>
;;> \example{(test 4 (+ 2 2))}
;;> \example{(test "add two and two" 4 (+ 2 2))}
;;> \example{(test 3 (+ 2 2))}
;;> \example{(test 4 (+ 2 "2"))}
;;>
;;> The equality comparison is made with
;;> \scheme{current-test-comparator}, defaulting to
;;> \scheme{test-equal?}, which is the same as \scheme{equal?} but
;;> more permissive on floating point comparisons). Returns the
;;> status of the test (one of the symbols \scheme{'PASS},
;;> \scheme{'FAIL}, \scheme{'SKIP}, \scheme{'ERROR}).
(define-syntax test
(syntax-rules (quote)
((test expect expr)
(test #f expect expr))
((test name expect (expr ...))
(test-propagate-info name expect (expr ...) ()))
((test name 'expect expr)
(test-propagate-info name 'expect expr ()))
((test name (expect ...) expr)
(test-syntax-error
'test
"the test expression should come last: (test <expected> (<expr> ...)) "
(test name (expect ...) expr)))
((test name expect expr)
(test-propagate-info name expect expr ()))
((test a ...)
(test-syntax-error 'test "test requires 2 or 3 arguments" (test a ...)))))
;;> \macro{(test-equal equal [name] expect expr)}
;;> Equivalent to test, using \var{equal} for comparison instead of
;;> \scheme{equal?}.
(define-syntax test-equal
(syntax-rules ()
((test-equal equal . args)
(parameterize ((current-test-comparator equal))
(test . args)))))
;;> \macro{(test-assert [name] expr)}
;;> Like \scheme{test} but evaluates \var{expr} and checks that it's true.
(define-syntax test-assert
(syntax-rules ()
((_ expr)
(test-assert #f expr))
((_ name expr)
(test-propagate-info name #f expr ((assertion . #t))))
((test a ...)
(test-syntax-error 'test-assert "1 or 2 arguments required"
(test a ...)))))
;;> \macro{(test-not [name] expr)}
;;> Like \scheme{test} but evaluates \var{expr} and checks that it's false.
(define-syntax test-not
(syntax-rules ()
((_ expr) (test-assert (not expr)))
((_ name expr) (test-assert name (not expr)))))
;;> \macro{(test-values [name] expect expr)}
;;> Like \scheme{test} but \var{expect} and \var{expr} can both
;;> return multiple values.
(define-syntax test-values
(syntax-rules ()
((_ expect expr)
(test-values #f expect expr))
((_ name expect expr)
(test name (call-with-values (lambda () expect) (lambda results results))
(call-with-values (lambda () expr) (lambda results results))))))
;;> \macro{(test-error [name] expr)}
;;> Like \scheme{test} but evaluates \var{expr} and checks that it
;;> raises an error.
(define-syntax test-error
(syntax-rules ()
((_ expr)
(test-error #f expr))
((_ name expr)
(test-propagate-info name #f expr ((expect-error . #t))))
((test a ...)
(test-syntax-error 'test-error "1 or 2 arguments required"
(test a ...)))))
;;> Low-level macro to pass alist info to the underlying \var{test-run}.
(define-syntax test-propagate-info
(syntax-rules ()
;; TODO: Extract interesting variables so we can show their values
;; on failure. Vars are empty for now.
((test-propagate-info name expect expr info)
(test-vars () name expect expr info))))
(define-syntax test-vars
(syntax-rules ()
((_ (vars ...) n expect expr ((key . val) ...))
(test-run (lambda () expect)
(lambda () expr)
`((name . ,n)
(source . expr)
(var-names . (vars ...))
(var-values . ,(list vars ...))
(key . val) ...)))))
;;> The procedural interface to testing. \var{expect} and \var{expr}
;;> should be thunks, and \var{info} is an alist of properties used in
;;> test reporting.
(define (test-run expect expr info)
(let ((info (test-expand-info info)))
(if (and (cond ((current-test-group)
=> (lambda (g) (not (test-group-ref g 'skip-group?))))
(else #t))
(or (and (not (any (lambda (f) (f info)) (current-test-removers)))
(or (pair? (current-test-removers))
(null? (current-test-filters))))
(any (lambda (f) (f info)) (current-test-filters))))
((current-test-applier) expect expr info)
((current-test-skipper) info))))
;;> Returns true if either \scheme{(equal? expect res)}, or
;;> \var{expect} is inexact and \var{res} is within
;;> \scheme{current-test-epsilon} of \var{expect}.
(define (test-equal? expect res)
(or (equal? expect res)
(if (real? expect)
(and (inexact? expect)
(real? res)
;; tests which expect an inexact value can
;; accept an equivalent exact value
;; (inexact? res)
(approx-equal? expect res (current-test-epsilon)))
(and (complex? res)
(complex? expect)
(test-equal? (real-part expect) (real-part res))
(test-equal? (imag-part expect) (imag-part res))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; group interface
;;> \section{Test Groups}
;;> Tests can be collected in groups for
;;> Wraps \var{body} as a single test group, which can be filtered
;;> and summarized separately.
;;> \example{
;;> (test-group "pi"
;;> (test 3.14159 (acos -1))
;;> (test 3 (acos -1))
;;> (test 3.14159 (acos "-1")))
;;> }
(define-syntax test-group
(syntax-rules ()
((_ name-expr body ...)
(let ((name name-expr)
(old-group (current-test-group)))
(when (not (string? name))
(error "a name is required, got " 'name-expr name))
(test-begin name)
(guard
(exn
(else
(warning "error in group outside of tests")
(print-exception exn (current-error-port))
(test-group-inc! (current-test-group) 'count)
(test-group-inc! (current-test-group) 'ERROR)
(test-failure-count (+ 1 (test-failure-count)))))
body ...)
(test-end name)
(current-test-group old-group)))))
;;> Begin testing a new group until the closing \scheme{(test-end)}.
(define (test-begin . o)
(let* ((name (if (pair? o) (car o) ""))
(parent (current-test-group))
(group (make-test-group name parent)))
;; include a newline if we are directly nested in a parent with no
;; tests yet
(when (and parent
(zero? (test-group-ref parent 'subgroups-count 0))
(not (test-group-ref parent 'verbose)))
(newline))
;; header
(cond
((test-group-ref group 'skip-group?)
(display (make-string (or (test-group-indent-width group) 0) #\space))
(display (strikethrough (bold (string-append name ":"))))
(display " SKIP"))
((test-group-ref group 'verbose)
(display
(test-header-line
(string-append "testing " name)
(or (test-group-indent-width group) 0))))
(else
(display
(string-append
(make-string (or (test-group-indent-width group) 0)
#\space)
(bold (string-append name ": "))))))
;; set the current test group
(current-test-group group)))
;;> Ends testing group introduced with \scheme{(test-begin)}, and
;;> summarizes the results. The \var{name} is optional, but if
;;> present should match the corresponding \scheme{test-begin} name,
;;> or a warning is printed.
(define (test-end . o)
(let ((name (and (pair? o) (car o))))
(cond
((current-test-group)
=> (lambda (group)
(when (and name (not (equal? name (test-group-name group))))
(warning "mismatched test-end:" name (test-group-name group)))
(let ((parent (test-group-ref group 'parent)))
(when (and (test-group-ref group 'skip-group?)
(zero? (test-group-ref group 'subgroups-count 0)))
(newline))
;; only report if there's something to say
((current-test-group-reporter) group)
(when parent
(test-group-inc! parent 'subgroups-count)
(cond
((test-group-ref group 'skip-group?)
(test-group-inc! parent 'subgroups-skip))
((and (zero? (test-group-ref group 'FAIL 0))
(zero? (test-group-ref group 'ERROR 0))
(= (test-group-ref group 'subgroups-pass 0)
(test-group-ref group 'subgroups-count 0)))
(test-group-inc! parent 'subgroups-pass))))
(current-test-group parent)
group))))))
;;> Exits with a failure status if any tests have failed,
;;> and a successful status otherwise.
(define (test-exit)
(when (current-test-group)
(warning "calling test-exit with unfinished test group:"
(test-group-name (current-test-group))))
(exit (zero? (test-failure-count))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utilities
(define-syntax test-syntax-error
(syntax-rules ()
((_) (syntax-error "invalid use of test-syntax-error"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; test-group representation
;;> \section{Accessors}
;; (name (prop value) ...)
(define (make-test-group name . o)
(let ((parent (and (pair? o) (car o)))
(group (list name (cons 'start-time (current-second)))))
(test-group-set! group 'parent parent)
(test-group-set! group 'verbose
(if parent
(test-group-ref parent 'verbose)
(current-test-verbosity)))
(test-group-set! group 'level
(if parent
(+ 1 (test-group-ref parent 'level 0))
0))
(test-group-set!
group
'skip-group?
(and (or (and parent (test-group-ref parent 'skip-group?))
(any (lambda (f) (f group)) (current-test-group-removers))
(and (null? (current-test-group-removers))
(pair? (current-test-group-filters))))
(not (any (lambda (f) (f group)) (current-test-group-filters)))))
group))
;;> Returns the name of a test group info object.
(define (test-group-name group) (car group))
;;> Returns the value of a \var{field} in a test var{group} info
;;> object. \var{field} should be a symbol, and predefined fields
;;> include \scheme{parent}, \scheme{verbose}, \scheme{level},
;;> \scheme{start-time}, \scheme{skip-group?}, \scheme{count},
;;> \scheme{total-pass}, \scheme{total-fail}, \scheme{total-error}.
(define (test-group-ref group field . o)
(if group
(apply assq-ref (cdr group) field o)
(and (pair? o) (car o))))
;;> Sets the value of a \var{field} in a test \var{group} info object.
(define (test-group-set! group field value)
(cond
((assq field (cdr group))
=> (lambda (x) (set-cdr! x value)))
(else (set-cdr! group (cons (cons field value) (cdr group))))))
;;> Increments the value of a \var{field} in a test \var{group} info
;;> object by \var{amount}, defaulting to 1.
(define (test-group-inc! group field . o)
(let ((amount (if (pair? o) (car o) 1)))
(cond
((assq field (cdr group))
=> (lambda (x) (set-cdr! x (+ amount (cdr x)))))
(else (set-cdr! group (cons (cons field amount) (cdr group)))))))
;;> Updates a \var{field} in a test group info object by consing
;;> \var{value} onto it.
(define (test-group-push! group field value)
(cond
((assq field (cdr group))
=> (lambda (x) (set-cdr! x (cons value (cdr x)))))
(else (set-cdr! group (cons (cons field (list value)) (cdr group))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utilities
(define (assq-ref ls key . o)
(cond ((assq key ls) => cdr)
((pair? o) (car o))
(else #f)))
(define (approx-equal? a b epsilon)
(cond
((> (abs a) (abs b))
(approx-equal? b a epsilon))
((zero? a)
(< (abs b) epsilon))
(else
(< (abs (/ (- a b) b)) epsilon))))
(define (call-with-output-string proc)
(let ((out (open-output-string)))
(proc out)
(get-output-string out)))
;; partial pretty printing to abbreviate `quote' forms and the like
(define (write-to-string x)
(call-with-output-string
(lambda (out)
(let wr ((x x))
(if (pair? x)
(cond
((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))
(assq (car x)
'((quote . "'") (quasiquote . "`")
(unquote . ",") (unquote-splicing . ",@"))))
=> (lambda (s) (display (cdr s) out) (wr (cadr x))))
(else
(display "(" out)
(wr (car x))
(let lp ((ls (cdr x)))
(cond ((pair? ls)
(display " " out)
(wr (car ls))
(lp (cdr ls)))
((not (null? ls))
(display " . " out)
(write ls out))))
(display ")" out)))
(write x out))))))
(define (display-to-string x)
(if (string? x) x (call-with-output-string (lambda (out) (display x out)))))
;; if we need to truncate, try first dropping let's to get at the
;; heart of the expression
(define (truncate-source x width . o)
(let* ((str (write-to-string x))
(len (string-length str)))
(cond
((<= len width)
str)
((and (pair? x) (eq? 'let (car x)))
(if (and (pair? o) (car o))
(truncate-source (car (reverse x)) width #t)
(string-append "..."
(truncate-source (car (reverse x)) (- width 3) #t))))
((and (pair? x) (eq? 'call-with-current-continuation (car x)))
(truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
((and (pair? x) (eq? 'call-with-values (car x)))
(string-append
"..."
(truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (car (cadr x))))
(car (reverse (cadr x)))
(cadr x))
(- width 3)
#t)))
(else
(string-append
(substring str 0 (min (max 0 (- width 3)) (string-length str)))
"...")))))
(define (test-get-name! info)
(or
(assq-ref info 'name)
(assq-ref info 'gen-name)
(let ((name
(cond
((assq 'source info)
=> (lambda (src)
(truncate-source (cdr src) (- (current-column-width) 12))))
((current-test-group)
=> (lambda (g)
(display "no source in: " (current-error-port))
(write info (current-error-port))
(display "\n" (current-error-port))
(string-append
"test-"
(number->string (test-group-ref g 'count 0)))))
(else ""))))
(if (pair? info)
(set-cdr! info (cons (cons 'gen-name name) (cdr info))))
name)))
(define (test-print-name info . indent)
(let ((width (- (current-column-width)
(or (and (pair? indent) (car indent)) 0)))
(name (test-get-name! info)))
(display name)
(display " ")
(let ((diff (- width 9 (string-length name))))
(cond
((positive? diff)
(display (make-string diff #\.)))))
(display " ")
(flush-output-port)))
(define (test-group-indent-width group)
(let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0)
(test-first-indentation))))))
(* 4 (min level (test-max-indentation)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-expand-info info)
(let ((expr (assq-ref info 'source)))
(if (and (pair? expr)
(pair-source expr)
(not (assq-ref info 'line-number)))
`((file-name . ,(car (pair-source expr)))
(line-number . ,(cdr (pair-source expr)))
,@info)
info)))
(define (test-default-applier expect expr info)
(let* ((group (current-test-group))
(indent (and group (test-group-indent-width group))))
(cond
((or (not group) (test-group-ref group 'verbose))
(if (and indent (positive? indent))
(display (make-string indent #\space)))
(test-print-name info indent)))
(let ((expect-val
(guard
(exn
(else
(warning "bad expect value")
(print-exception exn (current-error-port))
#f))
(expect))))
(guard
(exn
(else
((current-test-reporter)
(if (assq-ref info 'expect-error) 'PASS 'ERROR)
(append `((exception . ,exn)) info))))
(let ((res (expr)))
(let ((status
(if (and (not (assq-ref info 'expect-error))
(if (assq-ref info 'assertion)
res
((current-test-comparator) expect-val res)))
'PASS
'FAIL))
(info `((result . ,res) (expected . ,expect-val) ,@info)))
((current-test-reporter) status info)))))))
(define (test-default-skipper info)
((current-test-reporter) 'SKIP info))
(define (test-status-color status)
(case status
((ERROR) (lambda (x) (underline (red x))))
((FAIL) red)
((SKIP) yellow)
(else (lambda (x) x))))
(define (test-status-message status)
((test-status-color status) (symbol->string status)))
(define (test-status-code status)
((test-status-color status)
;; alternatively: ❗, ✗, ‒, ✓
;; unfortunately, these have ambiguous width
(case status
((ERROR) "!")
((FAIL) "x")
((SKIP) "-")
(else "."))))
(define (display-expected/actual expected actual)
(let* ((e-str (write-to-string expected))
(a-str (write-to-string actual))
(diff (diff e-str a-str read-char)))
(write-string "expected ")
(write-string (edits->string/color (car diff) (car (cddr diff)) 1))
(write-string " but got ")
(write-string (edits->string/color (cadr diff) (car (cddr diff)) 2))))
(define (test-print-explanation indent status info)
(cond
((eq? status 'ERROR)
(display indent)
(cond ((assq 'exception info)
=> (lambda (e)
(print-exception (cdr e) (current-output-port))))))
((and (eq? status 'FAIL) (assq-ref info 'assertion))
(display indent)
(display "assertion failed\n"))
((and (eq? status 'FAIL) (assq-ref info 'expect-error))
(display indent)
(display "expected an error but got ")
(write (assq-ref info 'result)) (newline))
((eq? status 'FAIL)
(display indent)
(display-expected/actual (assq-ref info 'expected) (assq-ref info 'result))
(newline)))
;; print variables
(cond
((and (memq status '(FAIL ERROR)) (assq-ref info 'var-names))
=> (lambda (names)
(let ((values (assq-ref info 'var-values)))
(if (and (pair? names)
(pair? values)
(= (length names) (length values)))
(let ((indent2
(string-append indent (make-string 2 #\space))))
(for-each
(lambda (name value)
(display indent2) (write name) (display ": ")
(write value) (newline))
names values))))))))
(define (test-print-source indent status info)
(case status
((FAIL ERROR)
(cond
((assq-ref info 'line-number)
=> (lambda (line)
(display " on line ")
(write line)
(cond ((assq-ref info 'file-name)
=> (lambda (file) (display " of file ") (write file))))
(newline))))
(cond
((assq-ref info 'source)
=> (lambda (s)
(cond
((or (assq-ref info 'name)
(> (string-length (write-to-string s))
(current-column-width)))
(display (write-to-string s))
(newline))))))
(cond
((assq-ref info 'values)
=> (lambda (v)
(for-each
(lambda (v)
(display " ") (display (car v))
(display ": ") (write (cdr v)) (newline))
v)))))))
(define (test-print-failure indent status info)
;; display status explanation
(test-print-explanation indent status info)
;; display line, source and values info
(test-print-source indent status info))
(define (test-header-line str . indent)
(let* ((header (string-append
(make-string (if (pair? indent) (car indent) 0) #\space)
"-- " str " "))
(len (string-length header)))
(string-append (bold header)
(make-string (max 0 (- (current-column-width) len)) #\-))))
(define (test-default-handler status info)
(define indent
(make-string
(+ 4 (cond ((current-test-group)
=> (lambda (group) (or (test-group-indent-width group) 0)))
(else 0)))
#\space))
;; update group info
(cond
((current-test-group)
=> (lambda (group)
(if (not (eq? 'SKIP status))
(test-group-inc! group 'count))
(test-group-inc! group status)
;; maybe wrap long status lines
(let ((width (max (- (current-column-width)
(or (test-group-indent-width group) 0))
4))
(column
(+ (string-length (or (test-group-name group) ""))
(or (test-group-ref group 'count) 0)
1)))
(if (and (zero? (modulo column width))
(not (test-group-ref group 'verbose)))
(display (string-append "\n" (string-copy indent 4))))))))
;; update global failure count for exit status
(cond
((or (eq? status 'FAIL) (eq? status 'ERROR))
(test-failure-count (+ 1 (test-failure-count)))))
(cond
((or (not (current-test-group))
(test-group-ref (current-test-group) 'verbose))
;; display status
(display "[")
(if (not (eq? status 'ERROR)) (display " ")) ; pad
(display (test-status-message status))
(display "]")
(newline)
(test-print-failure indent status info))
((eq? status 'SKIP))
(else
(display (test-status-code status))
(cond
((and (memq status '(FAIL ERROR)) (current-test-group))
=> (lambda (group)
(test-group-push! group 'failures (list indent status info)))))
(cond ((current-test-group)
=> (lambda (group) (test-group-set! group 'trailing #t))))))
(flush-output-port)
status)
(define (test-default-group-reporter group)
(define (plural word n)
(if (= n 1) word (string-append word "s")))
(define (percent n d)
(string-append " (" (number->string (/ (round (* 1000.0 (/ n d))) 10))
"%)"))
(let* ((end-time (current-second))
(start-time (test-group-ref group 'start-time))
(duration (- end-time start-time))
(base-count (or (test-group-ref group 'count) 0))
(base-pass (or (test-group-ref group 'PASS) 0))
(base-fail (or (test-group-ref group 'FAIL) 0))
(base-err (or (test-group-ref group 'ERROR) 0))
(skip (or (test-group-ref group 'SKIP) 0))
(pass (+ base-pass (or (test-group-ref group 'total-pass) 0)))
(fail (+ base-fail (or (test-group-ref group 'total-fail) 0)))
(err (+ base-err (or (test-group-ref group 'total-error) 0)))
(count (+ pass fail err))
(subgroups-count (or (test-group-ref group 'subgroups-count) 0))
(subgroups-skip (or (test-group-ref group 'subgroups-skip) 0))
(subgroups-run (- subgroups-count subgroups-skip))
(subgroups-pass (or (test-group-ref group 'subgroups-pass) 0))
(indent (make-string (or (test-group-indent-width group) 0) #\space)))
(if (and (not (test-group-ref group 'verbose))
(test-group-ref group 'trailing))
(newline))
(cond
((or (positive? count) (positive? subgroups-count))
(if (not (= base-count (+ base-pass base-fail base-err)))
(warning "inconsistent count:"
base-count base-pass base-fail base-err))
(cond
((positive? count)
(display indent)
(display
((if (= pass count) green (lambda (x) x))
(string-append
(number->string pass) " out of " (number->string count)
(percent pass count))))
(display
(string-append
(plural " test" pass) " passed in "
(number->string duration) " seconds"
(cond
((zero? skip) "")
(else (string-append " (" (number->string skip)
(plural " test" skip) " skipped)")))
".\n"))))
(cond ((positive? fail)
(display indent)
(display
(red
(string-append
(number->string fail) (plural " failure" fail)
(percent fail count) ".\n")))))
(cond ((positive? err)
(display indent)
(display
((lambda (x) (underline (red x)))
(string-append
(number->string err) (plural " error" err)
(percent err count) ".\n")))))
(cond
((not (test-group-ref group 'verbose))
(for-each
(lambda (failure)
(display indent)
(display (red
(string-append (display-to-string (cadr failure)) ": ")))
(display (test-get-name! (car (cddr failure))))
(newline)
(apply test-print-failure failure))
(reverse (or (test-group-ref group 'failures) '())))))
(cond
((positive? subgroups-run)
(display indent)
(display
((if (= subgroups-pass subgroups-run)
green (lambda (x) x))
(string-append
(number->string subgroups-pass) " out of "
(number->string subgroups-run)
(percent subgroups-pass subgroups-run))))
(display (plural " subgroup" subgroups-pass))
(display " passed.\n")))))
(cond
((test-group-ref group 'verbose)
(display
(test-header-line
(string-append "done testing " (or (test-group-name group) ""))
(or (test-group-indent-width group) 0)))
(newline)))
(cond
((test-group-ref group 'parent)
=> (lambda (parent)
(test-group-set! parent 'trailing #f)
(test-group-inc! parent 'total-pass pass)
(test-group-inc! parent 'total-fail fail)
(test-group-inc! parent 'total-error err))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parameters
;;> \section{Parameters}
;;> The current test group as started by \scheme{test-group} or
;;> \scheme{test-begin}.
(define current-test-group (make-parameter #f))
;;> If true, show more verbose output per test. Inferred from the
;;> environment variable TEST_VERBOSE.
(define current-test-verbosity
(make-parameter
(cond ((get-environment-variable "TEST_VERBOSE")
=> (lambda (s) (not (member s '("" "0")))))
(else #f))))
;;> The epsilon used for floating point comparisons.
(define current-test-epsilon (make-parameter 1e-5))
;;> The underlying comparator used in testing, defaults to
;;> \scheme{test-equal?}.
(define current-test-comparator (make-parameter test-equal?))
;;> The test applier - what we do with non-skipped tests. Takes the
;;> same signature as \scheme{test-run}, should be responsible for
;;> evaluating the thunks, determining the status of the test, and
;;> passing this information to \scheme{current-test-reporter}.
(define current-test-applier (make-parameter test-default-applier))
;;> The test skipper - what we do with non-skipped tests. This should
;;> not evaluate the thunks and simply pass off to
;;> \scheme{current-test-reporter}.
(define current-test-skipper (make-parameter test-default-skipper))
;;> Takes two arguments, the symbol status of the test and the info
;;> alist. Reports the result of the test and updates bookkeeping in
;;> the current test group for reporting.
(define current-test-reporter (make-parameter test-default-handler))
;;> Takes one argument, a test group, and prints a summary of the test
;;> results for that group.
(define current-test-group-reporter
(make-parameter test-default-group-reporter))
;;> A running count of all test failures and errors across all groups
;;> (and threads). Used by \scheme{test-exit}.
(define test-failure-count (make-parameter 0))
(define test-first-indentation
(make-parameter
(or (cond ((get-environment-variable "TEST_FIRST_INDENTATION")
=> string->number)
(else #f))
1)))
(define test-max-indentation
(make-parameter
(or (cond ((get-environment-variable "TEST_MAX_INDENTATION")
=> string->number)
(else #f))
5)))
(define (string->info-matcher str)
(lambda (info)
(cond ((test-get-name! info)
=> (lambda (n) (string-search str n)))
(else #f))))
(define (string->group-matcher str)
(lambda (group) (string-search str (test-group-name group))))
;; simplified version from SRFI 130
(define (string-split str ch)
(let ((end (string-length str)))
(let lp ((from 0) (to 0) (res '()))
(cond
((>= to end)
(reverse (if (> to from) (cons (substring str from to) res) res)))
((eqv? ch (string-ref str to))
(lp (+ to 1) (+ to 1) (cons (substring str from to) res)))
(else
(lp from (+ to 1) res))))))
(define (getenv-filter-list proc name)
(cond
((get-environment-variable name)
=> (lambda (s)
(let lp ((ls (string-split s #\,))
(res '()))
(cond
((null? ls) (reverse res))
(else
(let* ((s (car ls))
(f (guard
(exn
(else
(warning
(string-append "invalid filter '" s
"' from environment variable: "
name))
(print-exception exn (current-error-port))
#f))
(proc s))))
(lp (cdr ls) (if f (cons f res) res))))))))
(else '())))
(define current-test-group-filters
(make-parameter
(getenv-filter-list string->group-matcher "TEST_GROUP_FILTER")))
(define current-test-group-removers
(make-parameter
(getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE")))
;;> Parameters controlling which test groups are skipped. Each
;;> parameter is a list of procedures of one argument, a test group
;;> info, which can be queried with \var{test-group-name} and
;;> \var{test-group-ref}. Analogous to SRFI 1, a filter selects a
;;> group for inclusion and a removers for exclusion. The defaults
;;> are set automatically from the environment variables
;;> TEST_GROUP_FILTER and TEST_GROUP_REMOVE, which should be
;;> comma-delimited lists of strings which are checked for a substring
;;> match in the test group name. A test group is skipped if it does
;;> not match any filter and:
;;> \itemlist[
;;> \item{its parent group is skipped, or}
;;> \item{it matches a remover, or}
;;> \item{no removers are specified but some filters are}
;;> ]
;;/
(define current-test-filters
(make-parameter (getenv-filter-list string->info-matcher "TEST_FILTER")))
(define current-test-removers
(make-parameter (getenv-filter-list string->info-matcher "TEST_REMOVE")))
;;> Parameters controlling which tests are skipped. Each parameter is
;;> a list of procedures of one argument, a test info alist, which can
;;> be queried with \scheme{test-get-name!} or \scheme{assq}.
;;> Analogous to SRFI 1, a filter selects a test for inclusion and a
;;> removers for exclusion. The defaults are set automatically from
;;> the environment variables TEST_FILTER and TEST_REMOVE, which
;;> should be comma-delimited lists of strings which are checked for a
;;> substring match in the test name. A test is skipped if its group
;;> is skipped, or if it does not match a filter and:
;;> \itemlist[
;;> \item{it matches a remover, or}
;;> \item{no removers are specified but some filters are}
;;> ]
;;/
;;> Parameter controlling the current column width for test output,
;;> can be set from the environment variable TEST_COLUMN_WIDTH,
;;> otherwise defaults to 78. For portability of implementation (and
;;> resulting output), does not attempt to use termios to determine
;;> the actual available width.
(define current-column-width
(make-parameter
(or (cond ((get-environment-variable "TEST_COLUMN_WIDTH")
=> string->number)
(else #f))
78)))

3
tests.scm Normal file
View File

@ -0,0 +1,3 @@
(define tests
'(((name . "r7rs-test")
(file . "r7rs-tests.scm"))))

11
update-srfis Executable file
View File

@ -0,0 +1,11 @@
#!/bin/sh
set -euxo
rm -rf snow/srfi
mkdir -p snow/srfi
cd snow/srfi || exit 1
wget https://raw.githubusercontent.com/srfi-explorations/r7rs-srfi/refs/heads/main/srfi/1.scm
wget https://raw.githubusercontent.com/srfi-explorations/r7rs-srfi/refs/heads/main/srfi/1.sld
wget https://raw.githubusercontent.com/srfi-explorations/r7rs-srfi/refs/heads/main/srfi/8.scm
wget https://raw.githubusercontent.com/srfi-explorations/r7rs-srfi/refs/heads/main/srfi/8.sld

4
update-tests Executable file
View File

@ -0,0 +1,4 @@
#/bin/sh
rm -rf r7rs-tests.scm
wget https://raw.githubusercontent.com/ashinn/chibi-scheme/refs/heads/master/tests/r7rs-tests.scm

30
util.scm Normal file
View File

@ -0,0 +1,30 @@
(define slurp-loop
(lambda (line result)
(if (eof-object? line)
result
(slurp-loop (read-line) (string-append result line (string #\newline))))))
(define slurp
(lambda (path)
(with-input-from-file
path
(lambda ()
(slurp-loop (read-line) "")))))
(define string-starts-with?
(lambda (str prefix)
(and (>= (string-length str) (string-length prefix))
(string=? (string-copy str 0 (string-length prefix)) prefix))))
(define number-of-line->number
(lambda (str)
(letrec
((looper
(lambda (chars result)
(if (and (not (null? chars))
(char-whitespace? (car chars)))
(begin
(string->number result))
(looper (cdr chars) (string-append (string (car chars)) result ))))))
(looper (reverse (string->list str)) ""))))