diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-10-30 00:16:53 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-11-06 00:46:26 +0100 |
commit | 6af1b3f9b55e95bfee051d73bdbb2257875d97bc (patch) | |
tree | e3ce3411227955d92bf71bc3d80f9eadf68d5dfa | |
parent | Rename test. (diff) | |
download | calp-6af1b3f9b55e95bfee051d73bdbb2257875d97bc.tar.gz calp-6af1b3f9b55e95bfee051d73bdbb2257875d97bc.tar.xz |
Add tests for module introspection.
Diffstat (limited to '')
-rw-r--r-- | module/hnh/module-introspection/all-modules.scm | 3 | ||||
-rw-r--r-- | module/hnh/module-introspection/module-uses.scm | 43 | ||||
-rw-r--r-- | tests/test-module-tree/README.md | 4 | ||||
-rw-r--r-- | tests/test-module-tree/a.scm | 6 | ||||
-rw-r--r-- | tests/test-module-tree/a/b.scm | 2 | ||||
-rw-r--r-- | tests/test-module-tree/a/c.scm | 3 | ||||
-rw-r--r-- | tests/test-module-tree/b.scm | 1 | ||||
-rw-r--r-- | tests/unit/module-introspection/all-modules.scm | 93 | ||||
-rw-r--r-- | tests/unit/module-introspection/module-uses.scm | 68 | ||||
-rw-r--r-- | tests/unit/module-introspection/static-util.scm | 15 |
10 files changed, 222 insertions, 16 deletions
diff --git a/module/hnh/module-introspection/all-modules.scm b/module/hnh/module-introspection/all-modules.scm index 753d5019..5b4b37d2 100644 --- a/module/hnh/module-introspection/all-modules.scm +++ b/module/hnh/module-introspection/all-modules.scm @@ -17,9 +17,6 @@ (ftw dir (lambda args (set! files (cons args files)) #t)) files) -;; (define (fs-find proc dir) -;; (filter proc (fs-find-base dir))) - (define (string-ends-with? string tail) (and (>= (string-length string) (string-length tail)) diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm index 3bed2a5e..ce33fb57 100644 --- a/module/hnh/module-introspection/module-uses.scm +++ b/module/hnh/module-introspection/module-uses.scm @@ -1,7 +1,7 @@ (define-module (hnh module-introspection module-uses) :use-module (ice-9 match) :use-module (hnh util) - :use-module ((srfi srfi-1) :select (concatenate)) + :use-module ((srfi srfi-1) :select (concatenate every)) :use-module ((srfi srfi-88) :select (string->keyword)) :use-module (rnrs records syntactic) :export (module-uses*)) @@ -13,24 +13,28 @@ ;;; Code: (define-record-type (module make-module% module?) - (fields name select hide prefix renamer version)) + (fields name select hide prefix renamer version autoload)) -(define* (make-module name key: - (select #f) - (hide '()) - (prefix #f) +(define* (make-module name ; (list-of symbol?) + key: + (select #f) ; (or false? (list-of symbol?)) + (hide '()) ; (list-of symbol?) + (prefix #f) ; (or false? symbol?):w (renamer #f) - (version #f)) - (make-module% name select hide prefix renamer version)) + (version #f) + (autoload #f) ; boolean? + ) + (make-module% name select hide prefix renamer version autoload)) (define (module->list module) (append (list (module-name module)) (awhen (module-select module) `(#:select ,it)) - (awhen (module-hide module) `(#:hide ,it)) + `(#:hide ,(module-hide module)) (awhen (module-prefix module) `(#:prefix ,it)) (awhen (module-renamer module) `(#:renamer ,it)) - (awhen (module-version module) `(#:version ,it)))) + (awhen (module-version module) `(#:version ,it)) + `(#:autoload ,(module-autoload module)))) ;; Normalizes keywords (#:key) and pseudo keywords (:key) used by define-module syntax. (define (normalize-keyword kw-or-symb) @@ -40,7 +44,10 @@ string->keyword)) ((keyword? kw-or-symb) kw-or-symb) - (else (error "Bad keyword like" kw-or-symb)))) + (else (scm-error 'wrong-type-arg "normalize-keyword" + "Expected symbol or keyword, got: ~s" + (list kw-or-symb) + #f)))) ;; Takes one argument as taken by @code{use-modules}, or following #:use-module ;; in @code{define-module}. @@ -59,8 +66,16 @@ (group args 2)))))) ;; matches `(srfi srfi-1) ((parts ...) + (unless (every symbol? parts) + (scm-error 'wrong-type-arg "parse-interface-specification" + "Not a valid module import: ~s" + (list interface-specification) + #f)) (make-module parts)) - (_ (error "Bad module declaration")))) + (_ (scm-error 'wrong-type-arg "parse-interface-specification" + "Bad module declaration, got: ~s" + (list interface-specification) + #f)))) ;; Finds all define-module forms, and returns what they ;; pull in (including autoloads) @@ -73,7 +88,9 @@ (cons (parse-interface-specification (cadr directives)) (loop (cddr directives)))) ((memv (car directives) '(#:autoload #{:autoload}#)) - (cons (cadr directives) + (cons (make-module (cadr directives) + select: (caddr directives) + autoload: #t) (loop (cdddr directives)))) (else (loop (cdr directives)))))) ((form forms ...) diff --git a/tests/test-module-tree/README.md b/tests/test-module-tree/README.md new file mode 100644 index 00000000..07cdca5d --- /dev/null +++ b/tests/test-module-tree/README.md @@ -0,0 +1,4 @@ +Test module tree +================ + +This directory contains test data, primarily for the module-introspection. diff --git a/tests/test-module-tree/a.scm b/tests/test-module-tree/a.scm new file mode 100644 index 00000000..c332b884 --- /dev/null +++ b/tests/test-module-tree/a.scm @@ -0,0 +1,6 @@ +(define-module (a) + :use-module (srfi srfi-1) + :export (f)) + +(define (f x) + (* x 2)) diff --git a/tests/test-module-tree/a/b.scm b/tests/test-module-tree/a/b.scm new file mode 100644 index 00000000..3ffb0c99 --- /dev/null +++ b/tests/test-module-tree/a/b.scm @@ -0,0 +1,2 @@ +(define-module (a b) + ) diff --git a/tests/test-module-tree/a/c.scm b/tests/test-module-tree/a/c.scm new file mode 100644 index 00000000..c5a369a3 --- /dev/null +++ b/tests/test-module-tree/a/c.scm @@ -0,0 +1,3 @@ +;;; This is not a module! + +(+ 1 2) diff --git a/tests/test-module-tree/b.scm b/tests/test-module-tree/b.scm new file mode 100644 index 00000000..341fab35 --- /dev/null +++ b/tests/test-module-tree/b.scm @@ -0,0 +1 @@ +(define-module (b)) diff --git a/tests/unit/module-introspection/all-modules.scm b/tests/unit/module-introspection/all-modules.scm new file mode 100644 index 00000000..da59c77c --- /dev/null +++ b/tests/unit/module-introspection/all-modules.scm @@ -0,0 +1,93 @@ +(define-module (test module-introspection all-modules) + :use-module (srfi srfi-1) + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((hnh util) :select (sort*)) + :use-module (hnh module-introspection all-modules)) + + +(test-group "fs-find" + (for-each (lambda (reference entry) + (test-equal "Filename" (list-ref reference 1) (list-ref entry 0)) + (test-group "Stat data" + (test-assert (vector? (list-ref entry 1))) + (test-equal 18 (vector-length (list-ref entry 1)))) + (test-equal "File type" (list-ref reference 0) (list-ref entry 2)) + ) + '((directory "tests/test-module-tree") + (regular "tests/test-module-tree/README.md") + (directory "tests/test-module-tree/a") + (regular "tests/test-module-tree/a.scm") + (regular "tests/test-module-tree/a/b.scm") + (regular "tests/test-module-tree/a/c.scm") + (regular "tests/test-module-tree/b.scm")) + (sort* + (fs-find "tests/test-module-tree") + string< car))) + + + +(test-equal "all-files" + '("tests/test-module-tree/README.md" + "tests/test-module-tree/a.scm" + "tests/test-module-tree/a/b.scm" + "tests/test-module-tree/a/c.scm" + "tests/test-module-tree/b.scm") + (sort* + (all-files-under-directory "tests/test-module-tree" + "") + string<)) + +(test-equal "all SCM files" + '("tests/test-module-tree/a.scm" + "tests/test-module-tree/a/b.scm" + "tests/test-module-tree/a/c.scm" + "tests/test-module-tree/b.scm") + (sort* + (all-files-under-directory "tests/test-module-tree" + ".scm") + string<)) + + +;; module-file-mapping +;; all-files-and-modules-under-directory + +(test-equal "all SCM files and modules" + '(("tests/test-module-tree/a.scm" (a)) + ("tests/test-module-tree/a/b.scm" (a b)) + ("tests/test-module-tree/a/c.scm" #f) + ("tests/test-module-tree/b.scm" (b))) + (sort* + (all-files-and-modules-under-directory "tests/test-module-tree") + string< car)) + +(test-group "all-modules-under-directory" + (let ((files modules + (all-modules-under-directory + "tests/test-module-tree"))) + (test-equal "Files" + '("tests/test-module-tree/a.scm" + "tests/test-module-tree/a/b.scm" + "tests/test-module-tree/a/c.scm" + "tests/test-module-tree/b.scm") + (sort* files string<)) + (test-equal "Modules" + '((a) (b) (a b)) + (sort modules + (lambda (a b) + (cond ((< (length a) (length b)) #t) + ((> (length a) (length b)) #f) + (else (string<? + (string-concatenate (map symbol->string a)) + (string-concatenate (map symbol->string b)))))))))) +(test-equal "Files" + '(((a) . "tests/test-module-tree/a.scm") + ((a b) . "tests/test-module-tree/a/b.scm") + ((b) . "tests/test-module-tree/b.scm")) + (sort* + (module-file-mapping "tests/test-module-tree") + string< cdr)) + +'((hnh module-introspection all-modules)) + diff --git a/tests/unit/module-introspection/module-uses.scm b/tests/unit/module-introspection/module-uses.scm new file mode 100644 index 00000000..f460f9dc --- /dev/null +++ b/tests/unit/module-introspection/module-uses.scm @@ -0,0 +1,68 @@ +(define-module (test module-introspection module-uses) + :use-module (srfi srfi-1) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((hnh util) :select (sort*)) + :use-module (hnh module-introspection module-uses)) + + +(test-equal "Basic example" + '(((srfi srfi-1) hide: () autoload: #f) + ((not-a-real-module) select: (x) hide: () autoload: #f)) + (module-uses* + '((define-module (test-module) + :use-module (srfi srfi-1)) + + (@ (not-a-real-module) x)))) + +(test-equal "Multiple imports of same module" + '(((xdg basedir) hide: () autoload: #f) + ((xdg basedir) select: (config-home) hide: () autoload: #f)) + (module-uses* + '((use-modules + ((xdg basedir))) + (@ (xdg basedir) config-home)))) + +(test-equal "Multiple imports of same thing + alternative keyword" + '(((xdg basedir) hide: () prefix: xdg- autoload: #f) + ((xdg basedir) select: (config-home) hide: () autoload: #f)) + (module-uses* + '((define-module (test) + ;; Prefix written as keyword, to test that normalization + :use-module ((xdg basedir) #:prefix xdg-)) + (@ (xdg basedir) config-home)))) + +(test-equal "Autoload + import private" + '(((mod-1) select: (x) hide: () autoload: #t) + ((mod-2) select: (z) hide: () autoload: #f)) + (module-uses* + '((define-module (test) + :autoload (mod-1) (x)) + (@@ (mod-2) z)))) + +(test-equal ":version on define-module, along with \"weird\" symbols" + '(((tt) select: (y) hide: () version: (0 1) autoload: #f)) + (module-uses* + '((define-module (test) + :version (1 1) + :use-module ((tt) :select (y) :version (0 1)))))) + +(test-error 'wrong-type-arg + (module-uses* + '((use-modules x)))) + +(test-error 'wrong-type-arg + (module-uses* + '((use-modules (x :select (y)))))) + +(test-error 'wrong-type-arg + (module-uses* + '((use-modules ((x) (y)))))) + +(test-error 'wrong-type-arg + (module-uses* + '((use-modules ((x) 1 (y)))))) + +'((hnh module-introspection module-uses)) diff --git a/tests/unit/module-introspection/static-util.scm b/tests/unit/module-introspection/static-util.scm new file mode 100644 index 00000000..f9b7e17e --- /dev/null +++ b/tests/unit/module-introspection/static-util.scm @@ -0,0 +1,15 @@ +(define-module (test module-introspection static-util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (hnh module-introspection static-util)) + +(test-equal "All forms" + '((define (f x) + (* x 2)) + (define-module (a) + :use-module (srfi srfi-1) + :export (f))) + (call-with-input-file "tests/test-module-tree/a.scm" get-forms)) + + +'((hnh module-introspection static-util)) |