Fixing snow doc extraction for multiple levels of includes.

lib/chibi/doc.scm

@@ -556,10 +556,11 @@ div#footer {padding-bottom: 50px}
                          '()))))))))))))
 
 (define (get-procedure-signature mod id proc)
-  (cond ((and mod (procedure? proc) (procedure-signature id mod))
+  (protect (exn (else '()))
-         => (lambda (sig)
+    (cond ((and mod (procedure? proc) (procedure-signature id mod))
-              (list (cons (or id (procedure-name proc)) (cdr sig)))))
+           => (lambda (sig)
-        (else '())))
+                (list (cons (or id (procedure-name proc)) (cdr sig)))))
+          (else '()))))
 
 (define (get-value-signature mod id proc name value)
   (match value
@@ -904,21 +905,27 @@ div#footer {padding-bottom: 50px}
         (else #f)))
 
 ;; helper for below functions
-(define (extract-module-docs-from-files mod srcs includes stubs strict? exports)
+(define (extract-module-docs-from-files mod srcs includes stubs strict? exports . o)
-  (let ((defs (map (lambda (x)
+  (let ((dir (or (and (pair? o) (car o)) (module-dir mod)))
+        (defs (map (lambda (x)
                      (let ((val (and mod (module-ref mod x))))
                        `(,x ,val ,(object-source val))))
                    exports)))
+    (define (resolve-file file)
+      (let ((res (make-path dir file)))
+        (if (file-exists? res)
+            res
+            file)))
     (append
      (reverse
       (append-map (lambda (x)
-                    (extract-file-docs mod x defs strict? 'module))
+                    (extract-file-docs mod (resolve-file x) defs strict? 'module))
                   srcs))
      (reverse
-      (append-map (lambda (x) (extract-file-docs mod x defs strict?))
+      (append-map (lambda (x) (extract-file-docs mod (resolve-file x) defs strict?))
                   includes))
      (reverse
-      (append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi))
+      (append-map (lambda (x) (extract-file-docs mod (resolve-file x) defs strict? 'ffi))
                   stubs)))))
 
 ;;> Extract the literate Scribble docs from module \var{mod-name} and
@@ -949,30 +956,54 @@ div#footer {padding-bottom: 50px}
                   (memq (caar forms) '(define-library library))))
         (error "file doesn't define a library" file))
     (let* ((mod-form (car forms))
-           (mod-name (cadr mod-form)))
+           (mod-name (cadr mod-form))
-      (load file (vector-ref (find-module '(meta)) 1))
+           (lib-dir (module-lib-dir file mod-name))
-      (let* ((mod (protect (exn (else #f)) (load-module mod-name)))
+           (orig-mod-path (current-module-path))
-             (dir (path-directory file))
+           (new-mod-path (cons lib-dir orig-mod-path))
-             (resolve (lambda (f) (make-path dir f))))
+           (mod (protect (exn (else #f))
-        (define (get-forms name)
+                  (dynamic-wind
-          (append-map
+                    (lambda () (current-module-path new-mod-path))
-           (lambda (x) (if (and (pair? x) (eq? name (car x))) (cdr x) '()))
+                    (lambda ()
-           (cddr mod-form)))
+                      (let ((mod (load-module mod-name)))
-        (define (get-exports)
+                        (protect (exn (else #f)) (analyze-module mod-name))
-          (if mod (module-exports mod) (get-forms 'exports)))
+                        mod))
-        (define (get-decls)
+                    (lambda () (current-module-path orig-mod-path)))))
-          (if mod
+           (dir (path-directory file)))
-              (module-include-library-declarations mod)
+      (define (get-forms ls names dir . o)
-              (map resolve (get-forms 'include-library-declarations))))
+        (let ((resolve? (and (pair? o) (car o))))
-        (define (get-includes)
+          (let lp ((ls ls) (res '()))
-          (if mod
+            (if (null? ls)
-              (module-includes mod)
+                (reverse res)
-              (map resolve (get-forms 'include))))
+                (let ((x (car ls)))
-        (define (get-shared-includes)
+                  (lp (cdr ls)
-          (if mod
+                      (append
-              (module-shared-includes mod)
+                       (if (and (pair? x) (memq (car x) names))
-              (map resolve (get-forms 'shared-include))))
+                           (map (lambda (y)
-        (let* ((exports (if (pair? o) (car o) (get-exports)))
+                                  (if (and resolve? (string? y))
-               (srcs (cons file (get-decls))))
+                                      (make-path dir y)
-          (extract-module-docs-from-files
+                                      y))
-           mod srcs (get-includes) (get-shared-includes) strict? exports))))))
+                                (reverse (cdr x)))
+                           '())
+                       (if (and (pair? x)
+                                (eq? 'include-library-declarations (car x)))
+                           (append-map
+                            (lambda (inc)
+                              (let* ((file (make-path dir inc))
+                                     (sexps (file->sexp-list file))
+                                     (dir (path-directory file)))
+                                (get-forms sexps names dir resolve?)))
+                            (cdr x))
+                           '())
+                       res)))))))
+      (define (get-exports)
+        (if mod (module-exports mod) (get-forms (cddr mod-form) '(exports) dir)))
+      (define (get-decls)
+        (get-forms (cddr mod-form) '(include-library-declarations) dir #t))
+      (define (get-includes)
+        (get-forms (cddr mod-form) '(include include-ci) dir #t))
+      (define (get-shared-includes)
+        (get-forms (cddr mod-form) '(shared-include) dir #t))
+      (let* ((exports (if (pair? o) (car o) (get-exports)))
+             (srcs (cons file (get-decls))))
+        (extract-module-docs-from-files
+         mod srcs (get-includes) (get-shared-includes) strict? exports)))))

lib/chibi/modules.scm

@@ -36,8 +36,21 @@
         ""
         (module-name-prefix name))))
 
-(define (module-metas mod metas)
+;; assuming mod-name was found in file, resolves to the containing lib dir
-  (let ((mod (if (module? mod) mod (find-module mod))))
+(define (module-lib-dir file mod-name)
+  (let lp ((ls (map (lambda (x)
+                      (if (number? x) (number->string x) (symbol->string x)))
+                    (reverse mod-name)))
+           (path (reverse (string-split (path-strip-extension file) #\/))))
+    (if (and (pair? ls) (pair? path) (equal? (car ls) (car path)))
+        (lp (cdr ls) (cdr path))
+        (if (null? path)
+            "."
+            (string-join (reverse path) "/")))))
+
+(define (module-metas mod metas . o)
+  (let* ((mod (if (module? mod) mod (find-module mod)))
+         (dir (if (pair? o) (car o) (module-dir mod))))
     (let lp ((ls (module-meta-data mod)) (res '()))
       (cond
        ((not (pair? ls)) (reverse res))
@@ -50,7 +63,7 @@
          (dir (module-dir mod)))
     (define (module-file f)
       (find-module-file (string-append dir f)))
-    (map module-file (reverse (module-metas mod decls)))))
+    (map module-file (reverse (module-metas mod decls dir)))))
 
 (define (module-includes mod)
   (module-extract-declaration-files mod '(include)))
@@ -71,8 +84,10 @@
 (define (analyze-module-source name mod recursive?)
   (let ((env (make-environment))
         (dir (module-dir mod)))
+    (define (resolve-file file)
+      (find-module-file (string-append dir file)))
     (define (include-source file)
-      (cond ((find-module-file (string-append dir file))
+      (cond ((resolve-file file)
              => (lambda (x) (cons 'begin (file->sexp-list x))))
             (else (error "couldn't find include" file))))
     (cond
@@ -100,7 +115,7 @@
           ((include include-ci)
            (lp (append (map include-source (cdar ls)) (cdr ls)) res))
           ((include-library-declarations)
-           (lp (append (append-map file->sexp-list (cdar ls)) (cdr ls)) res))
+           (lp (append (append-map file->sexp-list (map resolve-file (cdar ls))) (cdr ls)) res))
           ((begin body)
            (let lp2 ((ls2 (cdar ls)) (res res))
              (cond

lib/chibi/modules.sld

@@ -1,16 +1,23 @@
 
 (define-library (chibi modules)
   (export module? module-name module-dir module-includes module-shared-includes
-          module-include-library-declarations
+          module-include-library-declarations module-meta-data
           module-ast module-ast-set! module-ref module-contains?
           analyze-module containing-module load-module module-exports
-          module-name->file procedure-analysis find-module
+          module-name->file module-lib-dir procedure-analysis find-module
           available-modules-in-directory available-modules
           modules-exporting-identifier file->sexp-list)
-  (import (chibi) (srfi 1) (chibi ast) (chibi filesystem)
+  (import (chibi)
+          (srfi 1)
+          (chibi ast)
+          (chibi pathname)
+          (chibi filesystem)
+          (chibi string)
           (only (meta)
                 module-env module-meta-data module-exports
                 make-module load-module find-module resolve-import
                 resolve-module-imports
-                module-name-prefix module-name->file *modules*))
+                module-name-prefix
+                module-name->file
+                *modules*))
   (include "modules.scm"))

tests/snow/repo4/euler/exponential-include.sld

@@ -0,0 +1,3 @@
+;;> Library for computing the natural exponential function.
+
+(include "exponential.scm")

tests/snow/repo4/euler/exponential-test.sld

@@ -0,0 +1,19 @@
+(define-library (euler exponential-test)
+  (export run-tests)
+  (import (scheme base) (scheme process-context) (euler exponential))
+  (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 0.36788 (e -1.0))
+      (test 1.0 (e 0.0))
+      (test 2.71828 (e 1.0))
+      (test 4.48167 (e 1.5))
+      (test 7.38871 (e 2.0)))))

tests/snow/repo4/euler/exponential.scm

@@ -0,0 +1,10 @@
+
+;;> Returns e^\var{x}.
+
+(define e
+  (let ((iterations 10))
+    (lambda (x)
+      (let lp ((i 1) (num 1) (den 1) (res 0))
+        (if (> i iterations)
+            res
+            (lp (+ i 1) (* num x) (* den i) (+ res (/ num den))))))))

tests/snow/repo4/euler/exponential.sld

@@ -0,0 +1,5 @@
+
+(define-library (euler exponential)
+  (export e)
+  (import (scheme base) (scheme inexact))
+  (include-library-declarations "exponential-include.sld"))

tests/snow/snow-tests.scm

@@ -288,6 +288,8 @@
 
 (snow ,@repo4 package --output-dir tests/snow/repo4/
       tests/snow/repo4/euler/interest.sld)
+(snow ,@repo4 package --output-dir tests/snow/repo4/
+      tests/snow/repo4/euler/exponential.sld)
 (snow index ,(cadr repo4))
 (let* ((pkg-file "tests/snow/repo4/euler-interest-2.3.tgz")
        (pkg (package-file-meta pkg-file))
@@ -304,6 +306,21 @@
                           (run-tests run-euler-interest-test-tests)))
           (run-euler-interest-test-tests))
       (snowball-test->sexp-list pkg pkg-file)))
+(let* ((pkg-file "tests/snow/repo4/euler-exponential-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 the natural exponential function."
+      (assoc-get pkg 'description))
+  (test '((import (rename (euler exponential-test)
+                          (run-tests run-euler-exponential-test-tests)))
+          (run-euler-exponential-test-tests))
+      (snowball-test->sexp-list pkg pkg-file)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; multiple repos