Move all generally usable scripts to module dir.

4 files changed, 152 insertions, 0 deletions

diff --git a/module/hnh/module-introspection.scm b/module/hnh/module-introspection.scm
new file mode 100644
index 00000000..83e561f1
--- /dev/null
+++ b/module/hnh/module-introspection.scm
@@ -0,0 +1,22 @@
+(define-module (hnh module-introspection)
+  :use-module (srfi srfi-1)
+  :use-module (hnh util)
+  :export (unique-symbols
+           find-module-declaration
+           module-declaration?
+           ))
+
+
+(define (unique-symbols tree)
+  (uniq
+   (sort* (filter symbol? (flatten tree))
+          string<? symbol->string)))
+
+(define (module-declaration? form)
+  (cond ((null? form) #f)
+        ((not (pair? form)) #f)
+        (else (eq? 'define-module (car form)))))
+
+(define (find-module-declaration forms)
+  (and=> (find module-declaration? forms)
+         cadr))
diff --git a/module/hnh/module-introspection/all-modules.scm b/module/hnh/module-introspection/all-modules.scm
new file mode 100644
index 00000000..1bf39e1e
--- /dev/null
+++ b/module/hnh/module-introspection/all-modules.scm
@@ -0,0 +1,55 @@
+(define-module (hnh module-introspection all-modules)
+  :use-module (ice-9 regex)
+  :use-module (srfi srfi-1)
+  :use-module (ice-9 ftw)
+  :use-module (ice-9 match)
+  :use-module (hnh util path)
+  :use-module (hnh module-introspection)
+  :use-module ((hnh module-introspection static-util) :select (get-forms))
+  :export (all-files-and-modules-under-directory
+           all-modules-under-directory
+           fs-find-base fs-find
+           module-file-mapping
+           ))
+
+(define (fs-find dir)
+  (define files '())
+  (ftw dir (lambda args (set! files (cons args files)) #t))
+  files)
+
+;; (define (fs-find proc dir)
+;;   (filter proc (fs-find-base dir)))
+
+(define (all-files-and-modules-under-directory dir)
+  (define re (make-regexp "\\.scm$"))
+
+  (define files
+    (map car
+         (filter (match-lambda ((filename _ 'regular)
+                                (and (regexp-exec re filename)
+                                     (not (file-hidden? filename))))
+                               (_ #f))
+                 (fs-find dir))))
+
+  (map (lambda (file)
+         (list file
+               (call-with-input-file file
+                 (compose find-module-declaration get-forms))))
+       files))
+
+(define (all-modules-under-directory dir)
+  "Returns two values, all scm files in dir, and all top
+level modules in those files"
+
+  (define pairs (all-files-and-modules-under-directory dir))
+  (values
+   (map car pairs)
+   (filter identity (map cadr pairs))))
+
+;; Returns an association list from module names the modules
+;; containing filename
+(define (module-file-mapping dir)
+  (filter
+   car
+   (map (lambda (pair) (cons (cadr pair) (car pair)))
+        (all-files-and-modules-under-directory dir))))
diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm
new file mode 100644
index 00000000..d690f1d7
--- /dev/null
+++ b/module/hnh/module-introspection/module-uses.scm
@@ -0,0 +1,66 @@
+(define-module (hnh module-introspection module-uses)
+  :use-module (ice-9 match)
+  :export (module-uses*))
+
+;;; Commentary:
+;;; Static analyze version of guile's built in module-uses.
+;;; Will give a less accurate result, but in turn doesn't
+;;; require that the target module compiles.
+;;; Code:
+
+(define (parse-interface-specification interface-specification)
+  (match interface-specification
+    ;; matches `((srfi srfi-1) :select (something))
+    (((parts ...) args ...)
+     parts)
+    ;; matches `(srfi srfi-1)
+    ((parts ...)
+     parts)
+    (_ (error "Bad module declaration"))))
+
+;; Finds all define-module forms, and returns what they
+;; pull in (including autoloads)
+(define (module-declaration-uses forms)
+  (match forms
+    (('define-module module-name directives ...)
+     (let loop ((directives directives))
+       (cond ((null? directives) '())
+             ((memv (car directives) '(#:use-module #{:use-module}#))
+              (cons (parse-interface-specification (cadr directives))
+                    (loop (cddr directives))))
+             ((memv (car directives) '(#:autoload #{:autoload}#))
+              (cons (cadr directives)
+                    (loop (cdddr directives))))
+             (else (loop (cdr directives))))))
+    ((form forms ...)
+     (append (module-declaration-uses form)
+             (module-declaration-uses forms)))
+    (_ '())))
+
+;; find all use-modules forms, and return what they pull in
+(define (module-use-module-uses forms)
+  (match forms
+    (('use-modules modules ...)
+     (map parse-interface-specification modules))
+    ((form forms ...)
+     (append (module-use-module-uses form)
+             (module-use-module-uses forms)))
+    (_ '())))
+
+;; find all explicit module references (e.g.
+;; (@ (module) var) and (@@ (module) private-var)),
+;; and return those modules
+(define (module-refer-uses forms)
+  (match forms
+    (((or '@ '@@) module _) (list module))
+    ((form forms ...)
+     (append (module-refer-uses form)
+             (module-refer-uses forms)))
+    (_ '())))
+
+;; List of all modules pulled in in any of forms
+(define (module-uses* forms)
+  (append
+   (module-declaration-uses forms)
+   (module-use-module-uses  forms)
+   (module-refer-uses       forms)))
diff --git a/module/hnh/module-introspection/static-util.scm b/module/hnh/module-introspection/static-util.scm
new file mode 100644
index 00000000..7593ce3c
--- /dev/null
+++ b/module/hnh/module-introspection/static-util.scm
@@ -0,0 +1,9 @@
+(define-module (hnh module-introspection static-util)
+  :export (get-forms))
+
+(define (get-forms port)
+  (let loop ((done '()))
+    (let ((form (read port)))
+      (if (eof-object? form)
+          done
+          (loop (cons form done))))))