1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
(define-module (hnh module-introspection module-uses)
:use-module (ice-9 match)
:use-module (hnh util)
:use-module ((srfi srfi-1) :select (concatenate every))
: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 autoload))
(define* (make-module name ; (list-of symbol?)
key:
(select #f) ; (or false? (list-of symbol?))
(hide '()) ; (list-of symbol?)
(prefix #f) ; (or false? symbol?):w
(renamer #f)
(version #f)
(autoload #f) ; boolean?
)
(make-module% name select hide prefix renamer version autoload))
(define (module->list module)
(append
(list (module-name module))
(awhen (module-select module) `(#:select ,it))
`(#:hide ,(module-hide module))
(awhen (module-prefix module) `(#:prefix ,it))
(awhen (module-renamer module) `(#:renamer ,it))
(awhen (module-version module) `(#:version ,it))
`(#:autoload ,(module-autoload module))))
;; 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 (scm-error 'wrong-type-arg "normalize-keyword"
"Expected symbol or keyword, got: ~s"
(list kw-or-symb)
#f))))
;; 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 ...)
(unless (every symbol? parts)
(scm-error 'wrong-type-arg "parse-interface-specification"
"Not a valid module import: ~s"
(list interface-specification)
#f))
(make-module parts))
(_ (scm-error 'wrong-type-arg "parse-interface-specification"
"Bad module declaration, got: ~s"
(list interface-specification)
#f))))
;; 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 (make-module (cadr directives)
select: (caddr directives)
autoload: #t)
(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))))
|
