From 630f6ace92c81b811d0545d8ff1d63fbfea23585 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sun, 16 Oct 2022 01:58:27 +0200
Subject: Improve source-analyzing module introspection.

---
 module/hnh/module-introspection/module-uses.scm | 62 ++++++++++++++++++++++---
 module/scripts/module-imports.scm               | 21 ++++++---
 2 files changed, 69 insertions(+), 14 deletions(-)

diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm
index d690f1d7..b82aa6d0 100644
--- a/module/hnh/module-introspection/module-uses.scm
+++ b/module/hnh/module-introspection/module-uses.scm
@@ -1,5 +1,9 @@
 (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:
@@ -8,14 +12,54 @@
 ;;; 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 ...)
-     parts)
+     (apply make-module
+            `(,parts ,@(concatenate
+                        (map (lambda (pair)
+                               (cons (normalize-keyword (car pair))
+                                     (cdr pair)))
+                             (group args 2))))))
     ;; matches `(srfi srfi-1)
     ((parts ...)
-     parts)
+     (make-module parts))
     (_ (error "Bad module declaration"))))
 
 ;; Finds all define-module forms, and returns what they
@@ -52,15 +96,19 @@
 ;; and return those modules
 (define (module-refer-uses forms)
   (match forms
-    (((or '@ '@@) module _) (list module))
+    (((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)
-  (append
-   (module-declaration-uses forms)
-   (module-use-module-uses  forms)
-   (module-refer-uses       forms)))
+  (map module->list
+       (append
+        (module-declaration-uses forms)
+        (module-use-module-uses  forms)
+        (module-refer-uses       forms))))
diff --git a/module/scripts/module-imports.scm b/module/scripts/module-imports.scm
index dc7d9a78..8f9ab1b8 100755
--- a/module/scripts/module-imports.scm
+++ b/module/scripts/module-imports.scm
@@ -24,6 +24,7 @@
 
 (define (main . args)
   (define filename (car args))
+  ;; TODO Module declaration can reside inside a cond-expand block
   (define-values (module-declaration-list forms)
     (partition module-declaration?
                (reverse (call-with-input-file filename get-forms))))
@@ -41,15 +42,21 @@
                       (srfi srfi-1)
                       ))
 
-
   (define modules
+    ;; If we didn't find the module declaration
     (if (null? module-declaration-list)
-        (map resolve-interface
-             (remp (lambda (mod) (member mod skip-list))
-                   (module-uses* forms)))
-        (remp (lambda (mod) (member (module-name mod) skip-list))
-              (module-uses (resolve-module
-                            (cadr (car module-declaration-list)))))))
+        ;; Find symbols by best effort
+        (begin
+          (format #t "Using our make-shift module introspection~%")
+          (map (lambda (mod) (apply resolve-interface mod))
+               (remp (lambda (mod) (member (car mod) skip-list))
+                     (module-uses* forms))))
+        ;; If we did find the declaration, use the actual symbol in
+        (begin
+          (format #t "Using guile's true module introspection~%")
+          (remp (lambda (mod) (member (module-name mod) skip-list))
+                (module-uses (resolve-module
+                              (cadr (car module-declaration-list))))))))
 
   (format #t "=== ~a ===~%" filename)
   (for-each (lambda (mod)
-- 
cgit v1.2.3