From 20cb936e0d5df39d27e54e07115098bd64f6673d Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 5 Oct 2024 11:55:06 +0300 Subject: [PATCH] First steps --- .gitignore | 18 + Jenkinsfile | 489 +++++ Makefile | 82 + build.scm | 111 ++ generate | 3 + implementations.scm | 25 + snow/arvyy/mustache-impl.scm | 106 ++ snow/arvyy/mustache-test.sld | 73 + snow/arvyy/mustache-test/comments.scm | 56 + snow/arvyy/mustache-test/delimiters.scm | 75 + .../mustache-test/implementation-specific.scm | 71 + snow/arvyy/mustache-test/interpolation.scm | 199 ++ snow/arvyy/mustache-test/inverted.scm | 147 ++ snow/arvyy/mustache-test/partials.scm | 46 + snow/arvyy/mustache-test/sections.scm | 84 + snow/arvyy/mustache.sld | 27 + snow/arvyy/mustache/collection.sld | 64 + snow/arvyy/mustache/executor-impl.scm | 94 + snow/arvyy/mustache/executor.sld | 6 + snow/arvyy/mustache/lookup.sld | 27 + snow/arvyy/mustache/parser-impl.scm | 296 +++ snow/arvyy/mustache/parser.sld | 14 + snow/arvyy/mustache/tokenizer-impl.scm | 237 +++ snow/arvyy/mustache/tokenizer.sld | 15 + snow/chibi/diff-test.sld | 47 + snow/chibi/diff.html | 75 + snow/chibi/diff.scm | 239 +++ snow/chibi/diff.sld | 21 + snow/chibi/optional-test.sld | 72 + snow/chibi/optional.html | 137 ++ snow/chibi/optional.scm | 227 +++ snow/chibi/optional.sld | 42 + snow/chibi/term/ansi-test.sld | 219 +++ snow/chibi/term/ansi.html | 206 +++ snow/chibi/term/ansi.scm | 524 ++++++ snow/chibi/term/ansi.sld | 42 + snow/chibi/test.html | 131 ++ snow/chibi/test.scm | 985 ++++++++++ snow/chibi/test.sld | 39 + snow/srfi/1.scm | 1647 +++++++++++++++++ snow/srfi/1.sld | 156 ++ snow/srfi/8.scm | 5 + snow/srfi/8.sld | 6 + templates/Jenkinsfile-bottom | 35 + templates/Jenkinsfile-job | 2 + templates/Jenkinsfile-job-bottom | 7 + templates/Jenkinsfile-job-top | 23 + templates/Jenkinsfile-top | 49 + templates/Makefile-bottom | 16 + templates/Makefile-job | 4 + templates/Makefile-top | 0 templates/Report-bottom | 17 + templates/Report-row | 6 + templates/Report-top | 16 + test.scm | 985 ++++++++++ tests.scm | 3 + update-srfis | 11 + update-tests | 4 + util.scm | 30 + 59 files changed, 8393 insertions(+) create mode 100644 .gitignore create mode 100644 Jenkinsfile create mode 100644 Makefile create mode 100644 build.scm create mode 100755 generate create mode 100644 implementations.scm create mode 100644 snow/arvyy/mustache-impl.scm create mode 100644 snow/arvyy/mustache-test.sld create mode 100644 snow/arvyy/mustache-test/comments.scm create mode 100644 snow/arvyy/mustache-test/delimiters.scm create mode 100644 snow/arvyy/mustache-test/implementation-specific.scm create mode 100644 snow/arvyy/mustache-test/interpolation.scm create mode 100644 snow/arvyy/mustache-test/inverted.scm create mode 100644 snow/arvyy/mustache-test/partials.scm create mode 100644 snow/arvyy/mustache-test/sections.scm create mode 100644 snow/arvyy/mustache.sld create mode 100644 snow/arvyy/mustache/collection.sld create mode 100644 snow/arvyy/mustache/executor-impl.scm create mode 100644 snow/arvyy/mustache/executor.sld create mode 100644 snow/arvyy/mustache/lookup.sld create mode 100644 snow/arvyy/mustache/parser-impl.scm create mode 100644 snow/arvyy/mustache/parser.sld create mode 100644 snow/arvyy/mustache/tokenizer-impl.scm create mode 100644 snow/arvyy/mustache/tokenizer.sld create mode 100644 snow/chibi/diff-test.sld create mode 100644 snow/chibi/diff.html create mode 100644 snow/chibi/diff.scm create mode 100644 snow/chibi/diff.sld create mode 100644 snow/chibi/optional-test.sld create mode 100644 snow/chibi/optional.html create mode 100644 snow/chibi/optional.scm create mode 100644 snow/chibi/optional.sld create mode 100644 snow/chibi/term/ansi-test.sld create mode 100644 snow/chibi/term/ansi.html create mode 100644 snow/chibi/term/ansi.scm create mode 100644 snow/chibi/term/ansi.sld create mode 100644 snow/chibi/test.html create mode 100644 snow/chibi/test.scm create mode 100644 snow/chibi/test.sld create mode 100644 snow/srfi/1.scm create mode 100644 snow/srfi/1.sld create mode 100644 snow/srfi/8.scm create mode 100644 snow/srfi/8.sld create mode 100644 templates/Jenkinsfile-bottom create mode 100644 templates/Jenkinsfile-job create mode 100644 templates/Jenkinsfile-job-bottom create mode 100644 templates/Jenkinsfile-job-top create mode 100644 templates/Jenkinsfile-top create mode 100644 templates/Makefile-bottom create mode 100644 templates/Makefile-job create mode 100644 templates/Makefile-top create mode 100644 templates/Report-bottom create mode 100644 templates/Report-row create mode 100644 templates/Report-top create mode 100644 test.scm create mode 100644 tests.scm create mode 100755 update-srfis create mode 100755 update-tests create mode 100644 util.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..2f89f8a --- /dev/null +++ b/.gitignore @@ -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.* diff --git a/Jenkinsfile b/Jenkinsfile new file mode 100644 index 0000000..cb0b9e7 --- /dev/null +++ b/Jenkinsfile @@ -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 "

Test results

" > 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() + } + } +} + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..6e07009 --- /dev/null +++ b/Makefile @@ -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 + diff --git a/build.scm b/build.scm new file mode 100644 index 0000000..b46c88c --- /dev/null +++ b/build.scm @@ -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))) diff --git a/generate b/generate new file mode 100755 index 0000000..e43b597 --- /dev/null +++ b/generate @@ -0,0 +1,3 @@ +#!/bin/sh + +gosh -r7 -A . -A ./snow build.scm diff --git a/implementations.scm b/implementations.scm new file mode 100644 index 0000000..63411af --- /dev/null +++ b/implementations.scm @@ -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")))) diff --git a/snow/arvyy/mustache-impl.scm b/snow/arvyy/mustache-impl.scm new file mode 100644 index 0000000..fc2156a --- /dev/null +++ b/snow/arvyy/mustache-impl.scm @@ -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)))) diff --git a/snow/arvyy/mustache-test.sld b/snow/arvyy/mustache-test.sld new file mode 100644 index 0000000..02f600e --- /dev/null +++ b/snow/arvyy/mustache-test.sld @@ -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)))) diff --git a/snow/arvyy/mustache-test/comments.scm b/snow/arvyy/mustache-test/comments.scm new file mode 100644 index 0000000..7eb77b8 --- /dev/null +++ b/snow/arvyy/mustache-test/comments.scm @@ -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")) + diff --git a/snow/arvyy/mustache-test/delimiters.scm b/snow/arvyy/mustache-test/delimiters.scm new file mode 100644 index 0000000..455a932 --- /dev/null +++ b/snow/arvyy/mustache-test/delimiters.scm @@ -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" + '() + "|{{= @ @ =}}|" + "||")) diff --git a/snow/arvyy/mustache-test/implementation-specific.scm b/snow/arvyy/mustache-test/implementation-specific.scm new file mode 100644 index 0000000..5f11aa2 --- /dev/null +++ b/snow/arvyy/mustache-test/implementation-specific.scm @@ -0,0 +1,71 @@ +(define-record-type (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 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;"))) + diff --git a/snow/arvyy/mustache-test/interpolation.scm b/snow/arvyy/mustache-test/interpolation.scm new file mode 100644 index 0000000..4022d32 --- /dev/null +++ b/snow/arvyy/mustache-test/interpolation.scm @@ -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: & " < >") + + (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: & " < >") + + (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 }}|" + "|---|")) diff --git a/snow/arvyy/mustache-test/inverted.scm b/snow/arvyy/mustache-test/inverted.scm new file mode 100644 index 0000000..f5f68ea --- /dev/null +++ b/snow/arvyy/mustache-test/inverted.scm @@ -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 }}|" + "|=|")) + diff --git a/snow/arvyy/mustache-test/partials.scm b/snow/arvyy/mustache-test/partials.scm new file mode 100644 index 0000000..af82f05 --- /dev/null +++ b/snow/arvyy/mustache-test/partials.scm @@ -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>") + + (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>|")) + diff --git a/snow/arvyy/mustache-test/sections.scm b/snow/arvyy/mustache-test/sections.scm new file mode 100644 index 0000000..10534e1 --- /dev/null +++ b/snow/arvyy/mustache-test/sections.scm @@ -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 + " + )) + diff --git a/snow/arvyy/mustache.sld b/snow/arvyy/mustache.sld new file mode 100644 index 0000000..42aea6f --- /dev/null +++ b/snow/arvyy/mustache.sld @@ -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")) diff --git a/snow/arvyy/mustache/collection.sld b/snow/arvyy/mustache/collection.sld new file mode 100644 index 0000000..1688a1a --- /dev/null +++ b/snow/arvyy/mustache/collection.sld @@ -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 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")))))))) diff --git a/snow/arvyy/mustache/executor-impl.scm b/snow/arvyy/mustache/executor-impl.scm new file mode 100644 index 0000000..08bdf95 --- /dev/null +++ b/snow/arvyy/mustache/executor-impl.scm @@ -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 "&" out)) + ((#\<) (write-string "<" out)) + ((#\>) (write-string ">" out)) + ((#\") (write-string """ 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)) diff --git a/snow/arvyy/mustache/executor.sld b/snow/arvyy/mustache/executor.sld new file mode 100644 index 0000000..47e013b --- /dev/null +++ b/snow/arvyy/mustache/executor.sld @@ -0,0 +1,6 @@ +(define-library + (arvyy mustache executor) + (import (scheme base) + (arvyy mustache parser)) + (export execute) + (include "executor-impl.scm")) diff --git a/snow/arvyy/mustache/lookup.sld b/snow/arvyy/mustache/lookup.sld new file mode 100644 index 0000000..4d9135d --- /dev/null +++ b/snow/arvyy/mustache/lookup.sld @@ -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))))) diff --git a/snow/arvyy/mustache/parser-impl.scm b/snow/arvyy/mustache/parser-impl.scm new file mode 100644 index 0000000..8a90cc7 --- /dev/null +++ b/snow/arvyy/mustache/parser-impl.scm @@ -0,0 +1,296 @@ +(define-record-type + (interp ref escape?) + interp? + (ref interp-ref) + (escape? interp-escape?) ;; should html be escaped + ) + +(define-record-type
+ (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 name indent) + partial? + (name partial-name) + (indent partial-indent)) + +(define-record-type + (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-content t) "> "))) + ((token-nl? t) (display "#<> ")) + ((token-section-open? t) (display (string-append "#< " (token-section-open-tag t) "> "))) + ((token-section-close? t) (display "#<> ")) + ((token-ws? t) (display (string-append "#< " (number->string (token-ws-count t)) "> "))) + ((token-interp? t) (display (string-append "#< " (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))))) diff --git a/snow/arvyy/mustache/parser.sld b/snow/arvyy/mustache/parser.sld new file mode 100644 index 0000000..6efa52a --- /dev/null +++ b/snow/arvyy/mustache/parser.sld @@ -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")) diff --git a/snow/arvyy/mustache/tokenizer-impl.scm b/snow/arvyy/mustache/tokenizer-impl.scm new file mode 100644 index 0000000..4870e89 --- /dev/null +++ b/snow/arvyy/mustache/tokenizer-impl.scm @@ -0,0 +1,237 @@ +(define-record-type + (token-ws count) + token-ws? + (count token-ws-count)) + +(define-record-type + (token-nl chars) + token-nl? + (chars token-nl-chars)) + +(define-record-type + (token-comment) + token-comment?) + +(define-record-type + (token-str content) + token-str? + (content token-str-content)) + +(define-record-type + (token-delimchager open close) + token-delimchager? + (open token-delimchager-open) + (close token-delimchager-close)) + +(define-record-type + (token-interp tag escape?) + token-interp? + (tag token-interp-tag) + (escape? token-interp-escape?)) + +(define-record-type + (token-section-open tag inverted?) + token-section-open? + (tag token-section-open-tag) + (inverted? token-section-open-inverted?)) + +(define-record-type + (token-section-close tag) + token-section-close? + (tag token-section-close-tag)) + +(define-record-type + (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")))) diff --git a/snow/arvyy/mustache/tokenizer.sld b/snow/arvyy/mustache/tokenizer.sld new file mode 100644 index 0000000..edeea7e --- /dev/null +++ b/snow/arvyy/mustache/tokenizer.sld @@ -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")) diff --git a/snow/chibi/diff-test.sld b/snow/chibi/diff-test.sld new file mode 100644 index 0000000..0ecc2b3 --- /dev/null +++ b/snow/chibi/diff-test.sld @@ -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)))) diff --git a/snow/chibi/diff.html b/snow/chibi/diff.html new file mode 100644 index 0000000..af46c15 --- /dev/null +++ b/snow/chibi/diff.html @@ -0,0 +1,75 @@ + + +

