mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
Adding snow tests for advanced package defaults from config.
Adding test-library option to automatically infer tests from libraries. Processing scribble docs even when we can't load the module.
This commit is contained in:
Alex Shinn
parent
f9c063ebe6
commit
4e75fbab49
11 changed files with 316 additions and 87 deletions
|
|
@ -405,8 +405,10 @@ div#footer {padding-bottom: 50px}
|
|||
(if (pair? p) (cons `(p ,@(reverse p)) res) res))
|
||||
(define (inline? x)
|
||||
(or (string? x)
|
||||
(and (pair? x) (symbol? (car x))
|
||||
(memq (car x) '(a b i u span code small large sub sup em)))))
|
||||
(and (pair? x)
|
||||
(or (string? (car x))
|
||||
(memq (car x)
|
||||
'(a b i u span code small large sub sup em))))))
|
||||
(define (enclosing? x)
|
||||
(and (pair? x) (symbol? (car x))
|
||||
(memq (car x) '(div body))))
|
||||
|
|
@ -533,7 +535,7 @@ div#footer {padding-bottom: 50px}
|
|||
(list opts)))))))))))))
|
||||
|
||||
(define (get-procedure-signature mod id proc)
|
||||
(cond ((and (procedure? proc) (procedure-signature id mod))
|
||||
(cond ((and mod (procedure? proc) (procedure-signature id mod))
|
||||
=> (lambda (sig)
|
||||
(list (cons (or id (procedure-name proc)) (cdr sig)))))
|
||||
(else '())))
|
||||
|
|
@ -840,7 +842,7 @@ div#footer {padding-bottom: 50px}
|
|||
mod id (caar procs) (cdar procs) form))
|
||||
(else
|
||||
(get-signature
|
||||
mod id (and id (module-ref mod id)) #f form)))))
|
||||
mod id (and id mod (module-ref mod id)) #f form)))))
|
||||
(cond
|
||||
((and strict?
|
||||
(or (not (pair? sigs)) (not (assq (caar sigs) defs))))
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
string->utf8 utf8->string
|
||||
write-string write-u8 read-u8 peek-u8 send-file
|
||||
is-a-socket?
|
||||
call-with-input-string call-with-output-string
|
||||
call-with-input-file call-with-output-file)
|
||||
(import (chibi) (chibi ast))
|
||||
(include-shared "io/io")
|
||||
|
|
|
|||
|
|
@ -133,39 +133,6 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Package - generate a package from one or more libraries.
|
||||
|
||||
(define (tar-file? file)
|
||||
(or (equal? (path-extension file) "tgz")
|
||||
(and (member (path-extension file) '("gz" "bz2"))
|
||||
(equal? (path-extension (path-strip-extension file)) "tar"))))
|
||||
|
||||
(define (package-file-meta file)
|
||||
(and
|
||||
(tar-file? file)
|
||||
(let* ((unzipped-file
|
||||
(if (member (path-extension file) '("tgz" "gz"))
|
||||
(gunzip (let* ((in (open-binary-input-file file))
|
||||
(res (port->bytevector in)))
|
||||
(close-input-port in)
|
||||
res))
|
||||
file))
|
||||
(package-file
|
||||
(find
|
||||
(lambda (x)
|
||||
(and (equal? "package.scm" (path-strip-directory x))
|
||||
(equal? "." (path-directory (path-directory x)))))
|
||||
(tar-files unzipped-file))))
|
||||
(and package-file
|
||||
(guard (exn (else #f))
|
||||
(let* ((str (utf8->string
|
||||
(tar-extract-file unzipped-file package-file)))
|
||||
(package (read (open-input-string str))))
|
||||
(and (pair? package)
|
||||
(eq? 'package (car package))
|
||||
package)))))))
|
||||
|
||||
(define (package-file? file)
|
||||
(and (package-file-meta file) #t))
|
||||
|
||||
(define (x->string x)
|
||||
(cond ((string? x) x)
|
||||
((symbol? x) (symbol->string x))
|
||||
|
|
@ -252,7 +219,10 @@
|
|||
|
||||
(define (extract-program-dependencies file . o)
|
||||
(let ((depends (or (and (pair? o) (car o)) 'depends)))
|
||||
(let lp ((ls (guard (exn (else '())) (file->sexp-list file)))
|
||||
(let lp ((ls (guard (exn (else '()))
|
||||
(if (and (pair? file) (eq? 'inline (car file)))
|
||||
(port->sexp-list (open-input-string (cadr file)))
|
||||
(file->sexp-list file))))
|
||||
(deps '())
|
||||
(cond-deps '()))
|
||||
(cond
|
||||
|
|
@ -336,38 +306,59 @@
|
|||
|
||||
;; We want to automatically bundle (foo bar *) when packaging (foo bar)
|
||||
;; if it's already in the same directory.
|
||||
(define (submodule->path base file lib dep)
|
||||
(define (submodule->path cfg base file lib dep)
|
||||
(and base
|
||||
(> (length dep) (length base))
|
||||
(equal? base (take dep (length base)))
|
||||
;; TODO: find-library(-relative)
|
||||
(let* ((dir (library-path-base file lib))
|
||||
(dep-file (make-path dir (string-append
|
||||
(library-name->path dep)
|
||||
(library-name->path cfg dep)
|
||||
".sld"))))
|
||||
(and (file-exists? dep-file) dep-file))))
|
||||
|
||||
(define (package-docs cfg spec libs)
|
||||
(guard (exn (else '()))
|
||||
(define (extract-module-file-docs cfg path)
|
||||
(define (object-source x)
|
||||
(cond ((bytecode? x)
|
||||
(let ((src (bytecode-source x)))
|
||||
(if (and (vector? src) (positive? (vector-length src)))
|
||||
(vector-ref src 0)
|
||||
src)))
|
||||
((procedure? x) (object-source (procedure-code x)))
|
||||
((macro? x) (macro-source x))
|
||||
(else #f)))
|
||||
(let* ((lib+files (extract-library cfg path))
|
||||
(lib-name (library-name (car lib+files)))
|
||||
(exports (cond ((assq 'export (cdar lib+files)) => cdr) (else '())))
|
||||
(mod (guard (exn (else #f))
|
||||
#f))
|
||||
(defs (map (lambda (x)
|
||||
(let ((val (and mod (module-ref mod x))))
|
||||
`(,x ,val ,(object-source val))))
|
||||
exports)))
|
||||
(reverse (extract-file-docs mod path defs #f 'module))))
|
||||
|
||||
(define (package-docs cfg spec libs lib-dirs)
|
||||
(guard (exn (else (warn "package-docs failed" exn)
|
||||
'()))
|
||||
(cond
|
||||
((conf-get cfg '(command package doc)) => list)
|
||||
((conf-get cfg '(command package doc-from-scribble))
|
||||
(filter-map
|
||||
(lambda (lib)
|
||||
(let* ((lib+files (extract-library cfg lib))
|
||||
(lib-name (library-name (car lib+files)))
|
||||
;; TODO: load ignoring path and use extract-file-docs
|
||||
(docs (extract-module-docs lib-name #f)))
|
||||
(let ((lib-name (library-file-name lib))
|
||||
(docs (extract-module-file-docs cfg lib)))
|
||||
(and (pair? docs)
|
||||
(not (and (= 1 (length docs)) (eq? 'subsection (caar docs))))
|
||||
`(inline
|
||||
,(string-append (library-name->path lib-name) ".html")
|
||||
,(string-append (library-name->path cfg lib-name) ".html")
|
||||
,(call-with-output-string
|
||||
(lambda (out)
|
||||
(sxml-display-as-html
|
||||
(generate-docs
|
||||
`((title ,(write-to-string lib-name)) ,docs)
|
||||
(make-module-doc-env lib-name))
|
||||
(guard (exn (else (make-default-doc-env)))
|
||||
(make-module-doc-env lib-name)))
|
||||
out)))))))
|
||||
libs))
|
||||
(else '()))))
|
||||
|
|
@ -418,38 +409,70 @@
|
|||
package-spec)
|
||||
(package-output-version cfg)))))
|
||||
|
||||
(define (replace-library-pattern pat base-lib)
|
||||
(case (and (pair? pat) (car pat))
|
||||
((append-to-last)
|
||||
(append (drop-right base-lib 1)
|
||||
(list
|
||||
(string->symbol
|
||||
(string-append (x->string (last base-lib))
|
||||
(x->string (cadr pat)))))))
|
||||
((append) (append base-lib (cdr pat)))
|
||||
((quote) (cadr pat))
|
||||
(else pat)))
|
||||
|
||||
(define (find-library-from-pattern cfg pat lib . o)
|
||||
(and pat
|
||||
(if (and (pair? pat) (eq? 'or (car pat)))
|
||||
(any (lambda (pat) (find-library-from-pattern pat lib)) (cdr pat))
|
||||
(let ((lib-name (replace-library-pattern pat lib)))
|
||||
(apply find-library-file cfg lib-name o)))))
|
||||
|
||||
(define (tests-from-libraries cfg libs lib-dirs)
|
||||
(let ((pat (conf-get cfg '(command package test-library))))
|
||||
(filter-map
|
||||
(lambda (lib) (find-library-from-pattern cfg pat lib lib-dirs))
|
||||
libs)))
|
||||
|
||||
(define (test-program-from-libraries lib-files)
|
||||
(call-with-output-string
|
||||
(lambda (out)
|
||||
(let* ((lib-names (filter-map library-file-name lib-files))
|
||||
(run-names
|
||||
(map (lambda (lib)
|
||||
(string->symbol
|
||||
(string-append "run-"
|
||||
(string-join (map x->string lib) "-")
|
||||
"-tests")))
|
||||
lib-names)))
|
||||
(for-each
|
||||
(lambda (lib run)
|
||||
(write `(import (rename ,lib run-tests ,run)) out)
|
||||
(newline out))
|
||||
lib-names
|
||||
run-names)
|
||||
(newline out)
|
||||
(for-each (lambda (run) (write `(,run) out) (newline out)) run-names)))))
|
||||
|
||||
(define (package-spec+files cfg spec libs)
|
||||
(let* ((recursive? (conf-get cfg '(command package recursive?)))
|
||||
(programs (conf-get-list cfg '(command package programs)))
|
||||
(docs (package-docs cfg spec libs))
|
||||
(desc (package-description cfg spec libs docs))
|
||||
(test (package-test cfg))
|
||||
(test-depends
|
||||
(if test (extract-program-dependencies test 'test-depends) '()))
|
||||
(authors (conf-get-list cfg '(command package authors)))
|
||||
(maintainers (conf-get-list cfg '(command package maintainers)))
|
||||
(test (package-test cfg))
|
||||
(version (package-output-version cfg))
|
||||
(maintainers (conf-get-list cfg '(command package maintainers)))
|
||||
(license (package-license cfg)))
|
||||
(let lp ((ls (map (lambda (x) (cons x #f)) libs))
|
||||
(progs programs)
|
||||
(res
|
||||
`(,@(if license `((license ,license)) '())
|
||||
,@(if (pair? docs)
|
||||
`((manual ,@(map
|
||||
(lambda (x)
|
||||
(path-strip-leading-parents
|
||||
(if (pair? x) (cadr x) x)))
|
||||
docs)))
|
||||
'())
|
||||
,@(if desc `((description ,desc)) '())
|
||||
,@(if test `((test ,(path-strip-leading-parents test))) '())
|
||||
,@test-depends
|
||||
,@(if version `((version ,version)) '())
|
||||
,@(if (pair? authors) `((authors ,@authors)) '())
|
||||
,@(if (pair? maintainers) `((maintainers ,@maintainers)) '())))
|
||||
(files
|
||||
`(,@(if test (list test) '())
|
||||
,@docs)))
|
||||
(files '())
|
||||
(lib-dirs '())
|
||||
(test test)
|
||||
(extracted-tests? #f))
|
||||
(cond
|
||||
((pair? ls)
|
||||
(let* ((lib+files (extract-library cfg (caar ls)))
|
||||
|
|
@ -459,14 +482,18 @@
|
|||
(subdeps (if recursive?
|
||||
(filter-map
|
||||
(lambda (x)
|
||||
(submodule->path base (caar ls) name x))
|
||||
(submodule->path cfg base (caar ls) name x))
|
||||
(cond ((assq 'depends (cdr lib)) => cdr)
|
||||
(else '())))
|
||||
'())))
|
||||
(lp (append (map (lambda (x) (cons x base)) subdeps) (cdr ls))
|
||||
progs
|
||||
(cons lib res)
|
||||
(append (reverse (cdr lib+files)) files))))
|
||||
(append (reverse (cdr lib+files)) files)
|
||||
(delete-duplicates
|
||||
(cons (library-path-base (caar ls) name) lib-dirs))
|
||||
test
|
||||
extracted-tests?)))
|
||||
((pair? progs)
|
||||
(lp ls
|
||||
(cdr progs)
|
||||
|
|
@ -474,11 +501,55 @@
|
|||
(path ,(path-strip-leading-parents (car progs)))
|
||||
,@(extract-program-dependencies (car progs)))
|
||||
res)
|
||||
(cons (car progs) files)))
|
||||
(cons (car progs) files)
|
||||
lib-dirs
|
||||
test
|
||||
extracted-tests?))
|
||||
((null? res)
|
||||
(die 2 "No packages generated"))
|
||||
((and (not test)
|
||||
(not extracted-tests?)
|
||||
(tests-from-libraries
|
||||
cfg
|
||||
(filter-map (lambda (x) (and (library? x) (library-name x)))
|
||||
res)
|
||||
lib-dirs))
|
||||
=> (lambda (tests-from-libraries)
|
||||
(if (pair? tests-from-libraries)
|
||||
(lp (append (map (lambda (x) (cons x #f)) tests-from-libraries)
|
||||
ls)
|
||||
progs
|
||||
res
|
||||
files
|
||||
lib-dirs
|
||||
`(inline
|
||||
"run-tests.scm"
|
||||
,(test-program-from-libraries tests-from-libraries))
|
||||
#t)
|
||||
(lp ls progs res files lib-dirs test #t))))
|
||||
(else
|
||||
(cons (cons 'package (reverse res)) (reverse files)))))))
|
||||
(let* ((docs (package-docs cfg spec libs lib-dirs))
|
||||
(desc (package-description cfg spec libs docs))
|
||||
(test-depends
|
||||
(if test
|
||||
(extract-program-dependencies test 'test-depends)
|
||||
'())))
|
||||
(cons `(package
|
||||
,@(reverse res)
|
||||
,@(if (pair? docs)
|
||||
`((manual ,@(map
|
||||
(lambda (x)
|
||||
(path-strip-leading-parents
|
||||
(if (pair? x) (cadr x) x)))
|
||||
docs)))
|
||||
'())
|
||||
,@(if desc `((description ,desc)) '())
|
||||
,@(if test
|
||||
`((test ,(path-strip-leading-parents
|
||||
(if (pair? test) (cadr test) test))))
|
||||
'())
|
||||
,@test-depends)
|
||||
(reverse (if test (cons test (append docs files)) files)))))))))
|
||||
|
||||
(define (create-package spec files path)
|
||||
(gzip
|
||||
|
|
@ -787,7 +858,7 @@
|
|||
(warn-delete-file (make-path (get-install-source-dir impl cfg)
|
||||
(get-package-meta-file cfg pkg)))
|
||||
(let ((dir (make-path (get-install-source-dir impl cfg)
|
||||
(package->path pkg))))
|
||||
(package->path cfg pkg))))
|
||||
(if (and (file-directory? dir)
|
||||
(= 2 (length (directory-files dir))))
|
||||
(delete-directory dir))))
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@
|
|||
(chibi snow interface)
|
||||
(chibi snow package)
|
||||
(chibi snow utils)
|
||||
(chibi ast)
|
||||
(chibi bytevector)
|
||||
(chibi config)
|
||||
(chibi crypto md5)
|
||||
|
|
@ -37,6 +38,7 @@
|
|||
(chibi filesystem)
|
||||
(chibi io)
|
||||
(chibi match)
|
||||
(chibi modules)
|
||||
(chibi net http)
|
||||
(chibi process)
|
||||
(chibi pathname)
|
||||
|
|
|
|||
|
|
@ -226,7 +226,10 @@
|
|||
(define (package-installed-files pkg)
|
||||
(or (and (pair? pkg) (assoc-get-list (cdr pkg) 'installed-files)) '()))
|
||||
|
||||
(define (library-name->path name)
|
||||
(define (library-separator cfg)
|
||||
(conf-get cfg 'library-separator "/"))
|
||||
|
||||
(define (library-name->path cfg name)
|
||||
(if (null? name)
|
||||
""
|
||||
(call-with-output-string
|
||||
|
|
@ -234,24 +237,24 @@
|
|||
(let lp ((name name))
|
||||
(display (car name) out)
|
||||
(cond ((pair? (cdr name))
|
||||
(write-char #\/ out)
|
||||
(display (library-separator cfg) out)
|
||||
(lp (cdr name)))))))))
|
||||
|
||||
;; map a library to the path name it would be found in (sans extension)
|
||||
(define (library->path library)
|
||||
(library-name->path (library-name library)))
|
||||
(define (library->path cfg library)
|
||||
(library-name->path cfg (library-name library)))
|
||||
|
||||
;; find the library declaration file for the given library
|
||||
(define (get-library-file cfg library)
|
||||
(or (assoc-get library 'path)
|
||||
(string-append (library->path library) "."
|
||||
(string-append (library->path cfg library) "."
|
||||
(conf-get cfg 'library-extension "sld"))))
|
||||
|
||||
(define (package->path pkg)
|
||||
(library-name->path (package-name pkg)))
|
||||
(define (package->path cfg pkg)
|
||||
(library-name->path cfg (package-name pkg)))
|
||||
|
||||
(define (package-name->meta-file cfg name)
|
||||
(let ((path (library-name->path name)))
|
||||
(let ((path (library-name->path cfg name)))
|
||||
(string-append (path-directory path) "/."
|
||||
(path-strip-directory path) ".meta")))
|
||||
|
||||
|
|
@ -261,6 +264,71 @@
|
|||
(define (get-library-meta-file cfg lib)
|
||||
(package-name->meta-file cfg (library-name lib)))
|
||||
|
||||
(define (library-file-name file)
|
||||
(guard (exn (else #f))
|
||||
(let ((x (call-with-input-file file read)))
|
||||
(and (pair? x)
|
||||
(memq (car x) '(define-library library))
|
||||
(list? (cadr x))
|
||||
(cadr x)))))
|
||||
|
||||
(define (find-library-file cfg lib-name . o)
|
||||
(let ((base (string-append (library-name->path cfg lib-name)
|
||||
"."
|
||||
(conf-get cfg 'library-extension "sld"))))
|
||||
(let lp ((dirs (append (or (and (pair? o) (car o)) '())
|
||||
(cons "." (conf-get-list cfg 'library-path )))))
|
||||
(and (pair? dirs)
|
||||
(let ((path (make-path (car dirs) base)))
|
||||
(or (and (file-exists? path)
|
||||
(equal? lib-name (library-file-name path))
|
||||
path)
|
||||
(lp (cdr dirs))))))))
|
||||
|
||||
(define (tar-file? file)
|
||||
(or (equal? (path-extension file) "tgz")
|
||||
(and (member (path-extension file) '("gz" "bz2"))
|
||||
(equal? (path-extension (path-strip-extension file)) "tar"))))
|
||||
|
||||
(define (package-file-unzipped file)
|
||||
(and (tar-file? file)
|
||||
(if (member (path-extension file) '("tgz" "gz"))
|
||||
(gunzip (let* ((in (open-binary-input-file file))
|
||||
(res (port->bytevector in)))
|
||||
(close-input-port in)
|
||||
res))
|
||||
file)))
|
||||
|
||||
(define (package-file-meta file)
|
||||
(let* ((unzipped-file (package-file-unzipped file))
|
||||
(package-file
|
||||
(and unzipped-file
|
||||
(find
|
||||
(lambda (x)
|
||||
(and (equal? "package.scm" (path-strip-directory x))
|
||||
(equal? "." (path-directory (path-directory x)))))
|
||||
(tar-files unzipped-file)))))
|
||||
(and package-file
|
||||
(guard (exn (else #f))
|
||||
(let* ((str (utf8->string
|
||||
(tar-extract-file unzipped-file package-file)))
|
||||
(package (read (open-input-string str))))
|
||||
(and (pair? package)
|
||||
(eq? 'package (car package))
|
||||
package))))))
|
||||
|
||||
(define (package-file? file)
|
||||
(and (package-file-meta file) #t))
|
||||
|
||||
(define (package-file-top-directory file)
|
||||
(let ((unzipped-file (package-file-unzipped file)))
|
||||
(and unzipped-file
|
||||
(let lp ((file (car (tar-files unzipped-file))))
|
||||
(let ((dir (path-directory file)))
|
||||
(if (member dir '("" "." "/"))
|
||||
file
|
||||
(lp dir)))))))
|
||||
|
||||
;; libraries
|
||||
|
||||
(define (library? x)
|
||||
|
|
@ -384,7 +452,7 @@
|
|||
(define (get-program-file cfg prog)
|
||||
(cond ((assoc-get prog 'path))
|
||||
((assoc-get prog 'name)
|
||||
=> (lambda (name) (library-name->path (last name))))
|
||||
=> (lambda (name) (library-name->path cfg (list (last name)))))
|
||||
(else (error "program missing path: " prog))))
|
||||
|
||||
(define (program-install-name prog)
|
||||
|
|
|
|||
|
|
@ -8,17 +8,23 @@
|
|||
package-digest-mismatches package-signature-mismatches
|
||||
package-digest-ok? package-signature-ok?
|
||||
package->path package-name->meta-file
|
||||
package-file-meta package-file? package-file-top-directory
|
||||
package-file-unzipped
|
||||
get-package-meta-file get-library-meta-file
|
||||
library-name->path library->path get-library-file
|
||||
library-name->path library->path get-library-file find-library-file
|
||||
library-url library-name parse-library-name library-name->path
|
||||
library-analyze library-include-files library-dependencies
|
||||
library-rewrite-includes
|
||||
library-rewrite-includes library-file-name
|
||||
get-program-file program-name program-install-name
|
||||
invalid-package-reason valid-package?
|
||||
invalid-library-reason valid-library?
|
||||
repo-find-publisher lookup-digest rsa-identity=?
|
||||
extract-rsa-private-key extract-rsa-public-key)
|
||||
(import (chibi)
|
||||
(import (scheme base)
|
||||
(scheme char)
|
||||
(scheme file)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(srfi 1)
|
||||
(chibi snow interface)
|
||||
(chibi bytevector)
|
||||
|
|
@ -26,7 +32,11 @@
|
|||
(chibi crypto md5)
|
||||
(chibi crypto rsa)
|
||||
(chibi crypto sha2)
|
||||
(chibi filesystem)
|
||||
(chibi io)
|
||||
(chibi pathname)
|
||||
(chibi string)
|
||||
(chibi uri))
|
||||
(chibi tar)
|
||||
(chibi uri)
|
||||
(chibi zlib))
|
||||
(include "package.scm"))
|
||||
|
|
|
|||
1
tests/snow/repo4/VERSION
Normal file
1
tests/snow/repo4/VERSION
Normal file
|
|
@ -0,0 +1 @@
|
|||
2.3
|
||||
7
tests/snow/repo4/config.scm
Normal file
7
tests/snow/repo4/config.scm
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
((command
|
||||
(package
|
||||
(author "Leonhard Euler")
|
||||
(doc-from-scribble #t)
|
||||
(version-file "tests/snow/repo4/VERSION")
|
||||
(test-library (append-to-last -test))
|
||||
(license bsd))))
|
||||
18
tests/snow/repo4/euler/interest-test.sld
Normal file
18
tests/snow/repo4/euler/interest-test.sld
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
(define-library (euler interest-test)
|
||||
(export run-tests)
|
||||
(import (scheme base) (scheme process-context) (euler interest))
|
||||
(begin
|
||||
(define (test expect expr)
|
||||
(cond
|
||||
((not (or (equal? expect expr)
|
||||
(and (or (inexact? expect) (inexact? expr))
|
||||
(let ((a (min expect expr))
|
||||
(b (max expect expr)))
|
||||
(< (abs (/ (- a b) b)) 0.000001)))))
|
||||
(write-string "FAIL\n")
|
||||
(exit 1))))
|
||||
(define (run-tests)
|
||||
(test 2.0 (compound-interest 1 1.0 1 1))
|
||||
(test 2.25 (compound-interest 1 1.0 1 2))
|
||||
(test 2.4414 (compound-interest 1 1.0 1 4))
|
||||
(test 2.71828 (compound-interest 1 1.0 1)))))
|
||||
16
tests/snow/repo4/euler/interest.sld
Normal file
16
tests/snow/repo4/euler/interest.sld
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
|
||||
;;> Library for computing (optionally continuously) compounded interest.
|
||||
|
||||
(define-library (euler interest)
|
||||
(export compound-interest)
|
||||
(import (scheme base) (scheme inexact))
|
||||
(begin
|
||||
;;> Returns the total amount starting at \var{base} increasing at
|
||||
;;> the given interest rate \var{rate}, for the given \var{duration}.
|
||||
;;> Compounds at optional \var{interval} intervals, which default
|
||||
;;> to +inf.0 for continuous.
|
||||
(define (compound-interest base rate duration . o)
|
||||
(let ((interval (or (and (pair? o) (car o)) +inf.0)))
|
||||
(if (finite? interval)
|
||||
(* base (expt (+ 1 (/ rate interval)) (* duration interval)))
|
||||
(* base (exp (* rate duration))))))))
|
||||
|
|
@ -1,6 +1,8 @@
|
|||
(import (scheme base) (scheme write) (scheme process-context) (srfi 1)
|
||||
(chibi ast) (chibi filesystem) (chibi match) (chibi pathname)
|
||||
(chibi process) (chibi regexp) (chibi string) (chibi test))
|
||||
(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")
|
||||
|
||||
|
|
@ -91,6 +93,13 @@
|
|||
(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
|
||||
|
||||
|
|
@ -195,4 +204,28 @@
|
|||
(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)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue