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 ++++++++++++++++++++++---
 1 file changed, 55 insertions(+), 7 deletions(-)

(limited to 'module/hnh')

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))))
-- 
cgit v1.2.3