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.

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))
+          (and (pair? x)
-               (memq (car x) '(a b i u span code small large sub sup em)))))
+               (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))))

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")

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)
+(define (extract-module-file-docs cfg path)
-  (guard (exn (else '()))
+  (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))
+         (let ((lib-name (library-file-name lib))
-                (lib-name (library-name (car lib+files)))
+               (docs (extract-module-file-docs cfg lib)))
-                ;; TODO: load ignoring path and use extract-file-docs
-                (docs (extract-module-docs lib-name #f)))
            (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
+             (files '())
-              `(,@(if test (list test) '())
+             (lib-dirs '())
-                ,@docs)))
+             (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))))

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)

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)
+(define (library->path cfg library)
-  (library-name->path (library-name 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)
+(define (package->path cfg pkg)
-  (library-name->path (package-name 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)

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"))

tests/snow/repo4/VERSION

@@ -0,0 +1 @@
+2.3

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))))

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)))))

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))))))))

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 ast) (chibi config) (chibi filesystem) (chibi match)
-        (chibi process) (chibi regexp) (chibi string) (chibi test))
+        (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)