(chibi diff)

(lcs a-ls b-ls [eq])

Finds the Longest Common Subsequence between a-ls and +b-ls, comparing elements with eq (default +equal?. Returns this sequence as a list, using the +elements from a-ls. Uses quadratic time and space.

(lcs-with-positions a-ls b-ls [eq])

Variant of 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 +a-ls where the element occurred, and the position in +b-ls.

(diff a b [reader eq])

Utility to run lcs on text. a and b can be strings or +ports, which are tokenized into a sequence by calling reader +until eof-object is found. Returns a list of three values, +the sequences read from a and b, and the lcs +result.

(write-diff diff [writer out])

Utility to format the result of a diff to output port +out (default (current-output-port)). Applies +writer to successive diff chunks. writer should be a +procedure of three arguments: (writer subsequence type +out). subsequence is a subsequence from the original input, +type is a symbol indicating the type of diff: 'same +if this is part of the lcs, 'add if it is unique to the +second input, or 'remove if it is unique to the first +input. writer defaults to write-line-diffs, +assuming the default line diffs.

(diff->string diff . o)

Equivalent to write-diff but collects the output to a string.

(write-line-diffs lines type out)

The default writer for write-diff, annotates simple +/- +prefixes for added/removed lines.

(write-line-diffs/color lines type out)

A variant of write-line-diffs which adds red/green ANSI +coloring to the +/- prefix.

(write-char-diffs chars type out)

A diff writer for sequences of characters (when a diff was +generated with read-char), enclosing added characters in +«...» brackets and removed characters in »...«.

(write-char-diffs/color chars type out)

A diff writer for sequences of characters (when a diff was +generated with read-char), formatting added characters in +green and removed characters in red.

(write-edits ls lcs [index writer out])

Utility to format the result of a diff with respect to a +single input sequence ls. lcs is the annotated common +sequence from diff or lcs-with-positions, and +index is the index (0 or 1, default 1) of 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 index is 0) +or removed (if index is 1).

(edits->string ls lcs [type writer])

Equivalent to write-edits but collects the output to a string.

(edits->string/color ls lcs [type writer])

Equivalent to 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.
\ No newline at end of file diff --git a/snow/chibi/diff.scm b/snow/chibi/diff.scm new file mode 100644 index 0000000..ed7607e --- /dev/null +++ b/snow/chibi/diff.scm @@ -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)))) diff --git a/snow/chibi/diff.sld b/snow/chibi/diff.sld new file mode 100644 index 0000000..4058f8b --- /dev/null +++ b/snow/chibi/diff.sld @@ -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")) diff --git a/snow/chibi/optional-test.sld b/snow/chibi/optional-test.sld new file mode 100644 index 0000000..28fd68a --- /dev/null +++ b/snow/chibi/optional-test.sld @@ -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)))) diff --git a/snow/chibi/optional.html b/snow/chibi/optional.html new file mode 100644 index 0000000..82763e2 --- /dev/null +++ b/snow/chibi/optional.html @@ -0,0 +1,137 @@ + + +

(chibi optional)

Syntax to support optional and named keyword arguments. +let-optionals[*] is originally from SCSH, and +let-keywords[*] derived from Gauche.

(let-optionals ls ((var default) ... [rest]) body ...)

+ +Binding construct similar to let. The vars are +bound to fresh locations holding values taken in order from the +list ls, body is evaluated in the resulting +environment, and the value(s) of the last expression of body +returned. If the length of ls is shorter than the number of +vars, then the remaining vars taken their values from +their corresponding defaults, evaluated in an unspecified +order. Unused defaults are not evaluated. If a final +rest var is specified, then it is bound to any remaining +elements of ls beyond the length of ls, otherwise any +extra values are unused. + +Typically used on the dotted rest list at the start of a lambda, +let-optionals is more concise and more efficient than +case-lambda for simple optional argument uses. + +Example: +
(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)))
+ +Example: +
(let-optionals '(0) ((a 10) (b 11) (c 12))
+  (list a b c))
=> (0 11 12)

(let-optionals* ls ((var default) ... [rest]) body ...)

+ +let* equivalent to let-optionals. Any required +default values are evaluated in left-to-right order, with +all preceding vars in scope. +

(opt-lambda ((var default) ... [rest]) body ...)

+ +Shorthand for +
(lambda (required ... . o)
+  (let-optionals o ((var default) ... [rest])
+     body ...))

(define-opt (name (var default) ... [rest]) body ...)

+ +Shorthand for +
(define name (opt-lambda (var default) ... [rest]) body ...)

(keyword-ref ls key [default])

+ +Search for the identifier key in the list ls, treating +it as a property list of the form (key1 val1 key2 val2 +...), and return the associated val. If not found, return +default, or #f.

(keyword-ref* ls key default)

+ +Macro equivalent of keyword-ref, where default is +only evaluated if key is not found.

(let-keywords ls ((var [keyword] default) ... [rest]) body ...)

+ +Analogous to let-optionals, except instead of binding the +vars by position they are bound by name, by searching in +ls with keyword-ref*. If an optional keyword +argument is provided it must be an identifier to use as the name, +otherwise var is used, appending a ":" (colon). If the name +is not found, var is bound to default, even if unused +names remain in ls. + +If an optional trailing identifier rest is provided, it is +bound to the list of unused arguments not bound to any 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). + +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))
+
=> (#("John Doe" 0 unemployed) #("Methuselah" 969 unemployed) #("Dr. Who" 1500 time-lord))
+ +Example: +
(let-keywords '(b: 2 a: 1 other: 9)
+    ((a 0) (b 0) (c 0) rest)
+  (list a b c rest))
+
=> (1 2 0 (other: 9))

(let-keywords* ls ((var [keyword] default) ... [rest]) body ...)

+ +let* equivalent to let-keywords*. Any required +default values are evaluated in left-to-right order, with +all preceding vars in scope. + +Example: +
(let-keywords* '(b: 5)
+    ((a 1) (b (* a 2)) (c (* b 3)))
+  (list a b c))
+
=> (1 5 15)

\ No newline at end of file diff --git a/snow/chibi/optional.scm b/snow/chibi/optional.scm new file mode 100644 index 0000000..d703c73 --- /dev/null +++ b/snow/chibi/optional.scm @@ -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))))) diff --git a/snow/chibi/optional.sld b/snow/chibi/optional.sld new file mode 100644 index 0000000..4aa0243 --- /dev/null +++ b/snow/chibi/optional.sld @@ -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")) diff --git a/snow/chibi/term/ansi-test.sld b/snow/chibi/term/ansi-test.sld new file mode 100644 index 0000000..fbbb410 --- /dev/null +++ b/snow/chibi/term/ansi-test.sld @@ -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)))) diff --git a/snow/chibi/term/ansi.html b/snow/chibi/term/ansi.html new file mode 100644 index 0000000..ba3dad4 --- /dev/null +++ b/snow/chibi/term/ansi.html @@ -0,0 +1,206 @@ + + +

(chibi term ansi)

A library to use ANSI escape codes to format text and background +color, font weigh, and underlining.

Library

(black-escape)

(red-escape)

(green-escape)

(yellow-escape)

(blue-escape)

(magenta-escape)

(cyan-escape)

(white-escape)

Return a string consisting of an ANSI escape code to select the +specified text color.

(rgb-escape red-level green-level blue-level)

Return a string consisting of an ANSI escape code to select the +text color specified by the red-level, green-level, +and 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.

(gray-escape gray-level)

Return a string consisting of an ANSI escape code to select the +text color specified by the 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.

(rgb24-escape red-level green-level blue-level)

The true-color equivalent of rgb-escape. Return a string +consisting of an ANSI escape code to select the text color +specified by the red-level, green-level, and +blue-level arguments, each of which must be an exact integer +in the range [0, 255].

(reset-color-escape)

Return a string consisting of an ANSI escape code to select the +default text color.

(black str)

(red str)

(green str)

(yellow str)

(blue str)

(magenta str)

(cyan str)

(white str)

If ANSI escapes are enabled, return a string consisting of the +string 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 str.

(rgb red-level green-level blue-level)

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 rgb-escape procedure +with the values of the red-level, green-level, and +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.

(gray gray-level)

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 gray-escape procedure +with the values of the 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.

(rgb24 red-level green-level blue-level)

The true-color equivalent of rbg, extending the ranges +to [0, 255].

(black-background-escape)

(red-background-escape)

(green-background-escape)

(yellow-background-escape)

(blue-background-escape)

(magenta-background-escape)

(cyan-background-escape)

(white-background-escape)

Return a string consisting of an ANSI escape code to select the +specified background color.

(rgb-background-escape red-level green-level blue-level)

Return a string consisting of an ANSI escape code to select the +background color specified by the red-level, green-level, +and 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.

(gray-background-escape gray-level)

Return a string consisting of an ANSI escape code to select the +background color specified by the 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.

