diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm index de7c6c01..687f666f 100644 --- a/lib/chibi/doc.scm +++ b/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)) - => (lambda (sig) - (list (cons (or id (procedure-name proc)) (cdr sig))))) - (else '()))) + (protect (exn (else '())) + (cond ((and mod (procedure? proc) (procedure-signature id mod)) + => (lambda (sig) + (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) - (let ((defs (map (lambda (x) +(define (extract-module-docs-from-files mod srcs includes stubs strict? exports . o) + (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))) - (load file (vector-ref (find-module '(meta)) 1)) - (let* ((mod (protect (exn (else #f)) (load-module mod-name))) - (dir (path-directory file)) - (resolve (lambda (f) (make-path dir f)))) - (define (get-forms name) - (append-map - (lambda (x) (if (and (pair? x) (eq? name (car x))) (cdr x) '())) - (cddr mod-form))) - (define (get-exports) - (if mod (module-exports mod) (get-forms 'exports))) - (define (get-decls) - (if mod - (module-include-library-declarations mod) - (map resolve (get-forms 'include-library-declarations)))) - (define (get-includes) - (if mod - (module-includes mod) - (map resolve (get-forms 'include)))) - (define (get-shared-includes) - (if mod - (module-shared-includes mod) - (map resolve (get-forms 'shared-include)))) - (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)))))) + (mod-name (cadr mod-form)) + (lib-dir (module-lib-dir file mod-name)) + (orig-mod-path (current-module-path)) + (new-mod-path (cons lib-dir orig-mod-path)) + (mod (protect (exn (else #f)) + (dynamic-wind + (lambda () (current-module-path new-mod-path)) + (lambda () + (let ((mod (load-module mod-name))) + (protect (exn (else #f)) (analyze-module mod-name)) + mod)) + (lambda () (current-module-path orig-mod-path))))) + (dir (path-directory file))) + (define (get-forms ls names dir . o) + (let ((resolve? (and (pair? o) (car o)))) + (let lp ((ls ls) (res '())) + (if (null? ls) + (reverse res) + (let ((x (car ls))) + (lp (cdr ls) + (append + (if (and (pair? x) (memq (car x) names)) + (map (lambda (y) + (if (and resolve? (string? y)) + (make-path dir y) + y)) + (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))))) diff --git a/lib/chibi/modules.scm b/lib/chibi/modules.scm index 6a27591f..a27f2402 100644 --- a/lib/chibi/modules.scm +++ b/lib/chibi/modules.scm @@ -36,8 +36,21 @@ "" (module-name-prefix name)))) -(define (module-metas mod metas) - (let ((mod (if (module? mod) mod (find-module mod)))) +;; assuming mod-name was found in file, resolves to the containing lib dir +(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 diff --git a/lib/chibi/modules.sld b/lib/chibi/modules.sld index aa6444d1..6b37b4fa 100644 --- a/lib/chibi/modules.sld +++ b/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")) diff --git a/tests/snow/repo4/euler/exponential-include.sld b/tests/snow/repo4/euler/exponential-include.sld new file mode 100644 index 00000000..ec67ceaa --- /dev/null +++ b/tests/snow/repo4/euler/exponential-include.sld @@ -0,0 +1,3 @@ +;;> Library for computing the natural exponential function. + +(include "exponential.scm") diff --git a/tests/snow/repo4/euler/exponential-test.sld b/tests/snow/repo4/euler/exponential-test.sld new file mode 100644 index 00000000..72e67621 --- /dev/null +++ b/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))))) diff --git a/tests/snow/repo4/euler/exponential.scm b/tests/snow/repo4/euler/exponential.scm new file mode 100644 index 00000000..ede8c8f7 --- /dev/null +++ b/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)))))))) diff --git a/tests/snow/repo4/euler/exponential.sld b/tests/snow/repo4/euler/exponential.sld new file mode 100644 index 00000000..d1c7ad89 --- /dev/null +++ b/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")) diff --git a/tests/snow/snow-tests.scm b/tests/snow/snow-tests.scm index edfce923..f651585c 100644 --- a/tests/snow/snow-tests.scm +++ b/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