Add tests for module introspection.

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