blob: 19a4acd76c55280679e99124ce9a3d7d4f4abeed (
plain)
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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix modules)
#:use-module (guix memoization)
#:use-module (guix sets)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:export (missing-dependency-error?
missing-dependency-module
source-module-closure
live-module-closure
guix-module-name?))
;;; Commentary:
;;;
;;; This module provides introspection tools for Guile modules at the source
;;; level. Namely, it allows you to determine the closure of a module; it
;;; does so just by reading the 'define-module' clause of the module and its
;;; dependencies. This is primarily useful as an argument to
;;; 'with-imported-modules'.
;;;
;;; Code:
;; The error corresponding to a missing module.
(define-condition-type &missing-dependency-error &error
missing-dependency-error?
(module missing-dependency-module))
(define (colon-symbol? obj)
"Return true if OBJ is a symbol that starts with a colon."
(and (symbol? obj)
(string-prefix? ":" (symbol->string obj))))
(define (colon-symbol->keyword symbol)
"Convert SYMBOL to a keyword after stripping its initial ':'."
(symbol->keyword
(string->symbol (string-drop (symbol->string symbol) 1))))
(define (extract-dependencies clauses)
"Return the list of modules imported according to the given 'define-module'
CLAUSES."
(let loop ((clauses clauses)
(result '()))
(match clauses
(()
(reverse result))
((#:use-module (module (or #:select #:hide #:prefix #:renamer) _)
rest ...)
(loop rest (cons module result)))
((#:use-module module rest ...)
(loop rest (cons module result)))
((#:autoload module _ rest ...)
(loop rest (cons module result)))
(((or #:export #:re-export #:export-syntax #:re-export-syntax
#:replace #:version)
_ rest ...)
(loop rest result))
(((or #:pure #:no-backtrace) rest ...)
(loop rest result))
(((? colon-symbol? symbol) rest ...)
(loop (cons (colon-symbol->keyword symbol) rest)
result)))))
(define module-file-dependencies
(mlambda (file)
"Return the list of the names of modules that the Guile module in FILE
depends on."
(call-with-input-file file
(lambda (port)
(match (read port)
(('define-module name clauses ...)
(extract-dependencies clauses))
;; XXX: R6RS 'library' form is ignored.
(_
'()))))))
(define (module-name->file-name module)
"Return the file name for MODULE."
(string-append (string-join (map symbol->string module) "/")
".scm"))
(define (guix-module-name? name)
"Return true if NAME (a list of symbols) denotes a Guix or GuixSD module."
(match name
(('guix _ ...) #t)
(('gnu _ ...) #t)
(_ #f)))
(define %source-less-modules
;; These are modules that have no corresponding source files or a source
;; file different from what you'd expect.
'((system syntax) ;2.0, defined in boot-9
(ice-9 ports internal) ;2.2, defined in (ice-9 ports)
(system syntax internal))) ;2.2, defined in boot-9
(define* (source-module-dependencies module #:optional (load-path %load-path))
"Return the modules used by MODULE by looking at its source code."
(if (member module %source-less-modules)
'()
(match (search-path load-path (module-name->file-name module))
((? string? file)
(module-file-dependencies file))
(#f
(raise (condition (&missing-dependency-error
(module module))))))))
(define* (module-closure modules
#:key
(select? guix-module-name?)
(dependencies source-module-dependencies))
"Return the closure of MODULES, calling DEPENDENCIES to determine the list
of modules used by a given module. MODULES and the result are a list of Guile
module names. Only modules that match SELECT? are considered."
(let loop ((modules modules)
(result '())
(visited (set)))
(match modules
(()
(reverse result))
((module rest ...)
(cond ((set-contains? visited module)
(loop rest result visited))
((select? module)
(loop (append (dependencies module) rest)
(cons module result)
(set-insert module visited)))
(else
(loop rest result visited)))))))
(define* (source-module-closure modules
#:optional (load-path %load-path)
#:key (select? guix-module-name?))
"Return the closure of MODULES by reading 'define-module' forms in their
source code. MODULES and the result are a list of Guile module names. Only
modules that match SELECT? are considered."
(module-closure modules
#:dependencies (cut source-module-dependencies <> load-path)
#:select? select?))
(define* (live-module-closure modules
#:key (select? guix-module-name?))
"Return the closure of MODULES, determined by looking at live (loaded)
module information. MODULES and the result are a list of Guile module names.
Only modules that match SELECT? are considered."
(define (dependencies module)
(map module-name
(delq the-scm-module (module-uses (resolve-module module)))))
(module-closure modules
#:dependencies dependencies
#:select? select?))
;;; modules.scm ends here
|