mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-16 17:37:34 +02:00
4e75fbab49
Adding test-library option to automatically infer tests from libraries. Processing scribble docs even when we can't load the module.
231 lines
8.7 KiB
Scheme
231 lines
8.7 KiB
Scheme
(import (scheme base) (scheme write) (scheme process-context) (srfi 1)
|
|
(chibi ast) (chibi config) (chibi filesystem) (chibi match)
|
|
(chibi pathname) (chibi process) (chibi regexp) (chibi string)
|
|
(chibi io) (chibi tar) (chibi test)
|
|
(chibi snow package))
|
|
|
|
(test-begin "snow")
|
|
|
|
;; setup a temp root to install packages
|
|
(define install-prefix (make-path (current-directory) "tests/snow/tmp-root"))
|
|
(define install-libdir (make-path install-prefix "/share/snow/chibi"))
|
|
(if (file-exists? install-prefix)
|
|
(delete-file-hierarchy install-prefix))
|
|
(create-directory install-prefix)
|
|
|
|
;; setup chicken install directory with minimum required modules
|
|
(define chicken-lib-dir "/usr/local/lib/chicken/7")
|
|
(define chicken-install-dir (make-path install-prefix "/share/snow/chicken"))
|
|
(create-directory* chicken-install-dir)
|
|
(if (file-exists? chicken-lib-dir)
|
|
(let ((rx-required
|
|
'(: (or "chicken" "csi" "data-structures" "extras" "files"
|
|
"foreign" "irregex" "lolevel" "make" "matchable"
|
|
"modules" "numbers" "ports" "posix" "r7rs" "scheme"
|
|
"srfi" "tcp" "types" "utils")
|
|
(or "." "-")
|
|
(* any))))
|
|
(for-each
|
|
(lambda (file)
|
|
(if (regexp-matches? rx-required file)
|
|
(system 'cp
|
|
(make-path chicken-lib-dir file)
|
|
chicken-install-dir)))
|
|
(directory-files chicken-lib-dir))))
|
|
(setenv "CHICKEN_REPOSITORY" chicken-install-dir)
|
|
|
|
;; ignore any personal config settings
|
|
(setenv "SNOW_CHIBI_CONFIG" "no-such-file")
|
|
|
|
;; run snow-chibi command as a separate process with test defaults
|
|
(define chibi-path "./chibi-scheme")
|
|
(define (snow-command . args)
|
|
`(,chibi-path -A ,install-libdir "tools/snow-chibi"
|
|
--always-no
|
|
--implementations "chibi"
|
|
--chibi-path ,(string-append chibi-path " -A " install-libdir)
|
|
--install-prefix ,install-prefix
|
|
--local-user-repository "tests/snow/repo-cache"
|
|
,@args))
|
|
|
|
(define-syntax snow
|
|
(syntax-rules ()
|
|
((snow args ...)
|
|
(match (process->output+error+status (apply snow-command `(args ...)))
|
|
((output error (? zero?))
|
|
;; (display output)
|
|
;; (display error)
|
|
)
|
|
((output error status)
|
|
(display "Snow failed: ")
|
|
(display status)
|
|
(newline)
|
|
(display output)
|
|
(display error)
|
|
(newline))
|
|
(other
|
|
(display "Snow error:\n")
|
|
(display other)
|
|
(newline))))))
|
|
|
|
(define-syntax snow->string
|
|
(syntax-rules ()
|
|
((snow->string args ...)
|
|
(process->string (apply snow-command `(args ...))))))
|
|
|
|
(define-syntax snow->sexp
|
|
(syntax-rules ()
|
|
((snow->sexp args ...)
|
|
(process->sexp (apply snow-command `(--sexp args ...))))))
|
|
|
|
(define-syntax snow-status
|
|
(syntax-rules ()
|
|
((snow-status args ...)
|
|
(snow->sexp args ... status))))
|
|
|
|
(define (installed-status status lib-name . o)
|
|
(let* ((impl (if (pair? o) (car o) 'chibi))
|
|
(impl-status (assq impl status)))
|
|
(and impl-status
|
|
(assoc lib-name (cdr impl-status)))))
|
|
|
|
(define (installed-version status lib-name . o)
|
|
(cond ((apply installed-status status lib-name o) => cadr)
|
|
(else #f)))
|
|
|
|
(define (snowball-test->sexp-list pkg file)
|
|
(let ((path (make-path (package-file-top-directory file)
|
|
(assoc-get pkg 'test))))
|
|
(call-with-input-string
|
|
(utf8->string (tar-extract-file (package-file-unzipped file) path))
|
|
port->sexp-list)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; basics
|
|
|
|
;; package
|
|
(snow package --output-dir tests/snow --authors "Édouard Lucas"
|
|
--description "Lucas recurrence relation"
|
|
tests/snow/repo0/edouard/lucas.sld)
|
|
(test-assert (file-exists? "tests/snow/edouard-lucas.tgz"))
|
|
|
|
;; install
|
|
(snow install tests/snow/edouard-lucas.tgz)
|
|
(define lucas-sld-path
|
|
(make-path install-libdir "edouard/lucas.sld"))
|
|
(test-assert (file-exists? lucas-sld-path))
|
|
(delete-file "tests/snow/edouard-lucas.tgz")
|
|
|
|
;; status
|
|
(test-assert (installed-status (snow-status) '(edouard lucas)))
|
|
|
|
;; remove
|
|
(snow remove edouard.lucas)
|
|
(test-not (file-exists? lucas-sld-path))
|
|
(test-not (installed-version (snow-status) '(edouard lucas)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; install/upgrade via local repos
|
|
|
|
(define repo1 '(--repository-uri tests/snow/repo1/repo.scm))
|
|
(snow package --output-dir tests/snow/repo1/
|
|
--version 1.0 --authors "Leonardo Fibonacci"
|
|
--description "Fibonacci recurrence relation"
|
|
--test tests/snow/repo1/leonardo/fibonacci-test.scm
|
|
tests/snow/repo1/leonardo/fibonacci.sld)
|
|
(snow index ,(cadr repo1) tests/snow/repo1/leonardo-fibonacci-1.0.tgz)
|
|
(snow ,@repo1 update)
|
|
(snow ,@repo1 install --show-tests leonardo.fibonacci)
|
|
(test "1.0" (installed-version (snow-status) '(leonardo fibonacci)))
|
|
|
|
(define repo2 '(--repository-uri tests/snow/repo2/repo.scm))
|
|
(snow package --output-dir tests/snow/repo2/
|
|
--version 1.1 --authors "Leonardo Fibonacci"
|
|
--description "Fibonacci recurrence relation"
|
|
--test tests/snow/repo2/leonardo/fibonacci-test.scm
|
|
tests/snow/repo2/leonardo/fibonacci.sld)
|
|
(snow index ,(cadr repo2))
|
|
(snow ,@repo2 update)
|
|
(snow ,@repo2 upgrade leonardo.fibonacci)
|
|
(test "1.1" (installed-version (snow-status) '(leonardo fibonacci)))
|
|
|
|
(define repo3 '(--repository-uri tests/snow/repo3/repo.scm))
|
|
(snow package --output-dir tests/snow/repo3/
|
|
--version 1.0 --authors "Pingala"
|
|
--description "Factorial"
|
|
tests/snow/repo3/pingala/factorial.scm)
|
|
(snow package --output-dir tests/snow/repo3/
|
|
--version 1.0 --authors "Pingala"
|
|
--description "Binomial Coefficients"
|
|
--test tests/snow/repo3/pingala/binomial-test.scm
|
|
tests/snow/repo3/pingala/binomial.scm)
|
|
(snow package --output-dir tests/snow/repo3/
|
|
--version 1.0 --authors "Pingala"
|
|
--description "Pingala's test framework"
|
|
tests/snow/repo3/pingala/test-map.scm)
|
|
(snow index ,(cadr repo3))
|
|
(snow ,@repo3 update)
|
|
(snow ,@repo3 install pingala.binomial)
|
|
(let ((status (snow-status)))
|
|
(test-assert (installed-version status '(pingala binomial)))
|
|
(test-assert (installed-version status '(pingala factorial))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; other implementations
|
|
|
|
(snow ,@repo3 update)
|
|
(snow ,@repo3 --implementations "chicken" install pingala.binomial)
|
|
(let ((status (snow-status --implementations "chicken")))
|
|
(test-assert (installed-version status '(pingala binomial) 'chicken))
|
|
(test-assert (installed-version status '(pingala factorial) 'chicken)))
|
|
|
|
(snow ,@repo3 update)
|
|
(snow ,@repo3 --implementations "foment" install pingala.binomial)
|
|
(let ((status (snow-status --implementations "foment")))
|
|
(test-assert (installed-version status '(pingala binomial) 'foment))
|
|
(test-assert (installed-version status '(pingala factorial) 'foment)))
|
|
|
|
(snow ,@repo2 update)
|
|
(snow ,@repo2 --implementations "gauche,kawa,larceny"
|
|
install leonardo.fibonacci)
|
|
(let ((status (snow-status --implementations "gauche,kawa,larceny")))
|
|
(test "1.1" (installed-version status '(leonardo fibonacci) 'gauche))
|
|
(test "1.1" (installed-version status '(leonardo fibonacci) 'kawa))
|
|
(test "1.1" (installed-version status '(leonardo fibonacci) 'larceny)))
|
|
|
|
(snow ,@repo3 update)
|
|
(snow ,@repo3 --implementations "gauche,kawa,larceny"
|
|
install pingala.binomial)
|
|
(let ((status (snow-status --implementations "gauche,kawa,larceny")))
|
|
(test-assert (installed-version status '(pingala binomial) 'gauche))
|
|
(test-assert (installed-version status '(pingala factorial) 'gauche))
|
|
(test-assert (installed-version status '(pingala binomial) 'kawa))
|
|
(test-assert (installed-version status '(pingala factorial) 'kawa))
|
|
(test-assert (installed-version status '(pingala binomial) 'larceny))
|
|
(test-assert (installed-version status '(pingala factorial) 'larceny)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; smart packaging
|
|
|
|
(define repo4 '(--repository-uri tests/snow/repo4/repo.scm))
|
|
(setenv "SNOW_CHIBI_CONFIG" "tests/snow/repo4/config.scm")
|
|
|
|
(snow ,@repo4 package --output-dir tests/snow/repo4/
|
|
tests/snow/repo4/euler/interest.sld)
|
|
(let* ((pkg-file "tests/snow/repo4/euler-interest-2.3.tgz")
|
|
(pkg (package-file-meta pkg-file))
|
|
(libs (package-libraries pkg)))
|
|
(test 2 (length libs))
|
|
(for-each
|
|
(lambda (lib)
|
|
(test "Leonhard Euler" (assoc-get lib 'author)))
|
|
libs)
|
|
(test 'bsd (assoc-get pkg 'license))
|
|
(test "Library for computing (optionally continuously) compounded interest."
|
|
(assoc-get pkg 'description))
|
|
(test '((import (rename (euler interest-test)
|
|
run-tests run-euler-interest-test-tests))
|
|
(run-euler-interest-test-tests))
|
|
(snowball-test->sexp-list pkg pkg-file)))
|
|
|
|
(test-end)
|