Add tests for module introspection.

8 files changed, 192 insertions, 0 deletions

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