diff options
Diffstat (limited to 'module/hnh/module-introspection')
-rw-r--r-- | module/hnh/module-introspection/all-modules.scm | 55 | ||||
-rw-r--r-- | module/hnh/module-introspection/module-uses.scm | 116 | ||||
-rw-r--r-- | module/hnh/module-introspection/static-util.scm | 9 |
3 files changed, 180 insertions, 0 deletions
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..3bed2a5e --- /dev/null +++ b/module/hnh/module-introspection/module-uses.scm @@ -0,0 +1,116 @@ +(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-88) :select (string->keyword)) + :use-module (rnrs records syntactic) + :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-record-type (module make-module% module?) + (fields name select hide prefix renamer version)) + +(define* (make-module name key: + (select #f) + (hide '()) + (prefix #f) + (renamer #f) + (version #f)) + (make-module% name select hide prefix renamer version)) + +(define (module->list module) + (append + (list (module-name module)) + (awhen (module-select module) `(#:select ,it)) + (awhen (module-hide module) `(#:hide ,it)) + (awhen (module-prefix module) `(#:prefix ,it)) + (awhen (module-renamer module) `(#:renamer ,it)) + (awhen (module-version module) `(#:version ,it)))) + +;; Normalizes keywords (#:key) and pseudo keywords (:key) used by define-module syntax. +(define (normalize-keyword kw-or-symb) + (cond ((symbol? kw-or-symb) + (-> (symbol->string kw-or-symb) + (string-drop 1) + string->keyword)) + ((keyword? kw-or-symb) + kw-or-symb) + (else (error "Bad keyword like" kw-or-symb)))) + +;; Takes one argument as taken by @code{use-modules}, or following #:use-module +;; in @code{define-module}. +;; returns a list on the form +;; (module-name (key value) ...) +;; where module name is something like (srfi srfi-1) +(define (parse-interface-specification interface-specification) + (match interface-specification + ;; matches `((srfi srfi-1) :select (something)) + (((parts ...) args ...) + (apply make-module + `(,parts ,@(concatenate + (map (lambda (pair) + (cons (normalize-keyword (car pair)) + (cdr pair))) + (group args 2)))))) + ;; matches `(srfi srfi-1) + ((parts ...) + (make-module 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 +;; NOTE this will pull in all forms looking like a (use-modules ...) +;; form, even if they are quoted, or in a cond-expand +(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 symb) + (list (make-module module select: (list symb)))) + ((form forms ...) + (append (module-refer-uses form) + (module-refer-uses forms))) + (_ '()))) + +;; List of all modules pulled in in any of forms +;; Returns a list where each element suitable to have +;; resolve-interface applied to it. +(define (module-uses* forms) + (map module->list + (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)))))) |