diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm index 117654d9..f9eb1b30 100644 --- a/lib/chibi/doc.scm +++ b/lib/chibi/doc.scm @@ -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)))) diff --git a/lib/chibi/io.sld b/lib/chibi/io.sld index 2314ac09..302e4d4a 100644 --- a/lib/chibi/io.sld +++ b/lib/chibi/io.sld @@ -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") diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm index e97fa73e..b5a91672 100644 --- a/lib/chibi/snow/commands.scm +++ b/lib/chibi/snow/commands.scm @@ -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)))) diff --git a/lib/chibi/snow/commands.sld b/lib/chibi/snow/commands.sld index 536450f2..d70d2516 100644 --- a/lib/chibi/snow/commands.sld +++ b/lib/chibi/snow/commands.sld @@ -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) diff --git a/lib/chibi/snow/package.scm b/lib/chibi/snow/package.scm index 347a40ab..272016e5 100644 --- a/lib/chibi/snow/package.scm +++ b/lib/chibi/snow/package.scm @@ -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) diff --git a/lib/chibi/snow/package.sld b/lib/chibi/snow/package.sld index 3054bb71..5ed3d09b 100644 --- a/lib/chibi/snow/package.sld +++ b/lib/chibi/snow/package.sld @@ -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")) diff --git a/tests/snow/repo4/VERSION b/tests/snow/repo4/VERSION new file mode 100644 index 00000000..c0943d3e --- /dev/null +++ b/tests/snow/repo4/VERSION @@ -0,0 +1 @@ +2.3 \ No newline at end of file diff --git a/tests/snow/repo4/config.scm b/tests/snow/repo4/config.scm new file mode 100644 index 00000000..aa462a4d --- /dev/null +++ b/tests/snow/repo4/config.scm @@ -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)))) diff --git a/tests/snow/repo4/euler/interest-test.sld b/tests/snow/repo4/euler/interest-test.sld new file mode 100644 index 00000000..9f1fca7b --- /dev/null +++ b/tests/snow/repo4/euler/interest-test.sld @@ -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))))) diff --git a/tests/snow/repo4/euler/interest.sld b/tests/snow/repo4/euler/interest.sld new file mode 100644 index 00000000..29f73cbe --- /dev/null +++ b/tests/snow/repo4/euler/interest.sld @@ -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)))))))) diff --git a/tests/snow/snow-tests.scm b/tests/snow/snow-tests.scm index 2d6e56a3..67547101 100644 --- a/tests/snow/snow-tests.scm +++ b/tests/snow/snow-tests.scm @@ -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)