(rgb24-background-escape red-level green-level blue-level)

The true-color equivalent of rgb-background-escape. +Return a string consisting of an ANSI escape code to select the +text color specified by the red-level, green-level, +and blue-level arguments, each of which must be an exact +integer in the range [0, 255].

(reset-background-color-escape)

+ +Return a string consisting of an ANSI escape code to select the +default background color.

(black-background str)

(red-background str)

(green-background str)

(yellow-background str)

(blue-background str)

(magenta-background str)

(cyan-background str)

(white-background str)

If ANSI escapes are enabled, return a string consisting of the +string 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 str.

(rgb-background red-level green-level blue-level)

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 rgb-background-escape +procedure with the values of the red-level, green-level, +and 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.

(gray-background gray-level)

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 gray-background-escape +procedure with the values of the 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.

(rgb24-background red-level green-level blue-level)

The true-color equivalent of rbg-background, extending +the ranges to [0, 255].

(bold-escape)

Return a string consisting of an ANSI escape code to select bold +style.

(reset-bold-escape)

Return a string consisting of an ANSI escape code to select non-bold +style.

(bold str)

If ANSI escapes are enabled, return a string consisting of the +string str with a prefix that selects bold style and a suffix +that selects non-bold style. + +If ANSI escapes are not enabled, return str.

(underline-escape)

Return a string consisting of an ANSI escape code to select +underlined style.

(reset-underline-escape)

Return a string consisting of an ANSI escape code to select +non-underlined style.

(underline str)

If ANSI escapes are enabled, return a string consisting of the +string str with a prefix that selects underlined style and +a suffix that selects non-underlined style. + +If ANSI escapes are not enabled, return str.

(italic-escape)

Return a string consisting of an ANSI escape code to select +italic style.

(reset-italic-escape)

Return a string consisting of an ANSI escape code to select +non-italic style.

(italic str)

Returns str optionally wrapped in italic escapes.

(strikethrough-escape)

Return a string consisting of an ANSI escape code to select +strikethrough style.

(reset-strikethrough-escape)

Return a string consisting of an ANSI escape code to select +non-strikethrough style.

(strikethrough str)

Returns str optionally wrapped in strikethrough escapes.

(negative-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).

(reset-negative-escape)

Return a string consisting of an ANSI escape code to select positive +style (text in the text color and background in the background +color).

(negative str)

If ANSI escapes are enabled, return a string consisting of the +string 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 str.

ansi-escapes-enabled?

A parameter object that determines whether ANSI escapes are enabled +in some of the preceding procedures. They are disabled if +(ansi-escapes-enabled?) returns #f, and otherwise +they are enabled. + +The initial value returned by (ansi-escapes-enabled?) is +determined by the environment. + +If the environment variable ANSI_ESCAPES_ENABLED is set, +its value determines the initial value returned by +(ansi-escapes-enabled?). If the value of +ANSI_ESCAPES_ENABLED is "0", the initial value +is #f, otherwise the initial value is #t. + +If the environment variable ANSI_ESCAPES_ENABLED is not +set, but the environment variable TERM is set, the value +of the latter determines the initial value returned by +(ansi-escapes-enabled?). If the value of TERM +is "xterm", "xterm-color", "xterm-256color", +"rxvt", "rxvt-unicode-256color", "kterm", +"linux", "screen", "screen-256color", +or "vt100", the initial value is #t, otherwise +the initial value is #f. + +If neither of the environment variables ANSI_ESCAPES_ENABLED +and TERM are set, the initial value returned by +(ansi-escapes-enabled?) is #f.

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: + +
(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: + +
(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. + +
(display (bold (string-append (underline (green "GREEN")) (red "RED"))))
+

\ No newline at end of file diff --git a/snow/chibi/term/ansi.scm b/snow/chibi/term/ansi.scm new file mode 100644 index 0000000..ebde95e --- /dev/null +++ b/snow/chibi/term/ansi.scm @@ -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"))))} +;;> diff --git a/snow/chibi/term/ansi.sld b/snow/chibi/term/ansi.sld new file mode 100644 index 0000000..5aa4533 --- /dev/null +++ b/snow/chibi/term/ansi.sld @@ -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")) diff --git a/snow/chibi/test.html b/snow/chibi/test.html new file mode 100644 index 0000000..f21ea17 --- /dev/null +++ b/snow/chibi/test.html @@ -0,0 +1,131 @@ + + +

(chibi test)

Simple but extensible testing framework with advanced reporting.

Testing

+

(test [name] expect expr)

+The primary interface to testing. Evaluate expr and check +that it is equal to expect, and report the result, using +name or a printed summary of expr. + +If used inside a group this will contribute to the overall group +reporting, but can be used standalone: + +
(test 4 (+ 2 2))
(+ 2 2) .............................................................. [ PASS]
+
=> PASS
+
(test "add two and two" 4 (+ 2 2))
add two and two ...................................................... [ PASS]
+
=> PASS
+
(test 3 (+ 2 2))
(+ 2 2) .............................................................. [ FAIL]
+    expected 3 but got 4
+
=> FAIL
+
(test 4 (+ 2 "2"))
(+ 2 "2") ............................................................ [ERROR]
+    ERROR: invalid type, expected Number: "2"
+
=> ERROR
+ +The equality comparison is made with +current-test-comparator, defaulting to +test-equal?, which is the same as equal? but +more permissive on floating point comparisons). Returns the +status of the test (one of the symbols 'PASS, +'FAIL, 'SKIP, 'ERROR).

(test-equal equal [name] expect expr)

+Equivalent to test, using equal for comparison instead of +equal?.

(test-assert [name] expr)

+Like test but evaluates expr and checks that it's true.

(test-not [name] expr)

+Like test but evaluates expr and checks that it's false.

(test-values [name] expect expr)

+Like test but expect and expr can both +return multiple values.

(test-error [name] expr)

+Like test but evaluates expr and checks that it +raises an error.

(test-propagate-info name expect expr info)

Low-level macro to pass alist info to the underlying test-run.

(test-run expect expr info)

The procedural interface to testing. expect and expr +should be thunks, and info is an alist of properties used in +test reporting.

(test-equal? expect res)

Returns true if either (equal? expect res), or +expect is inexact and res is within +current-test-epsilon of expect.

Test Groups

(test-group name-expr body ...)

+Tests can be collected in groups for +Wraps body as a single test group, which can be filtered +and summarized separately. +
(test-group "pi"
+  (test 3.14159 (acos -1))
+  (test 3 (acos -1))
+  (test 3.14159 (acos "-1")))
+
pi: .x!
+1 out of 3 (33.3%) test passed in 0.00030422210693359375 seconds.
+1 failure (33.3%).
+1 error (33.3%).
+FAIL: (acos -1)
+    expected 3 but got 3.141592653589793
+ERROR: (acos "-1")
+    ERROR in "acos": invalid type, expected Number: "-1"
+

(test-begin [name])

Begin testing a new group until the closing (test-end).

(test-end [name])

Ends testing group introduced with (test-begin), and +summarizes the results. The name is optional, but if +present should match the corresponding test-begin name, +or a warning is printed.

(test-exit)

Exits with a failure status if any tests have failed, +and a successful status otherwise.

(test-syntax-error)

Accessors

(test-group-name group)

Returns the name of a test group info object.

(test-group-ref group field . o)

Returns the value of a field in a test var{group} info +object. field should be a symbol, and predefined fields +include parent, verbose, level, +start-time, skip-group?, count, +total-pass, total-fail, total-error.

(test-group-set! group field value)

Sets the value of a field in a test group info object.

(test-group-inc! group field [amount])

Increments the value of a field in a test group info +object by amount, defaulting to 1.

(test-group-push! group field value)

Updates a field in a test group info object by consing +value onto it.

(test-get-name! info)

Parameters

current-test-group

+The current test group as started by test-group or +test-begin.

current-test-verbosity

If true, show more verbose output per test. Inferred from the +environment variable TEST_VERBOSE.

current-test-epsilon

The epsilon used for floating point comparisons.

current-test-comparator

The underlying comparator used in testing, defaults to +test-equal?.

current-test-applier

The test applier - what we do with non-skipped tests. Takes the +same signature as test-run, should be responsible for +evaluating the thunks, determining the status of the test, and +passing this information to current-test-reporter.

current-test-skipper

The test skipper - what we do with non-skipped tests. This should +not evaluate the thunks and simply pass off to +current-test-reporter.

current-test-reporter

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.

current-test-group-reporter

Takes one argument, a test group, and prints a summary of the test +results for that group.

test-failure-count

A running count of all test failures and errors across all groups +(and threads). Used by test-exit.

current-test-group-filters

current-test-group-removers

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 test-group-name and +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: +
  • its parent group is skipped, or
  • it matches a remover, or
  • no removers are specified but some filters are

current-test-filters

current-test-removers

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 test-get-name! or 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: +
  • it matches a remover, or
  • no removers are specified but some filters are

current-column-width

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.

\ No newline at end of file diff --git a/snow/chibi/test.scm b/snow/chibi/test.scm new file mode 100644 index 0000000..4be7789 --- /dev/null +++ b/snow/chibi/test.scm @@ -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 ( ...)) " + (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))) diff --git a/snow/chibi/test.sld b/snow/chibi/test.sld new file mode 100644 index 0000000..3fed853 --- /dev/null +++ b/snow/chibi/test.sld @@ -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")) diff --git a/snow/srfi/1.scm b/snow/srfi/1.scm new file mode 100644 index 0000000..e1f481b --- /dev/null +++ b/snow/srfi/1.scm @@ -0,0 +1,1647 @@ +;;; SRFI-1 list-processing library -*- Scheme -*- +;;; Reference implementation +;;; +;;; SPDX-License-Identifier: MIT +;;; +;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with +;;; this code as long as you do not remove this copyright notice or +;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. +;;; -Olin + +;;; This is a library of list- and pair-processing functions. I wrote it after +;;; carefully considering the functions provided by the libraries found in +;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common +;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty +;;; rich toolkit, providing a superset of the functionality found in any of +;;; the various Schemes I considered. + +;;; This implementation is intended as a portable reference implementation +;;; for SRFI-1. See the porting notes below for more information. + +;;; Exported: +;;; xcons tree-copy make-list list-tabulate cons* list-copy +;;; proper-list? circular-list? dotted-list? not-pair? null-list? list= +;;; circular-list length+ +;;; iota +;;; 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 +;;; zip unzip1 unzip2 unzip3 unzip4 unzip5 +;;; count +;;; append! append-reverse append-reverse! concatenate concatenate! +;;; unfold fold pair-fold reduce +;;; unfold-right fold-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! +;;; find find-tail any every list-index +;;; take-while drop-while take-while! +;;; span break span! break! +;;; delete delete! +;;; alist-cons alist-copy +;;; delete-duplicates delete-duplicates! +;;; alist-delete alist-delete! +;;; reverse! +;;; lset<= lset= lset-adjoin +;;; lset-union lset-intersection lset-difference lset-xor lset-diff+intersection +;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection! +;;; +;;; In principle, the following R4RS list- and pair-processing procedures +;;; are also part of this package's exports, although they are not defined +;;; in this file: +;;; Primitives: cons pair? null? car cdr set-car! set-cdr! +;;; Non-primitives: list length append reverse cadr ... cddddr list-ref +;;; memq memv assq assv +;;; (The non-primitives are defined in this file, but commented out.) +;;; +;;; These R4RS procedures have extended definitions in SRFI-1 and are defined +;;; in this file: +;;; map for-each member assoc +;;; +;;; The remaining two R4RS list-processing procedures are not included: +;;; list-tail (use drop) +;;; list? (use proper-list?) + + +;;; A note on recursion and iteration/reversal: +;;; Many iterative list-processing algorithms naturally compute the elements +;;; of the answer list in the wrong order (left-to-right or head-to-tail) from +;;; the order needed to cons them into the proper answer (right-to-left, or +;;; tail-then-head). One style or idiom of programming these algorithms, then, +;;; loops, consing up the elements in reverse order, then destructively +;;; reverses the list at the end of the loop. I do not do this. The natural +;;; and efficient way to code these algorithms is recursively. This trades off +;;; intermediate temporary list structure for intermediate temporary stack +;;; structure. In a stack-based system, this improves cache locality and +;;; lightens the load on the GC system. Don't stand on your head to iterate! +;;; Recurse, where natural. Multiple-value returns make this even more +;;; convenient, when the recursion/iteration has multiple state values. + +;;; Porting: +;;; This is carefully tuned code; do not modify casually. +;;; - It is careful to share storage when possible; +;;; - Side-effecting code tries not to perform redundant writes. +;;; +;;; That said, a port of this library to a specific Scheme system might wish +;;; to tune this code to exploit particulars of the implementation. +;;; The single most important compiler-specific optimisation you could make +;;; to this library would be to add rewrite rules or transforms to: +;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND, +;;; LSET-UNION) into multiple applications of a primitive two-argument +;;; variant. +;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, +;;; ANY, EVERY) into open-coded loops. The killer here is that these +;;; functions are n-ary. Handling the general case is quite inefficient, +;;; requiring many intermediate data structures to be allocated and +;;; discarded. +;;; - transform applications of procedures that take optional arguments +;;; into calls to variants that do not take optional arguments. This +;;; eliminates unnecessary consing and parsing of the rest parameter. +;;; +;;; These transforms would provide BIG speedups. In particular, the n-ary +;;; mapping functions are particularly slow and cons-intensive, and are good +;;; candidates for tuning. I have coded fast paths for the single-list cases, +;;; but what you really want to do is exploit the fact that the compiler +;;; usually knows how many arguments are being passed to a particular +;;; application of these functions -- they are usually explicitly called, not +;;; passed around as higher-order values. If you can arrange to have your +;;; compiler produce custom code or custom linkages based on the number of +;;; arguments in the call, you can speed these functions up a *lot*. But this +;;; kind of compiler technology no longer exists in the Scheme world as far as +;;; I can see. +;;; +;;; Note that this code is, of course, dependent upon standard bindings for +;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound +;;; to the procedure that takes the car of a list. If your Scheme +;;; implementation allows user code to alter the bindings of these procedures +;;; in a manner that would be visible to these definitions, then there might +;;; be trouble. You could consider horrible kludgery along the lines of +;;; (define fact +;;; (let ((= =) (- -) (* *)) +;;; (letrec ((real-fact (lambda (n) +;;; (if (= n 0) 1 (* n (real-fact (- n 1))))))) +;;; real-fact))) +;;; Or you could consider shifting to a reasonable Scheme system that, say, +;;; has a module system protecting code from this kind of lossage. +;;; +;;; This code does a fair amount of run-time argument checking. If your +;;; Scheme system has a sophisticated compiler that can eliminate redundant +;;; error checks, this is no problem. However, if not, these checks incur +;;; some performance overhead -- and, in a safe Scheme implementation, they +;;; are in some sense redundant: if we don't check to see that the PROC +;;; parameter is a procedure, we'll find out anyway three lines later when +;;; we try to call the value. It's pretty easy to rip all this argument +;;; checking code out if it's inappropriate for your implementation -- just +;;; nuke every call to CHECK-ARG. +;;; +;;; On the other hand, if you *do* have a sophisticated compiler that will +;;; actually perform soft-typing and eliminate redundant checks (Rice's systems +;;; being the only possible candidate of which I'm aware), leaving these checks +;;; in can *help*, since their presence can be elided in redundant cases, +;;; and in cases where they are needed, performing the checks early, at +;;; procedure entry, can "lift" a check out of a loop. +;;; +;;; Finally, I have only checked the properties that can portably be checked +;;; with R5RS Scheme -- and this is not complete. You may wish to alter +;;; the CHECK-ARG parameter checks to perform extra, implementation-specific +;;; checks, such as procedure arity for higher-order values. +;;; +;;; The code has only these non-R4RS dependencies: +;;; A few calls to an ERROR procedure; +;;; Uses of the R5RS multiple-value procedure VALUES and the m-v binding +;;; RECEIVE macro (which isn't R5RS, but is a trivial macro). +;;; Many calls to a parameter-checking procedure check-arg: +;;; (define (check-arg pred val caller) +;;; (let lp ((val val)) +;;; (if (pred val) val (lp (error "Bad argument" val pred caller))))) +;;; A few uses of the LET-OPTIONAL and OPTIONAL macros for parsing +;;; optional arguments. +;;; +;;; Most of these procedures use the NULL-LIST? test to trigger the +;;; base case in the inner loop or recursion. The NULL-LIST? function +;;; is defined to be a careful one -- it raises an error if passed a +;;; non-nil, non-pair value. The spec allows an implementation to use +;;; a less-careful implementation that simply defines NULL-LIST? to +;;; be NOT-PAIR?. This would speed up the inner loops of these procedures +;;; at the expense of having them silently accept dotted lists. + +;;; A note on dotted lists: +;;; I, personally, take the view that the only consistent view of lists +;;; in Scheme is the view that *everything* is a list -- values such as +;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the +;;; fact that Scheme actually has no true list type. It has a pair type, +;;; and there is an *interpretation* of the trees built using this type +;;; as lists. +;;; +;;; I lobbied to have these list-processing procedures hew to this +;;; view, and accept any value as a list argument. I was overwhelmingly +;;; overruled during the SRFI discussion phase. So I am inserting this +;;; text in the reference lib and the SRFI spec as a sort of "minority +;;; opinion" dissent. +;;; +;;; Many of the procedures in this library can be trivially redefined +;;; to handle dotted lists, just by changing the NULL-LIST? base-case +;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be +;;; an empty list. For most of these procedures, that's all that is +;;; required. +;;; +;;; However, we have to do a little more work for some procedures that +;;; *produce* lists from other lists. Were we to extend these procedures to +;;; accept dotted lists, we would have to define how they terminate the lists +;;; produced as results when passed a dotted list. I designed a coherent set +;;; of termination rules for these cases; this was posted to the SRFI-1 +;;; discussion list. I additionally wrote an earlier version of this library +;;; that implemented that spec. It has been discarded during later phases of +;;; the definition and implementation of this library. +;;; +;;; The argument *against* defining these procedures to work on dotted +;;; lists is that dotted lists are the rare, odd case, and that by +;;; arranging for the procedures to handle them, we lose error checking +;;; in the cases where a dotted list is passed by accident -- e.g., when +;;; the programmer swaps a two arguments to a list-processing function, +;;; one being a scalar and one being a list. For example, +;;; (member '(1 3 5 7 9) 7) +;;; This would quietly return #f if we extended MEMBER to accept dotted +;;; lists. +;;; +;;; The SRFI discussion record contains more discussion on this topic. + + +;;; Utilities + +(define (check-arg pred val caller) + (if (pred val) val (error "Bad argument" val pred caller))) + +(define optional (lambda (a b) (if (null? a) b (car a)))) + +(define-syntax let-optionals + (syntax-rules () + ((let-optionals arg (opt-clause ...) body ...) + (let ((rest arg)) + (internal-let-optionals rest (opt-clause ...) body ...))))) + +(define-syntax internal-let-optionals + (syntax-rules () + ((internal-let-optionals arg (((var ...) xparser) opt-clause ...) body ...) + (call-with-values (lambda () (xparser arg)) + (lambda (rest var ...) + (internal-let-optionals rest (opt-clause ...) body ...)))) + + ((internal-let-optionals arg ((var default) opt-clause ...) body ...) + (call-with-values (lambda () (if (null? arg) (values default '()) + (values (car arg) (cdr arg)))) + (lambda (var rest) + (internal-let-optionals rest (opt-clause ...) body ...)))) + + ((internal-let-optionals arg ((var default test) opt-clause ...) body ...) + (call-with-values (lambda () + (if (null? arg) (values default '()) + (let ((var (car arg))) + (if test (values var (cdr arg)) + (error "arg failed LET-OPT test" var))))) + (lambda (var rest) + (internal-let-optionals rest (opt-clause ...) body ...)))) + + ((internal-let-optionals arg ((var default test supplied?) opt-clause ...) body ...) + (call-with-values (lambda () + (if (null? arg) (values default #f '()) + (let ((var (car arg))) + (if test (values var #t (cdr arg)) + (error "arg failed LET-OPT test" var))))) + (lambda (var supplied? rest) + (internal-let-optionals rest (opt-clause ...) body ...)))) + + ((internal-let-optionals arg (rest) body ...) + (let ((rest arg)) body ...)) + + ((internal-let-optionals arg () body ...) + (if (null? arg) (begin body ...) + (error "Too many arguments in let-opt" arg))))) + +;;; Constructors +;;;;;;;;;;;;;;;; + +;;; Occasionally useful as a value to be passed to a fold or other +;;; higher-order procedure. +(define (xcons d a) (cons a d)) + +;;;; Recursively copy every cons. +;(define (tree-copy x) +; (let recur ((x x)) +; (if (not (pair? x)) x +; (cons (recur (car x)) (recur (cdr x)))))) + +;;; Make a list of length LEN. + +#;(define (make-list len . maybe-elt) +(check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list) +(let ((elt (cond ((null? maybe-elt) #f) ; Default value + ((null? (cdr maybe-elt)) (car maybe-elt)) + (else (error "Too many arguments to MAKE-LIST" + (cons len maybe-elt)))))) + (do ((i len (- i 1)) + (ans '() (cons elt ans))) + ((<= i 0) ans)))) + + +;(define (list . ans) ans) ; R4RS + + +;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. + +(define (list-tabulate len proc) + (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate) + (check-arg procedure? proc list-tabulate) + (do ((i (- len 1) (- i 1)) + (ans '() (cons (proc i) ans))) + ((< i 0) ans))) + +;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an))) +;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...)) +;;; +;;; (cons first (unfold not-pair? car cdr rest values)) + +(define (cons* first . rest) + (let recur ((x first) (rest rest)) + (if (pair? rest) + (cons x (recur (car rest) (cdr rest))) + x))) + +;;; (unfold not-pair? car cdr lis values) + +#;(define (list-copy lis) +(let recur ((lis lis)) + (if (pair? lis) + (cons (car lis) (recur (cdr lis))) + lis))) + +;;; IOTA count [start step] (start start+step ... start+(count-1)*step) + +(define (iota count . maybe-start+step) + (check-arg integer? count iota) + (if (< count 0) (error "Negative step count" iota count)) + (let-optionals maybe-start+step ((start 0) (step 1)) + (check-arg number? start iota) + (check-arg number? step iota) + (let loop ((n 0) (r '())) + (if (= n count) + (reverse r) + (loop (+ 1 n) + (cons (+ start (* n step)) r)))))) + +;;; I thought these were lovely, but the public at large did not share my +;;; enthusiasm... +;;; :IOTA to (0 ... to-1) +;;; :IOTA from to (from ... to-1) +;;; :IOTA from to step (from from+step ...) + +;;; IOTA: to (1 ... to) +;;; IOTA: from to (from+1 ... to) +;;; IOTA: from to step (from+step from+2step ...) + +;(define (%parse-iota-args arg1 rest-args proc) +; (let ((check (lambda (n) (check-arg integer? n proc)))) +; (check arg1) +; (if (pair? rest-args) +; (let ((arg2 (check (car rest-args))) +; (rest (cdr rest-args))) +; (if (pair? rest) +; (let ((arg3 (check (car rest))) +; (rest (cdr rest))) +; (if (pair? rest) (error "Too many parameters" proc arg1 rest-args) +; (values arg1 arg2 arg3))) +; (values arg1 arg2 1))) +; (values 0 arg1 1)))) +; +;(define (iota: arg1 . rest-args) +; (receive (from to step) (%parse-iota-args arg1 rest-args iota:) +; (let* ((numsteps (floor (/ (- to from) step))) +; (last-val (+ from (* step numsteps)))) +; (if (< numsteps 0) (error "Negative step count" iota: from to step)) +; (do ((steps-left numsteps (- steps-left 1)) +; (val last-val (- val step)) +; (ans '() (cons val ans))) +; ((<= steps-left 0) ans))))) +; +; +;(define (:iota arg1 . rest-args) +; (receive (from to step) (%parse-iota-args arg1 rest-args :iota) +; (let* ((numsteps (ceiling (/ (- to from) step))) +; (last-val (+ from (* step (- numsteps 1))))) +; (if (< numsteps 0) (error "Negative step count" :iota from to step)) +; (do ((steps-left numsteps (- steps-left 1)) +; (val last-val (- val step)) +; (ans '() (cons val ans))) +; ((<= steps-left 0) ans))))) + + + +(define (circular-list val1 . vals) + (let ((ans (cons val1 vals))) + (set-cdr! (last-pair ans) ans) + ans)) + +;;; ::= () ; Empty proper list +;;; | (cons ) ; Proper-list pair +;;; Note that this definition rules out circular lists -- and this +;;; function is required to detect this case and return false. + +(define (proper-list? x) + (let lp ((x x) (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) (lp x lag))) + (null? x))) + (null? x)))) + + +;;; A dotted list is a finite list (possibly of length 0) terminated +;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5) +;;; is a dotted list of length 0. +;;; +;;; ::= ; Empty dotted list +;;; | (cons ) ; Proper-list pair + +(define (dotted-list? x) + (let lp ((x x) (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) (lp x lag))) + (not (null? x)))) + (not (null? x))))) + +(define (circular-list? x) + (let lp ((x x) (lag x)) + (and (pair? x) + (let ((x (cdr x))) + (and (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (or (eq? x lag) (lp x lag)))))))) + +(define (not-pair? x) (not (pair? x))) ; Inline me. + +;;; This is a legal definition which is fast and sloppy: +;;; (define null-list? not-pair?) +;;; but we'll provide a more careful one: +(define (null-list? l) + (cond ((pair? l) #f) + ((null? l) #t) + (else (error "null-list?: argument out of domain" l)))) + + +(define (list= = . lists) + (or (null? lists) ; special case + + (let lp1 ((list-a (car lists)) (others (cdr lists))) + (or (null? others) + (let ((list-b (car others)) + (others (cdr others))) + (if (eq? list-a list-b) ; EQ? => LIST= + (lp1 list-b others) + (let lp2 ((pair-a list-a) (pair-b list-b)) + (if (null-list? pair-a) + (and (null-list? pair-b) + (lp1 list-b others)) + (and (not (null-list? pair-b)) + (= (car pair-a) (car pair-b)) + (lp2 (cdr pair-a) (cdr pair-b))))))))))) + + +;;; R4RS, so commented out. +;(define (length x) ; LENGTH may diverge or +; (let lp ((x x) (len 0)) ; raise an error if X is +; (if (pair? x) ; a circular list. This version +; (lp (cdr x) (+ len 1)) ; diverges. +; len))) + +(define (length+ x) ; Returns #f if X is circular. + (let lp ((x x) (lag x) (len 0)) + (if (pair? x) + (let ((x (cdr x)) + (len (+ len 1))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag)) + (len (+ len 1))) + (and (not (eq? x lag)) (lp x lag len))) + len)) + len))) + +(define (zip list1 . more-lists) (apply map list list1 more-lists)) + + +;;; Selectors +;;;;;;;;;;;;; + +;;; R4RS non-primitives: +;(define (caar x) (car (car x))) +;(define (cadr x) (car (cdr x))) +;(define (cdar x) (cdr (car x))) +;(define (cddr x) (cdr (cdr x))) +; +;(define (caaar x) (caar (car x))) +;(define (caadr x) (caar (cdr x))) +;(define (cadar x) (cadr (car x))) +;(define (caddr x) (cadr (cdr x))) +;(define (cdaar x) (cdar (car x))) +;(define (cdadr x) (cdar (cdr x))) +;(define (cddar x) (cddr (car x))) +;(define (cdddr x) (cddr (cdr x))) +; +;(define (caaaar x) (caaar (car x))) +;(define (caaadr x) (caaar (cdr x))) +;(define (caadar x) (caadr (car x))) +;(define (caaddr x) (caadr (cdr x))) +;(define (cadaar x) (cadar (car x))) +;(define (cadadr x) (cadar (cdr x))) +;(define (caddar x) (caddr (car x))) +;(define (cadddr x) (caddr (cdr x))) +;(define (cdaaar x) (cdaar (car x))) +;(define (cdaadr x) (cdaar (cdr x))) +;(define (cdadar x) (cdadr (car x))) +;(define (cdaddr x) (cdadr (cdr x))) +;(define (cddaar x) (cddar (car x))) +;(define (cddadr x) (cddar (cdr x))) +;(define (cdddar x) (cdddr (car x))) +;(define (cddddr x) (cdddr (cdr x))) + + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth x) (car (cddddr x))) +(define (sixth x) (cadr (cddddr x))) +(define (seventh x) (caddr (cddddr x))) +(define (eighth x) (cadddr (cddddr x))) +(define (ninth x) (car (cddddr (cddddr x)))) +(define (tenth x) (cadr (cddddr (cddddr x)))) + +(define (car+cdr pair) (values (car pair) (cdr pair))) + +;;; take & drop + +(define (take lis k) + (check-arg integer? k take) + (let recur ((lis lis) (k k)) + (if (zero? k) '() + (cons (car lis) + (recur (cdr lis) (- k 1)))))) + +(define (drop lis k) + (check-arg integer? k drop) + (let iter ((lis lis) (k k)) + (if (zero? k) lis (iter (cdr lis) (- k 1))))) + +(define (take! lis k) + (check-arg integer? k take!) + (if (zero? k) '() + (begin (set-cdr! (drop lis (- k 1)) '()) + lis))) + +;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, +;;; off by K, then chasing down the list until the lead pointer falls off +;;; the end. + +(define (take-right lis k) + (check-arg integer? k take-right) + (let lp ((lag lis) (lead (drop lis k))) + (if (pair? lead) + (lp (cdr lag) (cdr lead)) + lag))) + +(define (drop-right lis k) + (check-arg integer? k drop-right) + (let recur ((lag lis) (lead (drop lis k))) + (if (pair? lead) + (cons (car lag) (recur (cdr lag) (cdr lead))) + '()))) + +;;; In this function, LEAD is actually K+1 ahead of LAG. This lets +;;; us stop LAG one step early, in time to smash its cdr to (). +(define (drop-right! lis k) + (check-arg integer? k drop-right!) + (let ((lead (drop lis k))) + (if (pair? lead) + + (let lp ((lag lis) (lead (cdr lead))) ; Standard case + (if (pair? lead) + (lp (cdr lag) (cdr lead)) + (begin (set-cdr! lag '()) + lis))) + + '()))) ; Special case dropping everything -- no cons to side-effect. + +;(define (list-ref lis i) (car (drop lis i))) ; R4RS + +;;; These use the APL convention, whereby negative indices mean +;;; "from the right." I liked them, but they didn't win over the +;;; SRFI reviewers. +;;; K >= 0: Take and drop K elts from the front of the list. +;;; K <= 0: Take and drop -K elts from the end of the list. + +;(define (take lis k) +; (check-arg integer? k take) +; (if (negative? k) +; (list-tail lis (+ k (length lis))) +; (let recur ((lis lis) (k k)) +; (if (zero? k) '() +; (cons (car lis) +; (recur (cdr lis) (- k 1))))))) +; +;(define (drop lis k) +; (check-arg integer? k drop) +; (if (negative? k) +; (let recur ((lis lis) (nelts (+ k (length lis)))) +; (if (zero? nelts) '() +; (cons (car lis) +; (recur (cdr lis) (- nelts 1))))) +; (list-tail lis k))) +; +; +;(define (take! lis k) +; (check-arg integer? k take!) +; (cond ((zero? k) '()) +; ((positive? k) +; (set-cdr! (list-tail lis (- k 1)) '()) +; lis) +; (else (list-tail lis (+ k (length lis)))))) +; +;(define (drop! lis k) +; (check-arg integer? k drop!) +; (if (negative? k) +; (let ((nelts (+ k (length lis)))) +; (if (zero? nelts) '() +; (begin (set-cdr! (list-tail lis (- nelts 1)) '()) +; lis))) +; (list-tail lis k))) + +(define (split-at x k) + (check-arg integer? k split-at) + (let recur ((lis x) (k k)) + (if (zero? k) (values '() lis) + (receive (prefix suffix) (recur (cdr lis) (- k 1)) + (values (cons (car lis) prefix) suffix))))) + +(define (split-at! x k) + (check-arg integer? k split-at!) + (if (zero? k) (values '() x) + (let* ((prev (drop x (- k 1))) + (suffix (cdr prev))) + (set-cdr! prev '()) + (values x suffix)))) + + +(define (last lis) (car (last-pair lis))) + +(define (last-pair lis) + (check-arg pair? lis last-pair) + (let lp ((lis lis)) + (let ((tail (cdr lis))) + (if (pair? tail) (lp tail) lis)))) + + +;;; Unzippers -- 1 through 5 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (unzip1 lis) (map car lis)) + +(define (unzip2 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle + (let ((elt (car lis))) ; dotted lists. + (receive (a b) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b))))))) + +(define (unzip3 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis) + (let ((elt (car lis))) + (receive (a b c) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c))))))) + +(define (unzip4 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis lis) + (let ((elt (car lis))) + (receive (a b c d) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c) + (cons (cadddr elt) d))))))) + +(define (unzip5 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis lis lis) + (let ((elt (car lis))) + (receive (a b c d e) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c) + (cons (cadddr elt) d) + (cons (car (cddddr elt)) e))))))) + + +;;; append! append-reverse append-reverse! concatenate concatenate! +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (append! . lists) + ;; First, scan through lists looking for a non-empty one. + (let lp ((lists lists) (prev '())) + (if (not (pair? lists)) prev + (let ((first (car lists)) + (rest (cdr lists))) + (if (not (pair? first)) (lp rest first) + + ;; Now, do the splicing. + (let lp2 ((tail-cons (last-pair first)) + (rest rest)) + (if (pair? rest) + (let ((next (car rest)) + (rest (cdr rest))) + (set-cdr! tail-cons next) + (lp2 (if (pair? next) (last-pair next) tail-cons) + rest)) + first))))))) + +;;; APPEND is R4RS. +;(define (append . lists) +; (if (pair? lists) +; (let recur ((list1 (car lists)) (lists (cdr lists))) +; (if (pair? lists) +; (let ((tail (recur (car lists) (cdr lists)))) +; (fold-right cons tail list1)) ; Append LIST1 & TAIL. +; list1)) +; '())) + +;(define (append-reverse rev-head tail) (fold cons tail rev-head)) + +;(define (append-reverse! rev-head tail) +; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) +; tail +; rev-head)) + +;;; Hand-inline the FOLD and PAIR-FOLD ops for speed. + +(define (append-reverse rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (lp (cdr rev-head) (cons (car rev-head) tail))))) + +(define (append-reverse! rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (let ((next-rev (cdr rev-head))) + (set-cdr! rev-head tail) + (lp next-rev rev-head))))) + + +(define (concatenate lists) (reduce-right append '() lists)) +(define (concatenate! lists) (reduce-right append! '() lists)) + +;;; Fold/map internal utilities +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; These little internal utilities are used by the general +;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined. +;;; One the other hand, the n-ary cases are painfully inefficient as it is. +;;; An aggressive implementation should simply re-write these functions +;;; for raw efficiency; I have written them for as much clarity, portability, +;;; and simplicity as can be achieved. +;;; +;;; I use the dreaded call/cc to do local aborts. A good compiler could +;;; handle this with extreme efficiency. An implementation that provides +;;; a one-shot, non-persistent continuation grabber could help the compiler +;;; out by using that in place of the call/cc's in these routines. +;;; +;;; These functions have funky definitions that are precisely tuned to +;;; the needs of the fold/map procs -- for example, to minimize the number +;;; of times the argument lists need to be examined. + +;;; Return (map cdr lists). +;;; However, if any element of LISTS is empty, just abort and return '(). +(define (%cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (let ((lis (car lists))) + (if (null-list? lis) (abort '()) + (cons (cdr lis) (recur (cdr lists))))) + '()))))) + +(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) + (let recur ((lists lists)) + (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) + +;;; LISTS is a (not very long) non-empty list of lists. +;;; Return two lists: the cars & the cdrs of the lists. +;;; However, if any of the lists is empty, just abort and return [() ()]. + +(define (%cars+cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs)))))) + (values '() '())))))) + +;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the +;;; cars list. What a hack. +(define (%cars+cdrs+ lists cars-final) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs)))))) + (values (list cars-final) '())))))) + +;;; Like %CARS+CDRS, but blow up if any list is empty. +(define (%cars+cdrs/no-test lists) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs))))) + (values '() '())))) + + +;;; count +;;;;;;;;; +(define (count pred list1 . lists) + (check-arg procedure? pred count) + (if (pair? lists) + + ;; N-ary case + (let lp ((list1 list1) (lists lists) (i 0)) + (if (null-list? list1) i + (receive (as ds) (%cars+cdrs lists) + (if (null? as) i + (lp (cdr list1) ds + (if (apply pred (car list1) as) (+ i 1) i)))))) + + ;; Fast path + (let lp ((lis list1) (i 0)) + (if (null-list? lis) i + (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) + + +;;; fold/unfold +;;;;;;;;;;;;;;; + +(define (unfold-right p f g seed . maybe-tail) + (check-arg procedure? p unfold-right) + (check-arg procedure? f unfold-right) + (check-arg procedure? g unfold-right) + (let lp ((seed seed) (ans (optional maybe-tail '()))) + (if (p seed) ans + (lp (g seed) + (cons (f seed) ans))))) + + +(define (unfold p f g seed . maybe-tail-gen) + (check-arg procedure? p unfold) + (check-arg procedure? f unfold) + (check-arg procedure? g unfold) + (if (pair? maybe-tail-gen) + + (let ((tail-gen (car maybe-tail-gen))) + (if (pair? (cdr maybe-tail-gen)) + (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) + + (let recur ((seed seed)) + (if (p seed) (tail-gen seed) + (cons (f seed) (recur (g seed))))))) + + (let recur ((seed seed)) + (if (p seed) '() + (cons (f seed) (recur (g seed))))))) + + +(define (fold kons knil lis1 . lists) + (check-arg procedure? kons fold) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case + (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) + (if (null? cars+ans) ans ; Done. + (lp cdrs (apply kons cars+ans))))) + + (let lp ((lis lis1) (ans knil)) ; Fast path + (if (null-list? lis) ans + (lp (cdr lis) (kons (car lis) ans)))))) + + +(define (fold-right kons knil lis1 . lists) + (check-arg procedure? kons fold-right) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) ; N-ary case + (let ((cdrs (%cdrs lists))) + (if (null? cdrs) knil + (apply kons (%cars+ lists (recur cdrs)))))) + + (let recur ((lis lis1)) ; Fast path + (if (null-list? lis) knil + (let ((head (car lis))) + (kons head (recur (cdr lis)))))))) + + +(define (pair-fold-right f zero lis1 . lists) + (check-arg procedure? f pair-fold-right) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) ; N-ary case + (let ((cdrs (%cdrs lists))) + (if (null? cdrs) zero + (apply f (append! lists (list (recur cdrs))))))) + + (let recur ((lis lis1)) ; Fast path + (if (null-list? lis) zero (f lis (recur (cdr lis))))))) + +(define (pair-fold f zero lis1 . lists) + (check-arg procedure? f pair-fold) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case + (let ((tails (%cdrs lists))) + (if (null? tails) ans + (lp tails (apply f (append! lists (list ans))))))) + + (let lp ((lis lis1) (ans zero)) + (if (null-list? lis) ans + (let ((tail (cdr lis))) ; Grab the cdr now, + (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. + + +;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. +;;; These cannot meaningfully be n-ary. + +(define (reduce f ridentity lis) + (check-arg procedure? f reduce) + (if (null-list? lis) ridentity + (fold f (car lis) (cdr lis)))) + +(define (reduce-right f ridentity lis) + (check-arg procedure? f reduce-right) + (if (null-list? lis) ridentity + (let recur ((head (car lis)) (lis (cdr lis))) + (if (pair? lis) + (f head (recur (car lis) (cdr lis))) + head)))) + + + +;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (append-map f lis1 . lists) + (really-append-map append-map append f lis1 lists)) +(define (append-map! f lis1 . lists) + (really-append-map append-map! append! f lis1 lists)) + +(define (really-append-map who appender f lis1 lists) + (check-arg procedure? f who) + (if (pair? lists) + (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) + (if (null? cars) '() + (let recur ((cars cars) (cdrs cdrs)) + (let ((vals (apply f cars))) + (receive (cars2 cdrs2) (%cars+cdrs cdrs) + (if (null? cars2) vals + (appender vals (recur cars2 cdrs2)))))))) + + ;; Fast path + (if (null-list? lis1) '() + (let recur ((elt (car lis1)) (rest (cdr lis1))) + (let ((vals (f elt))) + (if (null-list? rest) vals + (appender vals (recur (car rest) (cdr rest))))))))) + + +(define (pair-for-each proc lis1 . lists) + (check-arg procedure? proc pair-for-each) + (if (pair? lists) + + (let lp ((lists (cons lis1 lists))) + (let ((tails (%cdrs lists))) + (if (pair? tails) + (begin (apply proc lists) + (lp tails))))) + + ;; Fast path. + (let lp ((lis lis1)) + (if (not (null-list? lis)) + (let ((tail (cdr lis))) ; Grab the cdr now, + (proc lis) ; in case PROC SET-CDR!s LIS. + (lp tail)))))) + +;;; We stop when LIS1 runs out, not when any list runs out. +(define (map! f lis1 . lists) + (check-arg procedure? f map!) + (if (pair? lists) + (let lp ((lis1 lis1) (lists lists)) + (if (not (null-list? lis1)) + (receive (heads tails) (%cars+cdrs/no-test lists) + (set-car! lis1 (apply f (car lis1) heads)) + (lp (cdr lis1) tails)))) + + ;; Fast path. + (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) + lis1) + + +;;; Map F across L, and save up all the non-false results. +(define (filter-map f lis1 . lists) + (check-arg procedure? f filter-map) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) + (else (recur cdrs))) ; Tail call in this arm. + '()))) + + ;; Fast path. + (let recur ((lis lis1)) + (if (null-list? lis) lis + (let ((tail (recur (cdr lis)))) + (cond ((f (car lis)) => (lambda (x) (cons x tail))) + (else tail))))))) + + +;;; Map F across lists, guaranteeing to go left-to-right. +;;; NOTE: Some implementations of R5RS MAP are compliant with this spec; +;;; in which case this procedure may simply be defined as a synonym for MAP. + +(define (map-in-order f lis1 . lists) + (check-arg procedure? f map-in-order) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (let ((x (apply f cars))) ; Do head first, + (cons x (recur cdrs))) ; then tail. + '()))) + + ;; Fast path. + (let recur ((lis lis1)) + (if (null-list? lis) lis + (let ((tail (cdr lis)) + (x (f (car lis)))) ; Do head first, + (cons x (recur tail))))))) ; then tail. + + +;;; We extend MAP to handle arguments of unequal length. +;(define map map-in-order) + + +;;; filter, remove, partition +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not +;;; disorder the elements of their argument. + +;; This FILTER shares the longest tail of L that has no deleted elements. +;; If Scheme had multi-continuation calls, they could be made more efficient. + +(define (filter pred lis) ; Sleazing with EQ? makes this + (check-arg procedure? pred filter) ; one faster. + (let recur ((lis lis)) + (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. + (let ((head (car lis)) + (tail (cdr lis))) + (if (pred head) + (let ((new-tail (recur tail))) ; Replicate the RECUR call so + (if (eq? tail new-tail) lis + (cons head new-tail))) + (recur tail)))))) ; this one can be a tail call. + + +;;; Another version that shares longest tail. +;(define (filter pred lis) +; (receive (ans no-del?) +; ;; (recur l) returns L with (pred x) values filtered. +; ;; It also returns a flag NO-DEL? if the returned value +; ;; is EQ? to L, i.e. if it didn't have to delete anything. +; (let recur ((l l)) +; (if (null-list? l) (values l #t) +; (let ((x (car l)) +; (tl (cdr l))) +; (if (pred x) +; (receive (ans no-del?) (recur tl) +; (if no-del? +; (values l #t) +; (values (cons x ans) #f))) +; (receive (ans no-del?) (recur tl) ; Delete X. +; (values ans #f)))))) +; ans)) + + + +;(define (filter! pred lis) ; Things are much simpler +; (let recur ((lis lis)) ; if you are willing to +; (if (pair? lis) ; push N stack frames & do N +; (cond ((pred (car lis)) ; SET-CDR! writes, where N is +; (set-cdr! lis (recur (cdr lis))); the length of the answer. +; lis) +; (else (recur (cdr lis)))) +; lis))) + + +;;; This implementation of FILTER! +;;; - doesn't cons, and uses no stack; +;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are +;;; usually expensive on modern machines, and can be extremely expensive on +;;; modern Schemes (e.g., ones that have generational GC's). +;;; It just zips down contiguous runs of in and out elts in LIS doing the +;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the +;;; beginning of the next. + +(define (filter! pred lis) + (check-arg procedure? pred filter!) + (let lp ((ans lis)) + (cond ((null-list? ans) ans) ; Scan looking for + ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. + + ;; ANS is the eventual answer. + ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. + ;; Scan over a contiguous segment of the list that + ;; satisfies PRED. + ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous + ;; segment of the list that *doesn't* satisfy PRED. + ;; When the segment ends, patch in a link from PREV + ;; to the start of the next good segment, and jump to + ;; SCAN-IN. + (else (letrec ((scan-in (lambda (prev lis) + (if (pair? lis) + (if (pred (car lis)) + (scan-in lis (cdr lis)) + (scan-out prev (cdr lis)))))) + (scan-out (lambda (prev lis) + (let lp ((lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (begin (set-cdr! prev lis) + (scan-in lis (cdr lis))) + (lp (cdr lis))) + (set-cdr! prev lis)))))) + (scan-in ans (cdr ans)) + ans))))) + + + +;;; Answers share common tail with LIS where possible; +;;; the technique is slightly subtle. + +(define (partition pred lis) + (check-arg procedure? pred partition) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. + (let ((elt (car lis)) + (tail (cdr lis))) + (receive (in out) (recur tail) + (if (pred elt) + (values (if (pair? out) (cons elt in) lis) out) + (values in (if (pair? in) (cons elt out) lis)))))))) + + + +;(define (partition! pred lis) ; Things are much simpler +; (let recur ((lis lis)) ; if you are willing to +; (if (null-list? lis) (values lis lis) ; push N stack frames & do N +; (let ((elt (car lis))) ; SET-CDR! writes, where N is +; (receive (in out) (recur (cdr lis)) ; the length of LIS. +; (cond ((pred elt) +; (set-cdr! lis in) +; (values lis out)) +; (else (set-cdr! lis out) +; (values in lis)))))))) + + +;;; This implementation of PARTITION! +;;; - doesn't cons, and uses no stack; +;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are +;;; usually expensive on modern machines, and can be extremely expensive on +;;; modern Schemes (e.g., ones that have generational GC's). +;;; It just zips down contiguous runs of in and out elts in LIS doing the +;;; minimal number of SET-CDR!s to splice these runs together into the result +;;; lists. + +(define (partition! pred lis) + (check-arg procedure? pred partition!) + (if (null-list? lis) (values lis lis) + + ;; This pair of loops zips down contiguous in & out runs of the + ;; list, splicing the runs together. The invariants are + ;; SCAN-IN: (cdr in-prev) = LIS. + ;; SCAN-OUT: (cdr out-prev) = LIS. + (letrec ((scan-in (lambda (in-prev out-prev lis) + (let lp ((in-prev in-prev) (lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (lp lis (cdr lis)) + (begin (set-cdr! out-prev lis) + (scan-out in-prev lis (cdr lis)))) + (set-cdr! out-prev lis))))) ; Done. + + (scan-out (lambda (in-prev out-prev lis) + (let lp ((out-prev out-prev) (lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (begin (set-cdr! in-prev lis) + (scan-in lis out-prev (cdr lis))) + (lp lis (cdr lis))) + (set-cdr! in-prev lis)))))) ; Done. + + ;; Crank up the scan&splice loops. + (if (pred (car lis)) + ;; LIS begins in-list. Search for out-list's first pair. + (let lp ((prev-l lis) (l (cdr lis))) + (cond ((not (pair? l)) (values lis l)) + ((pred (car l)) (lp l (cdr l))) + (else (scan-out prev-l l (cdr l)) + (values lis l)))) ; Done. + + ;; LIS begins out-list. Search for in-list's first pair. + (let lp ((prev-l lis) (l (cdr lis))) + (cond ((not (pair? l)) (values l lis)) + ((pred (car l)) + (scan-in l prev-l (cdr l)) + (values l lis)) ; Done. + (else (lp l (cdr l))))))))) + + +;;; Inline us, please. +(define (remove pred l) (filter (lambda (x) (not (pred x))) l)) +(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) + + + +;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions. +;;; (I don't actually think these are the world's most important +;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants +;;; are far more general.) +;;; +;;; Function Action +;;; --------------------------------------------------------------------------- +;;; remove pred lis Delete by general predicate +;;; delete x lis [=] Delete by element comparison +;;; +;;; find pred lis Search by general predicate +;;; find-tail pred lis Search by general predicate +;;; member x lis [=] Search by element comparison +;;; +;;; assoc key lis [=] Search alist by key comparison +;;; alist-delete key alist [=] Alist-delete by key comparison + +(define (delete x lis . maybe-=) + (let ((= (optional maybe-= equal?))) + (filter (lambda (y) (not (= x y))) lis))) + +(define (delete! x lis . maybe-=) + (let ((= (optional maybe-= equal?))) + (filter! (lambda (y) (not (= x y))) lis))) + +;;; Extended from R4RS to take an optional comparison argument. +#;(define (member x lis . maybe-=) +(let ((= (optional maybe-= equal?))) + (find-tail (lambda (y) (= x y)) lis))) + +;;; R4RS, hence we don't bother to define. +;;; The MEMBER and then FIND-TAIL call should definitely +;;; be inlined for MEMQ & MEMV. +;(define (memq x lis) (member x lis eq?)) +;(define (memv x lis) (member x lis eqv?)) + + +;;; right-duplicate deletion +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; delete-duplicates delete-duplicates! +;;; +;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates +;;; in long lists, sort the list to bring duplicates together, then use a +;;; linear-time algorithm to kill the dups. Or use an algorithm based on +;;; element-marking. The former gives you O(n lg n), the latter is linear. + +(define (delete-duplicates lis . maybe-=) + (let ((elt= (optional maybe-= equal?))) + (check-arg procedure? elt= delete-duplicates) + (let recur ((lis lis)) + (if (null-list? lis) lis + (let* ((x (car lis)) + (tail (cdr lis)) + (new-tail (recur (delete x tail elt=)))) + (if (eq? tail new-tail) lis (cons x new-tail))))))) + +(define (delete-duplicates! lis . maybe-=) + (let ((elt= (optional maybe-= equal?))) + (check-arg procedure? elt= delete-duplicates!) + (let recur ((lis lis)) + (if (null-list? lis) lis + (let* ((x (car lis)) + (tail (cdr lis)) + (new-tail (recur (delete! x tail elt=)))) + (if (eq? tail new-tail) lis (cons x new-tail))))))) + + +;;; alist stuff +;;;;;;;;;;;;;;; + +;;; Extended from R4RS to take an optional comparison argument. +#;(define (assoc x lis . maybe-=) +(let ((= (optional maybe-= equal?))) + (find (lambda (entry) (= x (car entry))) lis))) + +(define (alist-cons key datum alist) (cons (cons key datum) alist)) + +(define (alist-copy alist) + (map (lambda (elt) (cons (car elt) (cdr elt))) + alist)) + +(define (alist-delete key alist . maybe-=) + (let ((= (optional maybe-= equal?))) + (filter (lambda (elt) (not (= key (car elt)))) alist))) + +(define (alist-delete! key alist . maybe-=) + (let ((= (optional maybe-= equal?))) + (filter! (lambda (elt) (not (= key (car elt)))) alist))) + + +;;; find find-tail take-while drop-while span break any every list-index +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (find pred list) + (cond ((find-tail pred list) => car) + (else #f))) + +(define (find-tail pred list) + (check-arg procedure? pred find-tail) + (let lp ((list list)) + (and (not (null-list? list)) + (if (pred (car list)) list + (lp (cdr list)))))) + +(define (take-while pred lis) + (check-arg procedure? pred take-while) + (let recur ((lis lis)) + (if (null-list? lis) '() + (let ((x (car lis))) + (if (pred x) + (cons x (recur (cdr lis))) + '()))))) + +(define (drop-while pred lis) + (check-arg procedure? pred drop-while) + (let lp ((lis lis)) + (if (null-list? lis) '() + (if (pred (car lis)) + (lp (cdr lis)) + lis)))) + +(define (take-while! pred lis) + (check-arg procedure? pred take-while!) + (if (or (null-list? lis) (not (pred (car lis)))) '() + (begin (let lp ((prev lis) (rest (cdr lis))) + (if (pair? rest) + (let ((x (car rest))) + (if (pred x) (lp rest (cdr rest)) + (set-cdr! prev '()))))) + lis))) + +(define (span pred lis) + (check-arg procedure? pred span) + (let recur ((lis lis)) + (if (null-list? lis) (values '() '()) + (let ((x (car lis))) + (if (pred x) + (receive (prefix suffix) (recur (cdr lis)) + (values (cons x prefix) suffix)) + (values '() lis)))))) + +(define (span! pred lis) + (check-arg procedure? pred span!) + (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) + (let ((suffix (let lp ((prev lis) (rest (cdr lis))) + (if (null-list? rest) rest + (let ((x (car rest))) + (if (pred x) (lp rest (cdr rest)) + (begin (set-cdr! prev '()) + rest))))))) + (values lis suffix)))) + + +(define (break pred lis) (span (lambda (x) (not (pred x))) lis)) +(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) + +(define (any pred lis1 . lists) + (check-arg procedure? pred any) + (if (pair? lists) + + ;; N-ary case + (receive (heads tails) (%cars+cdrs (cons lis1 lists)) + (and (pair? heads) + (let lp ((heads heads) (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (or (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))) ; Last PRED app is tail call. + + ;; Fast path + (and (not (null-list? lis1)) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null-list? tail) + (pred head) ; Last PRED app is tail call. + (or (pred head) (lp (car tail) (cdr tail)))))))) + + +;(define (every pred list) ; Simple definition. +; (let lp ((list list)) ; Doesn't return the last PRED value. +; (or (not (pair? list)) +; (and (pred (car list)) +; (lp (cdr list)))))) + +(define (every pred lis1 . lists) + (check-arg procedure? pred every) + (if (pair? lists) + + ;; N-ary case + (receive (heads tails) (%cars+cdrs (cons lis1 lists)) + (or (not (pair? heads)) + (let lp ((heads heads) (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (and (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))) ; Last PRED app is tail call. + + ;; Fast path + (or (null-list? lis1) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null-list? tail) + (pred head) ; Last PRED app is tail call. + (and (pred head) (lp (car tail) (cdr tail)))))))) + +(define (list-index pred lis1 . lists) + (check-arg procedure? pred list-index) + (if (pair? lists) + + ;; N-ary case + (let lp ((lists (cons lis1 lists)) (n 0)) + (receive (heads tails) (%cars+cdrs lists) + (and (pair? heads) + (if (apply pred heads) n + (lp tails (+ n 1)))))) + + ;; Fast path + (let lp ((lis lis1) (n 0)) + (and (not (null-list? lis)) + (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) + +;;; Reverse +;;;;;;;;;;; + +;R4RS, so not defined here. +;(define (reverse lis) (fold cons '() lis)) + +;(define (reverse! lis) +; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis)) + +(define (reverse! lis) + (let lp ((lis lis) (ans '())) + (if (null-list? lis) ans + (let ((tail (cdr lis))) + (set-cdr! lis ans) + (lp tail lis))))) + +;;; Lists-as-sets +;;;;;;;;;;;;;;;;; + +;;; This is carefully tuned code; do not modify casually. +;;; - It is careful to share storage when possible; +;;; - Side-effecting code tries not to perform redundant writes. +;;; - It tries to avoid linear-time scans in special cases where constant-time +;;; computations can be performed. +;;; - It relies on similar properties from the other list-lib procs it calls. +;;; For example, it uses the fact that the implementations of MEMBER and +;;; FILTER in this source code share longest common tails between args +;;; and results to get structure sharing in the lset procedures. + +(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1)) + +(define (lset<= = . lists) + (check-arg procedure? = lset<=) + (or (not (pair? lists)) ; 0-ary case + (let lp ((s1 (car lists)) (rest (cdr lists))) + (or (not (pair? rest)) + (let ((s2 (car rest)) (rest (cdr rest))) + (and (or (eq? s2 s1) ; Fast path + (%lset2<= = s1 s2)) ; Real test + (lp s2 rest))))))) + +(define (lset= = . lists) + (define (flip proc) (lambda (x y) (proc y x))) + (check-arg procedure? = lset=) + (or (not (pair? lists)) ; 0-ary case + (let lp ((s1 (car lists)) (rest (cdr lists))) + (or (not (pair? rest)) + (let ((s2 (car rest)) + (rest (cdr rest))) + (and (or (eq? s1 s2) ; Fast path + (and (%lset2<= = s1 s2) ; Real test + (%lset2<= (flip =) s2 s1))) + (lp s2 rest))))))) + +(define (lset-adjoin = lis . elts) + (check-arg procedure? = lset-adjoin) + (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) + lis elts)) + + +(define (lset-union = . lists) + (check-arg procedure? = lset-union) + (reduce (lambda (lis ans) ; Compute ANS + LIS. + (cond ((null? lis) ans) ; Don't copy any lists + ((null? ans) lis) ; if we don't have to. + ((eq? lis ans) ans) + (else + (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) + ans + (cons elt ans))) + ans lis)))) + '() lists)) + +(define (lset-union! = . lists) + (check-arg procedure? = lset-union!) + (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. + (cond ((null? lis) ans) ; Don't copy any lists + ((null? ans) lis) ; if we don't have to. + ((eq? lis ans) ans) + (else + (pair-fold (lambda (pair ans) + (let ((elt (car pair))) + (if (any (lambda (x) (= x elt)) ans) + ans + (begin (set-cdr! pair ans) pair)))) + ans lis)))) + '() lists)) + + +(define (lset-intersection = lis1 . lists) + (check-arg procedure? = lset-intersection) + (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. + (cond ((any null-list? lists) '()) ; Short cut + ((null? lists) lis1) ; Short cut + (else (filter (lambda (x) + (every (lambda (lis) (member x lis =)) lists)) + lis1))))) + +(define (lset-intersection! = lis1 . lists) + (check-arg procedure? = lset-intersection!) + (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. + (cond ((any null-list? lists) '()) ; Short cut + ((null? lists) lis1) ; Short cut + (else (filter! (lambda (x) + (every (lambda (lis) (member x lis =)) lists)) + lis1))))) + + +(define (lset-difference = lis1 . lists) + (check-arg procedure? = lset-difference) + (let ((lists (filter pair? lists))) ; Throw out empty lists. + (cond ((null? lists) lis1) ; Short cut + ((memq lis1 lists) '()) ; Short cut + (else (filter (lambda (x) + (every (lambda (lis) (not (member x lis =))) + lists)) + lis1))))) + +(define (lset-difference! = lis1 . lists) + (check-arg procedure? = lset-difference!) + (let ((lists (filter pair? lists))) ; Throw out empty lists. + (cond ((null? lists) lis1) ; Short cut + ((memq lis1 lists) '()) ; Short cut + (else (filter! (lambda (x) + (every (lambda (lis) (not (member x lis =))) + lists)) + lis1))))) + + +(define (lset-xor = . lists) + (check-arg procedure? = lset-xor) + (reduce (lambda (b a) ; Compute A xor B: + ;; Note that this code relies on the constant-time + ;; short-cuts provided by LSET-DIFF+INTERSECTION, + ;; LSET-DIFFERENCE & APPEND to provide constant-time short + ;; cuts for the cases A = (), B = (), and A eq? B. It takes + ;; a careful case analysis to see it, but it's carefully + ;; built in. + + ;; Compute a-b and a^b, then compute b-(a^b) and + ;; cons it onto the front of a-b. + (receive (a-b a-int-b) (lset-diff+intersection = a b) + (cond ((null? a-b) (lset-difference = b a)) + ((null? a-int-b) (append b a)) + (else (fold (lambda (xb ans) + (if (member xb a-int-b =) ans (cons xb ans))) + a-b + b))))) + '() lists)) + + +(define (lset-xor! = . lists) + (check-arg procedure? = lset-xor!) + (reduce (lambda (b a) ; Compute A xor B: + ;; Note that this code relies on the constant-time + ;; short-cuts provided by LSET-DIFF+INTERSECTION, + ;; LSET-DIFFERENCE & APPEND to provide constant-time short + ;; cuts for the cases A = (), B = (), and A eq? B. It takes + ;; a careful case analysis to see it, but it's carefully + ;; built in. + + ;; Compute a-b and a^b, then compute b-(a^b) and + ;; cons it onto the front of a-b. + (receive (a-b a-int-b) (lset-diff+intersection! = a b) + (cond ((null? a-b) (lset-difference! = b a)) + ((null? a-int-b) (append! b a)) + (else (pair-fold (lambda (b-pair ans) + (if (member (car b-pair) a-int-b =) ans + (begin (set-cdr! b-pair ans) b-pair))) + a-b + b))))) + '() lists)) + + +(define (lset-diff+intersection = lis1 . lists) + (check-arg procedure? = lset-diff+intersection) + (cond ((every null-list? lists) (values lis1 '())) ; Short cut + ((memq lis1 lists) (values '() lis1)) ; Short cut + (else (partition (lambda (elt) + (not (any (lambda (lis) (member elt lis =)) + lists))) + lis1)))) + +(define (lset-diff+intersection! = lis1 . lists) + (check-arg procedure? = lset-diff+intersection!) + (cond ((every null-list? lists) (values lis1 '())) ; Short cut + ((memq lis1 lists) (values '() lis1)) ; Short cut + (else (partition! (lambda (elt) + (not (any (lambda (lis) (member elt lis =)) + lists))) + lis1)))) diff --git a/snow/srfi/1.sld b/snow/srfi/1.sld new file mode 100644 index 0000000..1fb6c3d --- /dev/null +++ b/snow/srfi/1.sld @@ -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"))) diff --git a/snow/srfi/8.scm b/snow/srfi/8.scm new file mode 100644 index 0000000..cda08b9 --- /dev/null +++ b/snow/srfi/8.scm @@ -0,0 +1,5 @@ +(define-syntax receive + (syntax-rules () + ((receive formals expression body ...) + (call-with-values (lambda () expression) + (lambda formals body ...))))) diff --git a/snow/srfi/8.sld b/snow/srfi/8.sld new file mode 100644 index 0000000..bb637b4 --- /dev/null +++ b/snow/srfi/8.sld @@ -0,0 +1,6 @@ +(define-library + (srfi 8) + (import (scheme base)) + (export receive) + (begin + (include "8.scm"))) diff --git a/templates/Jenkinsfile-bottom b/templates/Jenkinsfile-bottom new file mode 100644 index 0000000..6f57eb4 --- /dev/null +++ b/templates/Jenkinsfile-bottom @@ -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() + } + } +} diff --git a/templates/Jenkinsfile-job b/templates/Jenkinsfile-job new file mode 100644 index 0000000..cd14f05 --- /dev/null +++ b/templates/Jenkinsfile-job @@ -0,0 +1,2 @@ + {{#library-command}}sh '{{{library-command}}}'{{/library-command}} + sh '{{{command}}}' diff --git a/templates/Jenkinsfile-job-bottom b/templates/Jenkinsfile-job-bottom new file mode 100644 index 0000000..df07bcc --- /dev/null +++ b/templates/Jenkinsfile-job-bottom @@ -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' + } + } + } diff --git a/templates/Jenkinsfile-job-top b/templates/Jenkinsfile-job-top new file mode 100644 index 0000000..fc58d12 --- /dev/null +++ b/templates/Jenkinsfile-job-top @@ -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' diff --git a/templates/Jenkinsfile-top b/templates/Jenkinsfile-top new file mode 100644 index 0000000..e687afc --- /dev/null +++ b/templates/Jenkinsfile-top @@ -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 "

Test results

" > reports/results.html' + sh '(cd srfi-test && make clean build)' + sh 'tree srfi-test' + stash name: 'tests', includes: 'srfi-test/*' + } + } diff --git a/templates/Makefile-bottom b/templates/Makefile-bottom new file mode 100644 index 0000000..4411afe --- /dev/null +++ b/templates/Makefile-bottom @@ -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 diff --git a/templates/Makefile-job b/templates/Makefile-job new file mode 100644 index 0000000..5591aa3 --- /dev/null +++ b/templates/Makefile-job @@ -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}}}" + diff --git a/templates/Makefile-top b/templates/Makefile-top new file mode 100644 index 0000000..e69de29 diff --git a/templates/Report-bottom b/templates/Report-bottom new file mode 100644 index 0000000..323aa72 --- /dev/null +++ b/templates/Report-bottom @@ -0,0 +1,17 @@ + + +
    + Numbers +
  • # of expected passes
    • +
  • # of expected failures
    • +
  • # of unexpected failures
    • +
  • # of skipped tests
    • +
+
    + Colors +
  • Red: # of unexpected failures > 0
    • +
  • Yellow: # of skipped tests > 0
    • +
  • Green: none of the above
    • +
+ + diff --git a/templates/Report-row b/templates/Report-row new file mode 100644 index 0000000..9ba9df8 --- /dev/null +++ b/templates/Report-row @@ -0,0 +1,6 @@ + + {{expected-passes}} + {{expected-failures}} + {{unexpected-failures}} + {{skipped-tests}} + diff --git a/templates/Report-top b/templates/Report-top new file mode 100644 index 0000000..a369750 --- /dev/null +++ b/templates/Report-top @@ -0,0 +1,16 @@ + + + + R7RS-SRFI Test results + + + + + diff --git a/test.scm b/test.scm new file mode 100644 index 0000000..4be7789 --- /dev/null +++ b/test.scm @@ -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 ( ...)) " + (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))) diff --git a/tests.scm b/tests.scm new file mode 100644 index 0000000..7d4c369 --- /dev/null +++ b/tests.scm @@ -0,0 +1,3 @@ +(define tests + '(((name . "r7rs-test") + (file . "r7rs-tests.scm")))) diff --git a/update-srfis b/update-srfis new file mode 100755 index 0000000..cc2ae21 --- /dev/null +++ b/update-srfis @@ -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 diff --git a/update-tests b/update-tests new file mode 100755 index 0000000..8608228 --- /dev/null +++ b/update-tests @@ -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 diff --git a/util.scm b/util.scm new file mode 100644 index 0000000..e7f715c --- /dev/null +++ b/util.scm @@ -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)) ""))))
R7RS-SRFI Test results