Commit | Line | Data |
---|---|---|
21b679f6 | 1 | ;;; GNU Guix --- Functional package management for GNU |
1ae16033 | 2 | ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> |
bdcf0e6f | 3 | ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> |
e8e1f295 | 4 | ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> |
21b679f6 LC |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (guix gexp) | |
e87f0591 | 22 | #:use-module (guix store) |
21b679f6 | 23 | #:use-module (guix monads) |
e87f0591 | 24 | #:use-module (guix derivations) |
7adf9b84 | 25 | #:use-module (guix grafts) |
aa72d9af | 26 | #:use-module (guix utils) |
e8e1f295 | 27 | #:use-module (rnrs bytevectors) |
21b679f6 LC |
28 | #:use-module (srfi srfi-1) |
29 | #:use-module (srfi srfi-9) | |
7560b00b | 30 | #:use-module (srfi srfi-9 gnu) |
21b679f6 | 31 | #:use-module (srfi srfi-26) |
3e43166f LC |
32 | #:use-module (srfi srfi-34) |
33 | #:use-module (srfi srfi-35) | |
21b679f6 LC |
34 | #:use-module (ice-9 match) |
35 | #:export (gexp | |
36 | gexp? | |
0bb9929e | 37 | with-imported-modules |
838e17d8 | 38 | with-extensions |
0dbea56b LC |
39 | |
40 | gexp-input | |
41 | gexp-input? | |
558e8b11 | 42 | |
d9ae938f LC |
43 | local-file |
44 | local-file? | |
74d441ab | 45 | local-file-file |
9d3994f7 | 46 | local-file-absolute-file-name |
74d441ab LC |
47 | local-file-name |
48 | local-file-recursive? | |
0dbea56b | 49 | |
558e8b11 LC |
50 | plain-file |
51 | plain-file? | |
52 | plain-file-name | |
53 | plain-file-content | |
54 | ||
91937029 LC |
55 | computed-file |
56 | computed-file? | |
57 | computed-file-name | |
58 | computed-file-gexp | |
91937029 LC |
59 | computed-file-options |
60 | ||
15a01c72 LC |
61 | program-file |
62 | program-file? | |
63 | program-file-name | |
64 | program-file-gexp | |
15a01c72 | 65 | program-file-guile |
427ec19e | 66 | program-file-module-path |
15a01c72 | 67 | |
e1c153e0 LC |
68 | scheme-file |
69 | scheme-file? | |
70 | scheme-file-name | |
71 | scheme-file-gexp | |
72 | ||
a9e5e92f LC |
73 | file-append |
74 | file-append? | |
75 | file-append-base | |
76 | file-append-suffix | |
77 | ||
64fc9f65 RJ |
78 | load-path-expression |
79 | gexp-modules | |
80 | ||
21b679f6 LC |
81 | gexp->derivation |
82 | gexp->file | |
462a3fa3 | 83 | gexp->script |
aa72d9af | 84 | text-file* |
b751cde3 | 85 | mixed-text-file |
dedb512f | 86 | file-union |
d298c815 | 87 | directory-union |
aa72d9af LC |
88 | imported-files |
89 | imported-modules | |
ff40e9b7 LC |
90 | compiled-modules |
91 | ||
92 | define-gexp-compiler | |
6b6298ae | 93 | gexp-compiler? |
bdcf0e6f | 94 | file-like? |
c2b84676 | 95 | lower-object |
6b6298ae | 96 | |
3e43166f LC |
97 | lower-inputs |
98 | ||
99 | &gexp-error | |
100 | gexp-error? | |
101 | &gexp-input-error | |
102 | gexp-input-error? | |
103 | gexp-error-invalid-input)) | |
21b679f6 LC |
104 | |
105 | ;;; Commentary: | |
106 | ;;; | |
107 | ;;; This module implements "G-expressions", or "gexps". Gexps are like | |
108 | ;;; S-expressions (sexps), with two differences: | |
109 | ;;; | |
110 | ;;; 1. References (un-quotations) to derivations or packages in a gexp are | |
667b2508 LC |
111 | ;;; replaced by the corresponding output file name; in addition, the |
112 | ;;; 'ungexp-native' unquote-like form allows code to explicitly refer to | |
113 | ;;; the native code of a given package, in case of cross-compilation; | |
21b679f6 LC |
114 | ;;; |
115 | ;;; 2. Gexps embed information about the derivations they refer to. | |
116 | ;;; | |
117 | ;;; Gexps make it easy to write to files Scheme code that refers to store | |
118 | ;;; items, or to write Scheme code to build derivations. | |
119 | ;;; | |
120 | ;;; Code: | |
121 | ||
122 | ;; "G expressions". | |
123 | (define-record-type <gexp> | |
838e17d8 | 124 | (make-gexp references modules extensions proc) |
21b679f6 | 125 | gexp? |
affd7761 | 126 | (references gexp-references) ;list of <gexp-input> |
0bb9929e | 127 | (modules gexp-self-modules) ;list of module names |
838e17d8 | 128 | (extensions gexp-self-extensions) ;list of lowerable things |
affd7761 | 129 | (proc gexp-proc)) ;procedure |
21b679f6 | 130 | |
7560b00b LC |
131 | (define (write-gexp gexp port) |
132 | "Write GEXP on PORT." | |
133 | (display "#<gexp " port) | |
2cf0ea0d LC |
134 | |
135 | ;; Try to write the underlying sexp. Now, this trick doesn't work when | |
136 | ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure | |
137 | ;; tries to use 'append' on that, which fails with wrong-type-arg. | |
138 | (false-if-exception | |
667b2508 | 139 | (write (apply (gexp-proc gexp) |
affd7761 | 140 | (gexp-references gexp)) |
667b2508 | 141 | port)) |
7560b00b LC |
142 | (format port " ~a>" |
143 | (number->string (object-address gexp) 16))) | |
144 | ||
145 | (set-record-type-printer! <gexp> write-gexp) | |
146 | ||
bcb13287 LC |
147 | \f |
148 | ;;; | |
149 | ;;; Methods. | |
150 | ;;; | |
151 | ||
152 | ;; Compiler for a type of objects that may be introduced in a gexp. | |
153 | (define-record-type <gexp-compiler> | |
1cdecf24 | 154 | (gexp-compiler type lower expand) |
bcb13287 | 155 | gexp-compiler? |
1cdecf24 | 156 | (type gexp-compiler-type) ;record type descriptor |
ebdfd776 | 157 | (lower gexp-compiler-lower) |
1cdecf24 | 158 | (expand gexp-compiler-expand)) ;#f | DRV -> sexp |
bcb13287 | 159 | |
3e43166f LC |
160 | (define-condition-type &gexp-error &error |
161 | gexp-error?) | |
162 | ||
163 | (define-condition-type &gexp-input-error &gexp-error | |
164 | gexp-input-error? | |
165 | (input gexp-error-invalid-input)) | |
166 | ||
167 | ||
bcb13287 | 168 | (define %gexp-compilers |
1cdecf24 LC |
169 | ;; 'eq?' mapping of record type descriptor to <gexp-compiler>. |
170 | (make-hash-table 20)) | |
bcb13287 | 171 | |
ebdfd776 LC |
172 | (define (default-expander thing obj output) |
173 | "This is the default expander for \"things\" that appear in gexps. It | |
174 | returns its output file name of OBJ's OUTPUT." | |
175 | (match obj | |
176 | ((? derivation? drv) | |
177 | (derivation->output-path drv output)) | |
178 | ((? string? file) | |
179 | file))) | |
180 | ||
bcb13287 LC |
181 | (define (register-compiler! compiler) |
182 | "Register COMPILER as a gexp compiler." | |
1cdecf24 LC |
183 | (hashq-set! %gexp-compilers |
184 | (gexp-compiler-type compiler) compiler)) | |
bcb13287 LC |
185 | |
186 | (define (lookup-compiler object) | |
ebdfd776 | 187 | "Search for a compiler for OBJECT. Upon success, return the three argument |
bcb13287 | 188 | procedure to lower it; otherwise return #f." |
1cdecf24 LC |
189 | (and=> (hashq-ref %gexp-compilers (struct-vtable object)) |
190 | gexp-compiler-lower)) | |
bcb13287 | 191 | |
bdcf0e6f CL |
192 | (define (file-like? object) |
193 | "Return #t if OBJECT leads to a file in the store once unquoted in a | |
194 | G-expression; otherwise return #f." | |
195 | (and (struct? object) (->bool (lookup-compiler object)))) | |
196 | ||
ebdfd776 LC |
197 | (define (lookup-expander object) |
198 | "Search for an expander for OBJECT. Upon success, return the three argument | |
199 | procedure to expand it; otherwise return #f." | |
1cdecf24 LC |
200 | (and=> (hashq-ref %gexp-compilers (struct-vtable object)) |
201 | gexp-compiler-expand)) | |
ebdfd776 | 202 | |
c2b84676 LC |
203 | (define* (lower-object obj |
204 | #:optional (system (%current-system)) | |
205 | #:key target) | |
206 | "Return as a value in %STORE-MONAD the derivation or store item | |
207 | corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. | |
208 | OBJ must be an object that has an associated gexp compiler, such as a | |
209 | <package>." | |
3e43166f LC |
210 | (match (lookup-compiler obj) |
211 | (#f | |
212 | (raise (condition (&gexp-input-error (input obj))))) | |
213 | (lower | |
214 | (lower obj system target)))) | |
c2b84676 | 215 | |
ebdfd776 LC |
216 | (define-syntax define-gexp-compiler |
217 | (syntax-rules (=> compiler expander) | |
218 | "Define NAME as a compiler for objects matching PREDICATE encountered in | |
219 | gexps. | |
220 | ||
221 | In the simplest form of the macro, BODY must return a derivation for PARAM, an | |
222 | object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is | |
223 | #f except when cross-compiling.) | |
224 | ||
225 | The more elaborate form allows you to specify an expander: | |
226 | ||
227 | (define-gexp-compiler something something? | |
228 | compiler => (lambda (param system target) ...) | |
229 | expander => (lambda (param drv output) ...)) | |
230 | ||
231 | The expander specifies how an object is converted to its sexp representation." | |
1cdecf24 LC |
232 | ((_ (name (param record-type) system target) body ...) |
233 | (define-gexp-compiler name record-type | |
ebdfd776 LC |
234 | compiler => (lambda (param system target) body ...) |
235 | expander => default-expander)) | |
1cdecf24 | 236 | ((_ name record-type |
ebdfd776 LC |
237 | compiler => compile |
238 | expander => expand) | |
239 | (begin | |
240 | (define name | |
1cdecf24 | 241 | (gexp-compiler record-type compile expand)) |
ebdfd776 | 242 | (register-compiler! name))))) |
bcb13287 | 243 | |
1cdecf24 | 244 | (define-gexp-compiler (derivation-compiler (drv <derivation>) system target) |
2924f0d6 LC |
245 | ;; Derivations are the lowest-level representation, so this is the identity |
246 | ;; compiler. | |
247 | (with-monad %store-monad | |
248 | (return drv))) | |
249 | ||
bcb13287 | 250 | \f |
d9ae938f | 251 | ;;; |
558e8b11 | 252 | ;;; File declarations. |
d9ae938f LC |
253 | ;;; |
254 | ||
9d3994f7 LC |
255 | ;; A local file name. FILE is the file name the user entered, which can be a |
256 | ;; relative file name, and ABSOLUTE is a promise that computes its canonical | |
257 | ;; absolute file name. We keep it in a promise to compute it lazily and avoid | |
258 | ;; repeated 'stat' calls. | |
d9ae938f | 259 | (define-record-type <local-file> |
0687fc9c | 260 | (%%local-file file absolute name recursive? select?) |
d9ae938f LC |
261 | local-file? |
262 | (file local-file-file) ;string | |
9d3994f7 | 263 | (absolute %local-file-absolute-file-name) ;promise string |
d9ae938f | 264 | (name local-file-name) ;string |
0687fc9c LC |
265 | (recursive? local-file-recursive?) ;Boolean |
266 | (select? local-file-select?)) ;string stat -> Boolean | |
267 | ||
268 | (define (true file stat) #t) | |
d9ae938f | 269 | |
9d3994f7 | 270 | (define* (%local-file file promise #:optional (name (basename file)) |
0687fc9c | 271 | #:key recursive? (select? true)) |
9d3994f7 LC |
272 | ;; This intermediate procedure is part of our ABI, but the underlying |
273 | ;; %%LOCAL-FILE is not. | |
0687fc9c | 274 | (%%local-file file promise name recursive? select?)) |
9d3994f7 | 275 | |
9d3994f7 LC |
276 | (define (absolute-file-name file directory) |
277 | "Return the canonical absolute file name for FILE, which lives in the | |
278 | vicinity of DIRECTORY." | |
279 | (canonicalize-path | |
280 | (cond ((string-prefix? "/" file) file) | |
281 | ((not directory) file) | |
282 | ((string-prefix? "/" directory) | |
283 | (string-append directory "/" file)) | |
284 | (else file)))) | |
285 | ||
302d46e6 LC |
286 | (define-syntax local-file |
287 | (lambda (s) | |
288 | "Return an object representing local file FILE to add to the store; this | |
9d3994f7 LC |
289 | object can be used in a gexp. If FILE is a relative file name, it is looked |
290 | up relative to the source file where this form appears. FILE will be added to | |
291 | the store under NAME--by default the base name of FILE. | |
d9ae938f LC |
292 | |
293 | When RECURSIVE? is true, the contents of FILE are added recursively; if FILE | |
294 | designates a flat file and RECURSIVE? is true, its contents are added, and its | |
295 | permission bits are kept. | |
296 | ||
0687fc9c LC |
297 | When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, |
298 | where FILE is the entry's absolute file name and STAT is the result of | |
299 | 'lstat'; exclude entries for which SELECT? does not return true. | |
300 | ||
302d46e6 LC |
301 | This is the declarative counterpart of the 'interned-file' monadic procedure. |
302 | It is implemented as a macro to capture the current source directory where it | |
303 | appears." | |
304 | (syntax-case s () | |
305 | ((_ file rest ...) | |
306 | #'(%local-file file | |
307 | (delay (absolute-file-name file (current-source-directory))) | |
308 | rest ...)) | |
309 | ((_) | |
310 | #'(syntax-error "missing file name")) | |
311 | (id | |
312 | (identifier? #'id) | |
313 | ;; XXX: We could return #'(lambda (file . rest) ...). However, | |
314 | ;; (syntax-source #'id) is #f so (current-source-directory) would not | |
315 | ;; work. Thus, simply forbid this form. | |
316 | #'(syntax-error | |
317 | "'local-file' is a macro and cannot be used like this"))))) | |
9d3994f7 LC |
318 | |
319 | (define (local-file-absolute-file-name file) | |
320 | "Return the absolute file name for FILE, a <local-file> instance. A | |
321 | 'system-error' exception is raised if FILE could not be found." | |
322 | (force (%local-file-absolute-file-name file))) | |
d9ae938f | 323 | |
1cdecf24 | 324 | (define-gexp-compiler (local-file-compiler (file <local-file>) system target) |
d9ae938f LC |
325 | ;; "Compile" FILE by adding it to the store. |
326 | (match file | |
0687fc9c | 327 | (($ <local-file> file (= force absolute) name recursive? select?) |
9d3994f7 LC |
328 | ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing |
329 | ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling | |
330 | ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would | |
331 | ;; just throw an error, both of which are inconvenient. | |
0687fc9c LC |
332 | (interned-file absolute name |
333 | #:recursive? recursive? #:select? select?)))) | |
d9ae938f | 334 | |
558e8b11 LC |
335 | (define-record-type <plain-file> |
336 | (%plain-file name content references) | |
337 | plain-file? | |
338 | (name plain-file-name) ;string | |
e8e1f295 | 339 | (content plain-file-content) ;string or bytevector |
558e8b11 LC |
340 | (references plain-file-references)) ;list (currently unused) |
341 | ||
342 | (define (plain-file name content) | |
343 | "Return an object representing a text file called NAME with the given | |
344 | CONTENT (a string) to be added to the store. | |
345 | ||
346 | This is the declarative counterpart of 'text-file'." | |
347 | ;; XXX: For now just ignore 'references' because it's not clear how to use | |
348 | ;; them in a declarative context. | |
349 | (%plain-file name content '())) | |
350 | ||
1cdecf24 | 351 | (define-gexp-compiler (plain-file-compiler (file <plain-file>) system target) |
558e8b11 LC |
352 | ;; "Compile" FILE by adding it to the store. |
353 | (match file | |
e8e1f295 JN |
354 | (($ <plain-file> name (and (? string?) content) references) |
355 | (text-file name content references)) | |
356 | (($ <plain-file> name (and (? bytevector?) content) references) | |
357 | (binary-file name content references)))) | |
558e8b11 | 358 | |
91937029 | 359 | (define-record-type <computed-file> |
ab25eb7c | 360 | (%computed-file name gexp guile options) |
91937029 LC |
361 | computed-file? |
362 | (name computed-file-name) ;string | |
363 | (gexp computed-file-gexp) ;gexp | |
ab25eb7c | 364 | (guile computed-file-guile) ;<package> |
91937029 LC |
365 | (options computed-file-options)) ;list of arguments |
366 | ||
367 | (define* (computed-file name gexp | |
ab25eb7c | 368 | #:key guile (options '(#:local-build? #t))) |
91937029 | 369 | "Return an object representing the store item NAME, a file or directory |
a769bffb | 370 | computed by GEXP. OPTIONS is a list of additional arguments to pass |
91937029 LC |
371 | to 'gexp->derivation'. |
372 | ||
373 | This is the declarative counterpart of 'gexp->derivation'." | |
ab25eb7c | 374 | (%computed-file name gexp guile options)) |
91937029 | 375 | |
1cdecf24 | 376 | (define-gexp-compiler (computed-file-compiler (file <computed-file>) |
91937029 LC |
377 | system target) |
378 | ;; Compile FILE by returning a derivation whose build expression is its | |
379 | ;; gexp. | |
380 | (match file | |
ab25eb7c LC |
381 | (($ <computed-file> name gexp guile options) |
382 | (if guile | |
383 | (mlet %store-monad ((guile (lower-object guile system | |
384 | #:target target))) | |
385 | (apply gexp->derivation name gexp #:guile-for-build guile | |
386 | options)) | |
387 | (apply gexp->derivation name gexp options))))) | |
91937029 | 388 | |
15a01c72 | 389 | (define-record-type <program-file> |
427ec19e | 390 | (%program-file name gexp guile path) |
15a01c72 LC |
391 | program-file? |
392 | (name program-file-name) ;string | |
393 | (gexp program-file-gexp) ;gexp | |
427ec19e LC |
394 | (guile program-file-guile) ;package |
395 | (path program-file-module-path)) ;list of strings | |
15a01c72 | 396 | |
427ec19e | 397 | (define* (program-file name gexp #:key (guile #f) (module-path %load-path)) |
15a01c72 | 398 | "Return an object representing the executable store item NAME that runs |
427ec19e LC |
399 | GEXP. GUILE is the Guile package used to execute that script. Imported |
400 | modules of GEXP are looked up in MODULE-PATH. | |
15a01c72 LC |
401 | |
402 | This is the declarative counterpart of 'gexp->script'." | |
427ec19e | 403 | (%program-file name gexp guile module-path)) |
15a01c72 | 404 | |
1cdecf24 | 405 | (define-gexp-compiler (program-file-compiler (file <program-file>) |
15a01c72 LC |
406 | system target) |
407 | ;; Compile FILE by returning a derivation that builds the script. | |
408 | (match file | |
427ec19e | 409 | (($ <program-file> name gexp guile module-path) |
15a01c72 | 410 | (gexp->script name gexp |
427ec19e | 411 | #:module-path module-path |
15a01c72 LC |
412 | #:guile (or guile (default-guile)))))) |
413 | ||
e1c153e0 | 414 | (define-record-type <scheme-file> |
4fbd1a2b | 415 | (%scheme-file name gexp splice?) |
e1c153e0 LC |
416 | scheme-file? |
417 | (name scheme-file-name) ;string | |
4fbd1a2b LC |
418 | (gexp scheme-file-gexp) ;gexp |
419 | (splice? scheme-file-splice?)) ;Boolean | |
e1c153e0 | 420 | |
4fbd1a2b | 421 | (define* (scheme-file name gexp #:key splice?) |
e1c153e0 LC |
422 | "Return an object representing the Scheme file NAME that contains GEXP. |
423 | ||
424 | This is the declarative counterpart of 'gexp->file'." | |
4fbd1a2b | 425 | (%scheme-file name gexp splice?)) |
e1c153e0 | 426 | |
1cdecf24 | 427 | (define-gexp-compiler (scheme-file-compiler (file <scheme-file>) |
e1c153e0 LC |
428 | system target) |
429 | ;; Compile FILE by returning a derivation that builds the file. | |
430 | (match file | |
4fbd1a2b LC |
431 | (($ <scheme-file> name gexp splice?) |
432 | (gexp->file name gexp #:splice? splice?)))) | |
e1c153e0 | 433 | |
a9e5e92f LC |
434 | ;; Appending SUFFIX to BASE's output file name. |
435 | (define-record-type <file-append> | |
436 | (%file-append base suffix) | |
437 | file-append? | |
438 | (base file-append-base) ;<package> | <derivation> | ... | |
439 | (suffix file-append-suffix)) ;list of strings | |
440 | ||
441 | (define (file-append base . suffix) | |
442 | "Return a <file-append> object that expands to the concatenation of BASE and | |
443 | SUFFIX." | |
444 | (%file-append base suffix)) | |
445 | ||
1cdecf24 | 446 | (define-gexp-compiler file-append-compiler <file-append> |
a9e5e92f LC |
447 | compiler => (lambda (obj system target) |
448 | (match obj | |
449 | (($ <file-append> base _) | |
450 | (lower-object base system #:target target)))) | |
451 | expander => (lambda (obj lowered output) | |
452 | (match obj | |
453 | (($ <file-append> base suffix) | |
454 | (let* ((expand (lookup-expander base)) | |
455 | (base (expand base lowered output))) | |
456 | (string-append base (string-concatenate suffix))))))) | |
457 | ||
d9ae938f | 458 | \f |
bcb13287 LC |
459 | ;;; |
460 | ;;; Inputs & outputs. | |
461 | ;;; | |
462 | ||
e39d1461 LC |
463 | ;; The input of a gexp. |
464 | (define-record-type <gexp-input> | |
0dbea56b | 465 | (%gexp-input thing output native?) |
e39d1461 LC |
466 | gexp-input? |
467 | (thing gexp-input-thing) ;<package> | <origin> | <derivation> | ... | |
468 | (output gexp-input-output) ;string | |
469 | (native? gexp-input-native?)) ;Boolean | |
470 | ||
f7328634 LC |
471 | (define (write-gexp-input input port) |
472 | (match input | |
473 | (($ <gexp-input> thing output #f) | |
474 | (format port "#<gexp-input ~s:~a>" thing output)) | |
475 | (($ <gexp-input> thing output #t) | |
476 | (format port "#<gexp-input native ~s:~a>" thing output)))) | |
477 | ||
478 | (set-record-type-printer! <gexp-input> write-gexp-input) | |
479 | ||
0dbea56b LC |
480 | (define* (gexp-input thing ;convenience procedure |
481 | #:optional (output "out") | |
482 | #:key native?) | |
483 | "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines | |
484 | whether this should be considered a \"native\" input or not." | |
485 | (%gexp-input thing output native?)) | |
486 | ||
21b679f6 LC |
487 | ;; Reference to one of the derivation's outputs, for gexps used in |
488 | ;; derivations. | |
1e87da58 LC |
489 | (define-record-type <gexp-output> |
490 | (gexp-output name) | |
491 | gexp-output? | |
492 | (name gexp-output-name)) | |
21b679f6 | 493 | |
f7328634 LC |
494 | (define (write-gexp-output output port) |
495 | (match output | |
496 | (($ <gexp-output> name) | |
497 | (format port "#<gexp-output ~a>" name)))) | |
498 | ||
499 | (set-record-type-printer! <gexp-output> write-gexp-output) | |
500 | ||
838e17d8 LC |
501 | (define (gexp-attribute gexp self-attribute) |
502 | "Recurse on GEXP and the expressions it refers to, summing the items | |
503 | returned by SELF-ATTRIBUTE, a procedure that takes a gexp." | |
2363bdd7 LC |
504 | (if (gexp? gexp) |
505 | (delete-duplicates | |
838e17d8 | 506 | (append (self-attribute gexp) |
2363bdd7 LC |
507 | (append-map (match-lambda |
508 | (($ <gexp-input> (? gexp? exp)) | |
838e17d8 | 509 | (gexp-attribute exp self-attribute)) |
2363bdd7 LC |
510 | (($ <gexp-input> (lst ...)) |
511 | (append-map (lambda (item) | |
512 | (if (gexp? item) | |
838e17d8 LC |
513 | (gexp-attribute item |
514 | self-attribute) | |
2363bdd7 LC |
515 | '())) |
516 | lst)) | |
517 | (_ | |
518 | '())) | |
519 | (gexp-references gexp)))) | |
520 | '())) ;plain Scheme data type | |
0bb9929e | 521 | |
838e17d8 LC |
522 | (define (gexp-modules gexp) |
523 | "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is | |
524 | false, meaning that GEXP is a plain Scheme object, return the empty list." | |
525 | (gexp-attribute gexp gexp-self-modules)) | |
526 | ||
527 | (define (gexp-extensions gexp) | |
528 | "Return the list of Guile extensions (packages) GEXP relies on. If (gexp? | |
529 | GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty | |
530 | list." | |
531 | (gexp-attribute gexp gexp-self-extensions)) | |
532 | ||
68a61e9f LC |
533 | (define* (lower-inputs inputs |
534 | #:key system target) | |
535 | "Turn any package from INPUTS into a derivation for SYSTEM; return the | |
536 | corresponding input list as a monadic value. When TARGET is true, use it as | |
537 | the cross-compilation target triplet." | |
21b679f6 LC |
538 | (with-monad %store-monad |
539 | (sequence %store-monad | |
540 | (map (match-lambda | |
2242ff45 | 541 | (((? struct? thing) sub-drv ...) |
c2b84676 LC |
542 | (mlet %store-monad ((drv (lower-object |
543 | thing system #:target target))) | |
2242ff45 LC |
544 | (return `(,drv ,@sub-drv)))) |
545 | (input | |
546 | (return input))) | |
21b679f6 LC |
547 | inputs)))) |
548 | ||
b53833b2 LC |
549 | (define* (lower-reference-graphs graphs #:key system target) |
550 | "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a | |
551 | #:reference-graphs argument, lower it such that each INPUT is replaced by the | |
552 | corresponding derivation." | |
553 | (match graphs | |
554 | (((file-names . inputs) ...) | |
555 | (mlet %store-monad ((inputs (lower-inputs inputs | |
556 | #:system system | |
557 | #:target target))) | |
558 | (return (map cons file-names inputs)))))) | |
559 | ||
c8351d9a LC |
560 | (define* (lower-references lst #:key system target) |
561 | "Based on LST, a list of output names and packages, return a list of output | |
562 | names and file names suitable for the #:allowed-references argument to | |
563 | 'derivation'." | |
c8351d9a LC |
564 | (with-monad %store-monad |
565 | (define lower | |
566 | (match-lambda | |
567 | ((? string? output) | |
568 | (return output)) | |
accb682c | 569 | (($ <gexp-input> thing output native?) |
c2b84676 LC |
570 | (mlet %store-monad ((drv (lower-object thing system |
571 | #:target (if native? | |
572 | #f target)))) | |
accb682c | 573 | (return (derivation->output-path drv output)))) |
bcb13287 | 574 | (thing |
c2b84676 LC |
575 | (mlet %store-monad ((drv (lower-object thing system |
576 | #:target target))) | |
c8351d9a LC |
577 | (return (derivation->output-path drv)))))) |
578 | ||
579 | (sequence %store-monad (map lower lst)))) | |
580 | ||
ff40e9b7 LC |
581 | (define default-guile-derivation |
582 | ;; Here we break the abstraction by talking to the higher-level layer. | |
583 | ;; Thus, do the resolution lazily to hide the circular dependency. | |
584 | (let ((proc (delay | |
585 | (let ((iface (resolve-interface '(guix packages)))) | |
586 | (module-ref iface 'default-guile-derivation))))) | |
587 | (lambda (system) | |
588 | ((force proc) system)))) | |
589 | ||
21b679f6 LC |
590 | (define* (gexp->derivation name exp |
591 | #:key | |
68a61e9f | 592 | system (target 'current) |
21b679f6 LC |
593 | hash hash-algo recursive? |
594 | (env-vars '()) | |
595 | (modules '()) | |
4684f301 | 596 | (module-path %load-path) |
21b679f6 | 597 | (guile-for-build (%guile-for-build)) |
838e17d8 | 598 | (effective-version "2.2") |
ce45eb4c | 599 | (graft? (%graft?)) |
21b679f6 | 600 | references-graphs |
3f4ecf32 | 601 | allowed-references disallowed-references |
c0468155 | 602 | leaked-env-vars |
0309e1b0 | 603 | local-build? (substitutable? #t) |
a912c723 | 604 | deprecation-warnings |
0309e1b0 | 605 | (script-name (string-append name "-builder"))) |
21b679f6 | 606 | "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a |
0309e1b0 LC |
607 | derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When |
608 | TARGET is true, it is used as the cross-compilation target triplet for | |
609 | packages referred to by EXP. | |
21b679f6 | 610 | |
0bb9929e LC |
611 | MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to |
612 | make MODULES available in the evaluation context of EXP; MODULES is a list of | |
4684f301 | 613 | names of Guile modules searched in MODULE-PATH to be copied in the store, |
21b679f6 LC |
614 | compiled, and made available in the load path during the execution of |
615 | EXP---e.g., '((guix build utils) (guix build gnu-build-system)). | |
616 | ||
838e17d8 LC |
617 | EFFECTIVE-VERSION determines the string to use when adding extensions of |
618 | EXP (see 'with-extensions') to the search path---e.g., \"2.2\". | |
619 | ||
ce45eb4c LC |
620 | GRAFT? determines whether packages referred to by EXP should be grafted when |
621 | applicable. | |
622 | ||
b53833b2 LC |
623 | When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the |
624 | following forms: | |
625 | ||
626 | (FILE-NAME PACKAGE) | |
627 | (FILE-NAME PACKAGE OUTPUT) | |
628 | (FILE-NAME DERIVATION) | |
629 | (FILE-NAME DERIVATION OUTPUT) | |
630 | (FILE-NAME STORE-ITEM) | |
631 | ||
632 | The right-hand-side of each element of REFERENCES-GRAPHS is automatically made | |
633 | an input of the build process of EXP. In the build environment, each | |
634 | FILE-NAME contains the reference graph of the corresponding item, in a simple | |
635 | text format. | |
636 | ||
c8351d9a LC |
637 | ALLOWED-REFERENCES must be either #f or a list of output names and packages. |
638 | In the latter case, the list denotes store items that the result is allowed to | |
639 | refer to. Any reference to another store item will lead to a build error. | |
3f4ecf32 LC |
640 | Similarly for DISALLOWED-REFERENCES, which can list items that must not be |
641 | referenced by the outputs. | |
b53833b2 | 642 | |
a912c723 LC |
643 | DEPRECATION-WARNINGS determines whether to show deprecation warnings while |
644 | compiling modules. It can be #f, #t, or 'detailed. | |
645 | ||
21b679f6 | 646 | The other arguments are as for 'derivation'." |
0bb9929e LC |
647 | (define %modules |
648 | (delete-duplicates | |
649 | (append modules (gexp-modules exp)))) | |
21b679f6 LC |
650 | (define outputs (gexp-outputs exp)) |
651 | ||
b53833b2 LC |
652 | (define (graphs-file-names graphs) |
653 | ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. | |
654 | (map (match-lambda | |
838e17d8 | 655 | ;; TODO: Remove 'derivation?' special cases. |
b53833b2 LC |
656 | ((file-name (? derivation? drv)) |
657 | (cons file-name (derivation->output-path drv))) | |
658 | ((file-name (? derivation? drv) sub-drv) | |
659 | (cons file-name (derivation->output-path drv sub-drv))) | |
660 | ((file-name thing) | |
661 | (cons file-name thing))) | |
662 | graphs)) | |
663 | ||
838e17d8 LC |
664 | (define (extension-flags extension) |
665 | `("-L" ,(string-append (derivation->output-path extension) | |
666 | "/share/guile/site/" effective-version) | |
667 | "-C" ,(string-append (derivation->output-path extension) | |
668 | "/lib/guile/" effective-version "/site-ccache"))) | |
669 | ||
670 | (mlet* %store-monad ( ;; The following binding forces '%current-system' and | |
ce45eb4c LC |
671 | ;; '%current-target-system' to be looked up at >>= |
672 | ;; time. | |
673 | (graft? (set-grafting graft?)) | |
68a61e9f | 674 | |
5d098459 | 675 | (system -> (or system (%current-system))) |
68a61e9f LC |
676 | (target -> (if (eq? target 'current) |
677 | (%current-target-system) | |
678 | target)) | |
667b2508 | 679 | (normals (lower-inputs (gexp-inputs exp) |
68a61e9f LC |
680 | #:system system |
681 | #:target target)) | |
667b2508 LC |
682 | (natives (lower-inputs (gexp-native-inputs exp) |
683 | #:system system | |
684 | #:target #f)) | |
685 | (inputs -> (append normals natives)) | |
68a61e9f LC |
686 | (sexp (gexp->sexp exp |
687 | #:system system | |
688 | #:target target)) | |
0309e1b0 | 689 | (builder (text-file script-name |
21b679f6 | 690 | (object->string sexp))) |
838e17d8 LC |
691 | (extensions -> (gexp-extensions exp)) |
692 | (exts (mapm %store-monad | |
693 | (lambda (obj) | |
694 | (lower-object obj system)) | |
695 | extensions)) | |
21b679f6 LC |
696 | (modules (if (pair? %modules) |
697 | (imported-modules %modules | |
698 | #:system system | |
4684f301 | 699 | #:module-path module-path |
30d722c3 LC |
700 | #:guile guile-for-build |
701 | #:deprecation-warnings | |
702 | deprecation-warnings) | |
21b679f6 LC |
703 | (return #f))) |
704 | (compiled (if (pair? %modules) | |
705 | (compiled-modules %modules | |
706 | #:system system | |
4684f301 | 707 | #:module-path module-path |
838e17d8 | 708 | #:extensions extensions |
a912c723 LC |
709 | #:guile guile-for-build |
710 | #:deprecation-warnings | |
711 | deprecation-warnings) | |
21b679f6 | 712 | (return #f))) |
b53833b2 LC |
713 | (graphs (if references-graphs |
714 | (lower-reference-graphs references-graphs | |
715 | #:system system | |
716 | #:target target) | |
717 | (return #f))) | |
c8351d9a LC |
718 | (allowed (if allowed-references |
719 | (lower-references allowed-references | |
720 | #:system system | |
721 | #:target target) | |
722 | (return #f))) | |
3f4ecf32 LC |
723 | (disallowed (if disallowed-references |
724 | (lower-references disallowed-references | |
725 | #:system system | |
726 | #:target target) | |
727 | (return #f))) | |
21b679f6 LC |
728 | (guile (if guile-for-build |
729 | (return guile-for-build) | |
ff40e9b7 | 730 | (default-guile-derivation system)))) |
ce45eb4c LC |
731 | (mbegin %store-monad |
732 | (set-grafting graft?) ;restore the initial setting | |
733 | (raw-derivation name | |
734 | (string-append (derivation->output-path guile) | |
735 | "/bin/guile") | |
736 | `("--no-auto-compile" | |
737 | ,@(if (pair? %modules) | |
738 | `("-L" ,(derivation->output-path modules) | |
739 | "-C" ,(derivation->output-path compiled)) | |
740 | '()) | |
838e17d8 | 741 | ,@(append-map extension-flags exts) |
ce45eb4c LC |
742 | ,builder) |
743 | #:outputs outputs | |
744 | #:env-vars env-vars | |
745 | #:system system | |
746 | #:inputs `((,guile) | |
747 | (,builder) | |
748 | ,@(if modules | |
749 | `((,modules) (,compiled) ,@inputs) | |
750 | inputs) | |
838e17d8 | 751 | ,@(map list exts) |
ce45eb4c LC |
752 | ,@(match graphs |
753 | (((_ . inputs) ...) inputs) | |
754 | (_ '()))) | |
755 | #:hash hash #:hash-algo hash-algo #:recursive? recursive? | |
756 | #:references-graphs (and=> graphs graphs-file-names) | |
757 | #:allowed-references allowed | |
3f4ecf32 | 758 | #:disallowed-references disallowed |
c0468155 | 759 | #:leaked-env-vars leaked-env-vars |
4a6aeb67 LC |
760 | #:local-build? local-build? |
761 | #:substitutable? substitutable?)))) | |
21b679f6 | 762 | |
1123759b LC |
763 | (define* (gexp-inputs exp #:key native?) |
764 | "Return the input list for EXP. When NATIVE? is true, return only native | |
765 | references; otherwise, return only non-native references." | |
21b679f6 LC |
766 | (define (add-reference-inputs ref result) |
767 | (match ref | |
1123759b LC |
768 | (($ <gexp-input> (? gexp? exp) _ #t) |
769 | (if native? | |
770 | (append (gexp-inputs exp) | |
771 | (gexp-inputs exp #:native? #t) | |
772 | result) | |
773 | result)) | |
774 | (($ <gexp-input> (? gexp? exp) _ #f) | |
d343a60f LC |
775 | (append (gexp-inputs exp #:native? native?) |
776 | result)) | |
e39d1461 LC |
777 | (($ <gexp-input> (? string? str)) |
778 | (if (direct-store-path? str) | |
779 | (cons `(,str) result) | |
21b679f6 | 780 | result)) |
5b14a790 LC |
781 | (($ <gexp-input> (? struct? thing) output n?) |
782 | (if (and (eqv? n? native?) (lookup-compiler thing)) | |
bcb13287 LC |
783 | ;; THING is a derivation, or a package, or an origin, etc. |
784 | (cons `(,thing ,output) result) | |
785 | result)) | |
1123759b | 786 | (($ <gexp-input> (lst ...) output n?) |
578dfbe0 LC |
787 | (fold-right add-reference-inputs result |
788 | ;; XXX: For now, automatically convert LST to a list of | |
789 | ;; gexp-inputs. Inherit N?. | |
790 | (map (match-lambda | |
791 | ((? gexp-input? x) | |
792 | (%gexp-input (gexp-input-thing x) | |
793 | (gexp-input-output x) | |
794 | n?)) | |
795 | (x | |
796 | (%gexp-input x "out" n?))) | |
797 | lst))) | |
21b679f6 LC |
798 | (_ |
799 | ;; Ignore references to other kinds of objects. | |
800 | result))) | |
801 | ||
802 | (fold-right add-reference-inputs | |
803 | '() | |
5b14a790 | 804 | (gexp-references exp))) |
667b2508 LC |
805 | |
806 | (define gexp-native-inputs | |
1123759b | 807 | (cut gexp-inputs <> #:native? #t)) |
21b679f6 LC |
808 | |
809 | (define (gexp-outputs exp) | |
810 | "Return the outputs referred to by EXP as a list of strings." | |
811 | (define (add-reference-output ref result) | |
812 | (match ref | |
1e87da58 | 813 | (($ <gexp-output> name) |
21b679f6 | 814 | (cons name result)) |
e39d1461 | 815 | (($ <gexp-input> (? gexp? exp)) |
21b679f6 | 816 | (append (gexp-outputs exp) result)) |
e39d1461 LC |
817 | (($ <gexp-input> (lst ...) output native?) |
818 | ;; XXX: Automatically convert LST. | |
0dbea56b LC |
819 | (add-reference-output (map (match-lambda |
820 | ((? gexp-input? x) x) | |
821 | (x (%gexp-input x "out" native?))) | |
822 | lst) | |
e39d1461 | 823 | result)) |
f9efe568 LC |
824 | ((lst ...) |
825 | (fold-right add-reference-output result lst)) | |
21b679f6 LC |
826 | (_ |
827 | result))) | |
828 | ||
7e75a673 LC |
829 | (delete-duplicates |
830 | (add-reference-output (gexp-references exp) '()))) | |
21b679f6 | 831 | |
68a61e9f LC |
832 | (define* (gexp->sexp exp #:key |
833 | (system (%current-system)) | |
834 | (target (%current-target-system))) | |
21b679f6 LC |
835 | "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, |
836 | and in the current monad setting (system type, etc.)" | |
667b2508 | 837 | (define* (reference->sexp ref #:optional native?) |
21b679f6 LC |
838 | (with-monad %store-monad |
839 | (match ref | |
1e87da58 | 840 | (($ <gexp-output> output) |
bfd9eed9 LC |
841 | ;; Output file names are not known in advance but the daemon defines |
842 | ;; an environment variable for each of them at build time, so use | |
843 | ;; that trick. | |
844 | (return `((@ (guile) getenv) ,output))) | |
e39d1461 | 845 | (($ <gexp-input> (? gexp? exp) output n?) |
667b2508 LC |
846 | (gexp->sexp exp |
847 | #:system system | |
e39d1461 LC |
848 | #:target (if (or n? native?) #f target))) |
849 | (($ <gexp-input> (refs ...) output n?) | |
667b2508 | 850 | (sequence %store-monad |
e39d1461 LC |
851 | (map (lambda (ref) |
852 | ;; XXX: Automatically convert REF to an gexp-input. | |
0dbea56b LC |
853 | (reference->sexp |
854 | (if (gexp-input? ref) | |
855 | ref | |
856 | (%gexp-input ref "out" n?)) | |
affd7761 | 857 | (or n? native?))) |
e39d1461 | 858 | refs))) |
bcb13287 | 859 | (($ <gexp-input> (? struct? thing) output n?) |
ebdfd776 LC |
860 | (let ((target (if (or n? native?) #f target)) |
861 | (expand (lookup-expander thing))) | |
c2b84676 LC |
862 | (mlet %store-monad ((obj (lower-object thing system |
863 | #:target target))) | |
d9ae938f | 864 | ;; OBJ must be either a derivation or a store file name. |
ebdfd776 | 865 | (return (expand thing obj output))))) |
e39d1461 LC |
866 | (($ <gexp-input> x) |
867 | (return x)) | |
21b679f6 LC |
868 | (x |
869 | (return x))))) | |
870 | ||
871 | (mlet %store-monad | |
872 | ((args (sequence %store-monad | |
affd7761 | 873 | (map reference->sexp (gexp-references exp))))) |
21b679f6 LC |
874 | (return (apply (gexp-proc exp) args)))) |
875 | ||
21b679f6 LC |
876 | (define (syntax-location-string s) |
877 | "Return a string representing the source code location of S." | |
878 | (let ((props (syntax-source s))) | |
879 | (if props | |
880 | (let ((file (assoc-ref props 'filename)) | |
881 | (line (and=> (assoc-ref props 'line) 1+)) | |
882 | (column (assoc-ref props 'column))) | |
883 | (if file | |
884 | (simple-format #f "~a:~a:~a" | |
885 | file line column) | |
886 | (simple-format #f "~a:~a" line column))) | |
887 | "<unknown location>"))) | |
888 | ||
0bb9929e LC |
889 | (define-syntax-parameter current-imported-modules |
890 | ;; Current list of imported modules. | |
891 | (identifier-syntax '())) | |
892 | ||
893 | (define-syntax-rule (with-imported-modules modules body ...) | |
894 | "Mark the gexps defined in BODY... as requiring MODULES in their execution | |
895 | environment." | |
896 | (syntax-parameterize ((current-imported-modules | |
897 | (identifier-syntax modules))) | |
898 | body ...)) | |
899 | ||
838e17d8 LC |
900 | (define-syntax-parameter current-imported-extensions |
901 | ;; Current list of extensions. | |
902 | (identifier-syntax '())) | |
903 | ||
904 | (define-syntax-rule (with-extensions extensions body ...) | |
905 | "Mark the gexps defined in BODY... as requiring EXTENSIONS in their | |
906 | execution environment." | |
907 | (syntax-parameterize ((current-imported-extensions | |
908 | (identifier-syntax extensions))) | |
909 | body ...)) | |
910 | ||
21b679f6 LC |
911 | (define-syntax gexp |
912 | (lambda (s) | |
913 | (define (collect-escapes exp) | |
914 | ;; Return all the 'ungexp' present in EXP. | |
915 | (let loop ((exp exp) | |
916 | (result '())) | |
607e1b51 LC |
917 | (syntax-case exp (ungexp |
918 | ungexp-splicing | |
919 | ungexp-native | |
920 | ungexp-native-splicing) | |
21b679f6 LC |
921 | ((ungexp _) |
922 | (cons exp result)) | |
923 | ((ungexp _ _) | |
924 | (cons exp result)) | |
925 | ((ungexp-splicing _ ...) | |
926 | (cons exp result)) | |
607e1b51 | 927 | ((ungexp-native _ ...) |
667b2508 LC |
928 | (cons exp result)) |
929 | ((ungexp-native-splicing _ ...) | |
930 | (cons exp result)) | |
5e2e4a51 | 931 | ((exp0 . exp) |
667b2508 | 932 | (let ((result (loop #'exp0 result))) |
5e2e4a51 | 933 | (loop #'exp result))) |
667b2508 LC |
934 | (_ |
935 | result)))) | |
936 | ||
21b679f6 LC |
937 | (define (escape->ref exp) |
938 | ;; Turn 'ungexp' form EXP into a "reference". | |
667b2508 LC |
939 | (syntax-case exp (ungexp ungexp-splicing |
940 | ungexp-native ungexp-native-splicing | |
941 | output) | |
21b679f6 | 942 | ((ungexp output) |
1e87da58 | 943 | #'(gexp-output "out")) |
21b679f6 | 944 | ((ungexp output name) |
1e87da58 | 945 | #'(gexp-output name)) |
21b679f6 | 946 | ((ungexp thing) |
0dbea56b | 947 | #'(%gexp-input thing "out" #f)) |
21b679f6 | 948 | ((ungexp drv-or-pkg out) |
0dbea56b | 949 | #'(%gexp-input drv-or-pkg out #f)) |
21b679f6 | 950 | ((ungexp-splicing lst) |
0dbea56b | 951 | #'(%gexp-input lst "out" #f)) |
667b2508 | 952 | ((ungexp-native thing) |
0dbea56b | 953 | #'(%gexp-input thing "out" #t)) |
667b2508 | 954 | ((ungexp-native drv-or-pkg out) |
0dbea56b | 955 | #'(%gexp-input drv-or-pkg out #t)) |
667b2508 | 956 | ((ungexp-native-splicing lst) |
0dbea56b | 957 | #'(%gexp-input lst "out" #t)))) |
21b679f6 | 958 | |
667b2508 LC |
959 | (define (substitute-ungexp exp substs) |
960 | ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with | |
961 | ;; the corresponding form in SUBSTS. | |
962 | (match (assoc exp substs) | |
963 | ((_ id) | |
964 | id) | |
4a6e889f LC |
965 | (_ ;internal error |
966 | (with-syntax ((exp exp)) | |
967 | #'(syntax-error "error: no 'ungexp' substitution" exp))))) | |
667b2508 LC |
968 | |
969 | (define (substitute-ungexp-splicing exp substs) | |
970 | (syntax-case exp () | |
971 | ((exp rest ...) | |
972 | (match (assoc #'exp substs) | |
973 | ((_ id) | |
974 | (with-syntax ((id id)) | |
975 | #`(append id | |
976 | #,(substitute-references #'(rest ...) substs)))) | |
977 | (_ | |
978 | #'(syntax-error "error: no 'ungexp-splicing' substitution" | |
4a6e889f | 979 | exp)))))) |
667b2508 | 980 | |
21b679f6 LC |
981 | (define (substitute-references exp substs) |
982 | ;; Return a variant of EXP where all the cars of SUBSTS have been | |
983 | ;; replaced by the corresponding cdr. | |
667b2508 LC |
984 | (syntax-case exp (ungexp ungexp-native |
985 | ungexp-splicing ungexp-native-splicing) | |
21b679f6 | 986 | ((ungexp _ ...) |
667b2508 LC |
987 | (substitute-ungexp exp substs)) |
988 | ((ungexp-native _ ...) | |
989 | (substitute-ungexp exp substs)) | |
21b679f6 | 990 | (((ungexp-splicing _ ...) rest ...) |
667b2508 LC |
991 | (substitute-ungexp-splicing exp substs)) |
992 | (((ungexp-native-splicing _ ...) rest ...) | |
993 | (substitute-ungexp-splicing exp substs)) | |
5e2e4a51 | 994 | ((exp0 . exp) |
21b679f6 | 995 | #`(cons #,(substitute-references #'exp0 substs) |
5e2e4a51 | 996 | #,(substitute-references #'exp substs))) |
21b679f6 LC |
997 | (x #''x))) |
998 | ||
999 | (syntax-case s (ungexp output) | |
1000 | ((_ exp) | |
affd7761 | 1001 | (let* ((escapes (delete-duplicates (collect-escapes #'exp))) |
21b679f6 LC |
1002 | (formals (generate-temporaries escapes)) |
1003 | (sexp (substitute-references #'exp (zip escapes formals))) | |
affd7761 LC |
1004 | (refs (map escape->ref escapes))) |
1005 | #`(make-gexp (list #,@refs) | |
0bb9929e | 1006 | current-imported-modules |
838e17d8 | 1007 | current-imported-extensions |
21b679f6 LC |
1008 | (lambda #,formals |
1009 | #,sexp))))))) | |
1010 | ||
1011 | \f | |
aa72d9af LC |
1012 | ;;; |
1013 | ;;; Module handling. | |
1014 | ;;; | |
1015 | ||
df2d51f0 LC |
1016 | (define %utils-module |
1017 | ;; This file provides 'mkdir-p', needed to implement 'imported-files' and | |
a9601e23 LC |
1018 | ;; other primitives below. Note: We give the file name relative to this |
1019 | ;; file you are currently reading; 'search-path' could return a file name | |
1020 | ;; relative to the current working directory. | |
1021 | (local-file "build/utils.scm" | |
df2d51f0 | 1022 | "build-utils.scm")) |
aa72d9af LC |
1023 | |
1024 | (define* (imported-files files | |
1025 | #:key (name "file-import") | |
1026 | (system (%current-system)) | |
30d722c3 LC |
1027 | (guile (%guile-for-build)) |
1028 | ||
1029 | ;; XXX: The only reason we have | |
1030 | ;; #:deprecation-warnings is because (guix build | |
1031 | ;; utils), which we use here, relies on _IO*, which | |
1032 | ;; is deprecated in 2.2. On the next full-rebuild | |
1033 | ;; cycle, we should disable such warnings | |
1034 | ;; unconditionally. | |
1035 | (deprecation-warnings #f)) | |
aa72d9af | 1036 | "Return a derivation that imports FILES into STORE. FILES must be a list |
d938a58b LC |
1037 | of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the |
1038 | resulting store path. FILE can be either a file name, or a file-like object, | |
1039 | as returned by 'local-file' for example." | |
aa72d9af LC |
1040 | (define file-pair |
1041 | (match-lambda | |
d938a58b | 1042 | ((final-path . (? string? file-name)) |
aa72d9af LC |
1043 | (mlet %store-monad ((file (interned-file file-name |
1044 | (basename final-path)))) | |
d938a58b LC |
1045 | (return (list final-path file)))) |
1046 | ((final-path . file-like) | |
1047 | (mlet %store-monad ((file (lower-object file-like system))) | |
aa72d9af LC |
1048 | (return (list final-path file)))))) |
1049 | ||
1050 | (mlet %store-monad ((files (sequence %store-monad | |
1051 | (map file-pair files)))) | |
1052 | (define build | |
1053 | (gexp | |
1054 | (begin | |
df2d51f0 | 1055 | (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' |
aa72d9af LC |
1056 | (use-modules (ice-9 match)) |
1057 | ||
aa72d9af LC |
1058 | (mkdir (ungexp output)) (chdir (ungexp output)) |
1059 | (for-each (match-lambda | |
1060 | ((final-path store-path) | |
1061 | (mkdir-p (dirname final-path)) | |
1062 | (symlink store-path final-path))) | |
1063 | '(ungexp files))))) | |
1064 | ||
1065 | ;; TODO: Pass FILES as an environment variable so that BUILD remains | |
1066 | ;; exactly the same regardless of FILES: less disk space, and fewer | |
1067 | ;; 'add-to-store' RPCs. | |
1068 | (gexp->derivation name build | |
1069 | #:system system | |
1070 | #:guile-for-build guile | |
30d722c3 LC |
1071 | #:local-build? #t |
1072 | ||
1073 | ;; TODO: On the next rebuild cycle, set to "no" | |
1074 | ;; unconditionally. | |
1075 | #:env-vars | |
1076 | (case deprecation-warnings | |
1077 | ((#f) | |
1078 | '(("GUILE_WARN_DEPRECATED" . "no"))) | |
1079 | ((detailed) | |
1080 | '(("GUILE_WARN_DEPRECATED" . "detailed"))) | |
1081 | (else | |
1082 | '()))))) | |
aa72d9af | 1083 | |
aa72d9af LC |
1084 | (define* (imported-modules modules |
1085 | #:key (name "module-import") | |
1086 | (system (%current-system)) | |
1087 | (guile (%guile-for-build)) | |
30d722c3 LC |
1088 | (module-path %load-path) |
1089 | (deprecation-warnings #f)) | |
aa72d9af | 1090 | "Return a derivation that contains the source files of MODULES, a list of |
d938a58b LC |
1091 | module names such as `(ice-9 q)'. All of MODULES must be either names of |
1092 | modules to be found in the MODULE-PATH search path, or a module name followed | |
1093 | by an arrow followed by a file-like object. For example: | |
1094 | ||
1095 | (imported-modules `((guix build utils) | |
1096 | (guix gcrypt) | |
1097 | ((guix config) => ,(scheme-file …)))) | |
1098 | ||
1099 | In this example, the first two modules are taken from MODULE-PATH, and the | |
1100 | last one is created from the given <scheme-file> object." | |
4d20d87b LC |
1101 | (let ((files (map (match-lambda |
1102 | (((module ...) '=> file) | |
1103 | (cons (module->source-file-name module) | |
1104 | file)) | |
1105 | ((module ...) | |
1106 | (let ((f (module->source-file-name module))) | |
1107 | (cons f (search-path* module-path f))))) | |
1108 | modules))) | |
aa72d9af | 1109 | (imported-files files #:name name #:system system |
30d722c3 LC |
1110 | #:guile guile |
1111 | #:deprecation-warnings deprecation-warnings))) | |
aa72d9af LC |
1112 | |
1113 | (define* (compiled-modules modules | |
1114 | #:key (name "module-import-compiled") | |
1115 | (system (%current-system)) | |
1116 | (guile (%guile-for-build)) | |
a912c723 | 1117 | (module-path %load-path) |
838e17d8 | 1118 | (extensions '()) |
a912c723 | 1119 | (deprecation-warnings #f)) |
aa72d9af LC |
1120 | "Return a derivation that builds a tree containing the `.go' files |
1121 | corresponding to MODULES. All the MODULES are built in a context where | |
1122 | they can refer to each other." | |
d3292275 LC |
1123 | (define total (length modules)) |
1124 | ||
5d669883 LC |
1125 | (define build-utils-hack? |
1126 | ;; To avoid a full rebuild, we limit the fix below to the case where | |
1127 | ;; MODULE-PATH is different from %LOAD-PATH. This happens when building | |
1128 | ;; modules for 'compute-guix-derivation' upon 'guix pull'. TODO: Make | |
1129 | ;; this unconditional on the next rebuild cycle. | |
1130 | (and (member '(guix build utils) modules) | |
1131 | (not (equal? module-path %load-path)))) | |
1132 | ||
aa72d9af LC |
1133 | (mlet %store-monad ((modules (imported-modules modules |
1134 | #:system system | |
1135 | #:guile guile | |
1136 | #:module-path | |
30d722c3 LC |
1137 | module-path |
1138 | #:deprecation-warnings | |
1139 | deprecation-warnings))) | |
aa72d9af LC |
1140 | (define build |
1141 | (gexp | |
1142 | (begin | |
df2d51f0 LC |
1143 | (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' |
1144 | ||
aa72d9af | 1145 | (use-modules (ice-9 ftw) |
d3292275 LC |
1146 | (ice-9 format) |
1147 | (srfi srfi-1) | |
aa72d9af LC |
1148 | (srfi srfi-26) |
1149 | (system base compile)) | |
1150 | ||
aa72d9af LC |
1151 | (define (regular? file) |
1152 | (not (member file '("." "..")))) | |
1153 | ||
d3292275 | 1154 | (define (process-entry entry output processed) |
e640c9e6 LC |
1155 | (if (file-is-directory? entry) |
1156 | (let ((output (string-append output "/" (basename entry)))) | |
1157 | (mkdir-p output) | |
d3292275 | 1158 | (process-directory entry output processed)) |
e640c9e6 LC |
1159 | (let* ((base (basename entry ".scm")) |
1160 | (output (string-append output "/" base ".go"))) | |
d3292275 LC |
1161 | (format #t "[~2@a/~2@a] Compiling '~a'...~%" |
1162 | (+ 1 processed) (ungexp total) entry) | |
e640c9e6 LC |
1163 | (compile-file entry |
1164 | #:output-file output | |
d3292275 LC |
1165 | #:opts %auto-compilation-options) |
1166 | (+ 1 processed)))) | |
e640c9e6 | 1167 | |
d3292275 | 1168 | (define (process-directory directory output processed) |
aa72d9af LC |
1169 | (let ((entries (map (cut string-append directory "/" <>) |
1170 | (scandir directory regular?)))) | |
d3292275 LC |
1171 | (fold (cut process-entry <> output <>) |
1172 | processed | |
1173 | entries))) | |
1174 | ||
1175 | (setvbuf (current-output-port) | |
1176 | (cond-expand (guile-2.2 'line) (else _IOLBF))) | |
aa72d9af | 1177 | |
5d669883 LC |
1178 | (ungexp-splicing |
1179 | (if build-utils-hack? | |
1180 | (gexp ((define mkdir-p | |
1181 | ;; Capture 'mkdir-p'. | |
1182 | (@ (guix build utils) mkdir-p)))) | |
1183 | '())) | |
1184 | ||
838e17d8 LC |
1185 | ;; Add EXTENSIONS to the search path. |
1186 | ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle. | |
1187 | (ungexp-splicing | |
1188 | (if (null? extensions) | |
1189 | '() | |
1190 | (gexp ((set! %load-path | |
1191 | (append (map (lambda (extension) | |
1192 | (string-append extension | |
1193 | "/share/guile/site/" | |
1194 | (effective-version))) | |
1195 | '((ungexp-native-splicing extensions))) | |
1196 | %load-path)) | |
1197 | (set! %load-compiled-path | |
1198 | (append (map (lambda (extension) | |
1199 | (string-append extension "/lib/guile/" | |
1200 | (effective-version) | |
1201 | "/site-ccache")) | |
1202 | '((ungexp-native-splicing extensions))) | |
1203 | %load-compiled-path)))))) | |
1204 | ||
aa72d9af | 1205 | (set! %load-path (cons (ungexp modules) %load-path)) |
5d669883 LC |
1206 | |
1207 | (ungexp-splicing | |
1208 | (if build-utils-hack? | |
1209 | ;; Above we loaded our own (guix build utils) but now we may | |
1210 | ;; need to load a compile a different one. Thus, force a | |
1211 | ;; reload. | |
1212 | (gexp ((let ((utils (ungexp | |
1213 | (file-append modules | |
1214 | "/guix/build/utils.scm")))) | |
1215 | (when (file-exists? utils) | |
1216 | (load utils))))) | |
1217 | '())) | |
1218 | ||
aa72d9af LC |
1219 | (mkdir (ungexp output)) |
1220 | (chdir (ungexp modules)) | |
d3292275 | 1221 | (process-directory "." (ungexp output) 0)))) |
aa72d9af LC |
1222 | |
1223 | ;; TODO: Pass MODULES as an environment variable. | |
1224 | (gexp->derivation name build | |
1225 | #:system system | |
1226 | #:guile-for-build guile | |
a912c723 LC |
1227 | #:local-build? #t |
1228 | #:env-vars | |
1229 | (case deprecation-warnings | |
1230 | ((#f) | |
1231 | '(("GUILE_WARN_DEPRECATED" . "no"))) | |
1232 | ((detailed) | |
1233 | '(("GUILE_WARN_DEPRECATED" . "detailed"))) | |
1234 | (else | |
1235 | '()))))) | |
aa72d9af LC |
1236 | |
1237 | \f | |
21b679f6 LC |
1238 | ;;; |
1239 | ;;; Convenience procedures. | |
1240 | ;;; | |
1241 | ||
53e89b17 | 1242 | (define (default-guile) |
6ee797f3 LC |
1243 | ;; Lazily resolve 'guile-2.2' (not 'guile-final' because this is for |
1244 | ;; programs returned by 'program-file' and we don't want to keep references | |
1245 | ;; to several Guile packages). This module must not refer to (gnu …) | |
53e89b17 | 1246 | ;; modules directly, to avoid circular dependencies, hence this hack. |
6ee797f3 LC |
1247 | (module-ref (resolve-interface '(gnu packages guile)) |
1248 | 'guile-2.2)) | |
53e89b17 | 1249 | |
838e17d8 LC |
1250 | (define* (load-path-expression modules #:optional (path %load-path) |
1251 | #:key (extensions '())) | |
dd8d1a30 | 1252 | "Return as a monadic value a gexp that sets '%load-path' and |
1ae16033 LC |
1253 | '%load-compiled-path' to point to MODULES, a list of module names. MODULES |
1254 | are searched for in PATH." | |
1255 | (mlet %store-monad ((modules (imported-modules modules | |
1256 | #:module-path path)) | |
1257 | (compiled (compiled-modules modules | |
838e17d8 | 1258 | #:extensions extensions |
1ae16033 | 1259 | #:module-path path))) |
dd8d1a30 LC |
1260 | (return (gexp (eval-when (expand load eval) |
1261 | (set! %load-path | |
838e17d8 LC |
1262 | (cons (ungexp modules) |
1263 | (append (map (lambda (extension) | |
1264 | (string-append extension | |
1265 | "/share/guile/site/" | |
1266 | (effective-version))) | |
1267 | '((ungexp-native-splicing extensions))) | |
1268 | %load-path))) | |
dd8d1a30 LC |
1269 | (set! %load-compiled-path |
1270 | (cons (ungexp compiled) | |
838e17d8 LC |
1271 | (append (map (lambda (extension) |
1272 | (string-append extension | |
1273 | "/lib/guile/" | |
1274 | (effective-version) | |
1275 | "/site-ccache")) | |
1276 | '((ungexp-native-splicing extensions))) | |
1277 | %load-compiled-path)))))))) | |
dd8d1a30 | 1278 | |
21b679f6 | 1279 | (define* (gexp->script name exp |
1ae16033 LC |
1280 | #:key (guile (default-guile)) |
1281 | (module-path %load-path)) | |
9c14a487 | 1282 | "Return an executable script NAME that runs EXP using GUILE, with EXP's |
1ae16033 | 1283 | imported modules in its search path. Look up EXP's modules in MODULE-PATH." |
9c14a487 | 1284 | (mlet %store-monad ((set-load-path |
1ae16033 | 1285 | (load-path-expression (gexp-modules exp) |
838e17d8 LC |
1286 | module-path |
1287 | #:extensions | |
1288 | (gexp-extensions exp)))) | |
21b679f6 LC |
1289 | (gexp->derivation name |
1290 | (gexp | |
1291 | (call-with-output-file (ungexp output) | |
1292 | (lambda (port) | |
c17b5ab4 LC |
1293 | ;; Note: that makes a long shebang. When the store |
1294 | ;; is /gnu/store, that fits within the 128-byte | |
1295 | ;; limit imposed by Linux, but that may go beyond | |
1296 | ;; when running tests. | |
21b679f6 LC |
1297 | (format port |
1298 | "#!~a/bin/guile --no-auto-compile~%!#~%" | |
1299 | (ungexp guile)) | |
4a4cbd0b | 1300 | |
dd8d1a30 | 1301 | (write '(ungexp set-load-path) port) |
21b679f6 | 1302 | (write '(ungexp exp) port) |
1ae16033 LC |
1303 | (chmod port #o555)))) |
1304 | #:module-path module-path))) | |
21b679f6 | 1305 | |
1ae16033 LC |
1306 | (define* (gexp->file name exp #:key |
1307 | (set-load-path? #t) | |
4fbd1a2b LC |
1308 | (module-path %load-path) |
1309 | (splice? #f)) | |
1310 | "Return a derivation that builds a file NAME containing EXP. When SPLICE? | |
1311 | is true, EXP is considered to be a list of expressions that will be spliced in | |
1312 | the resulting file. | |
1313 | ||
1314 | When SET-LOAD-PATH? is true, emit code in the resulting file to set | |
1315 | '%load-path' and '%load-compiled-path' to honor EXP's imported modules. | |
1316 | Lookup EXP's modules in MODULE-PATH." | |
838e17d8 LC |
1317 | (define modules (gexp-modules exp)) |
1318 | (define extensions (gexp-extensions exp)) | |
1319 | ||
1320 | (if (or (not set-load-path?) | |
1321 | (and (null? modules) (null? extensions))) | |
1322 | (gexp->derivation name | |
1323 | (gexp | |
1324 | (call-with-output-file (ungexp output) | |
1325 | (lambda (port) | |
1326 | (for-each (lambda (exp) | |
1327 | (write exp port)) | |
1328 | '(ungexp (if splice? | |
1329 | exp | |
1330 | (gexp ((ungexp exp))))))))) | |
1331 | #:local-build? #t | |
1332 | #:substitutable? #f) | |
1333 | (mlet %store-monad ((set-load-path | |
1334 | (load-path-expression modules module-path | |
1335 | #:extensions extensions))) | |
1336 | (gexp->derivation name | |
1337 | (gexp | |
1338 | (call-with-output-file (ungexp output) | |
1339 | (lambda (port) | |
1340 | (write '(ungexp set-load-path) port) | |
1341 | (for-each (lambda (exp) | |
1342 | (write exp port)) | |
1343 | '(ungexp (if splice? | |
1344 | exp | |
1345 | (gexp ((ungexp exp))))))))) | |
1346 | #:module-path module-path | |
1347 | #:local-build? #t | |
1348 | #:substitutable? #f)))) | |
21b679f6 | 1349 | |
462a3fa3 LC |
1350 | (define* (text-file* name #:rest text) |
1351 | "Return as a monadic value a derivation that builds a text file containing | |
d9ae938f LC |
1352 | all of TEXT. TEXT may list, in addition to strings, objects of any type that |
1353 | can be used in a gexp: packages, derivations, local file objects, etc. The | |
1354 | resulting store file holds references to all these." | |
462a3fa3 LC |
1355 | (define builder |
1356 | (gexp (call-with-output-file (ungexp output "out") | |
1357 | (lambda (port) | |
1358 | (display (string-append (ungexp-splicing text)) port))))) | |
1359 | ||
851b6f62 LC |
1360 | (gexp->derivation name builder |
1361 | #:local-build? #t | |
1362 | #:substitutable? #f)) | |
462a3fa3 | 1363 | |
b751cde3 LC |
1364 | (define* (mixed-text-file name #:rest text) |
1365 | "Return an object representing store file NAME containing TEXT. TEXT is a | |
1366 | sequence of strings and file-like objects, as in: | |
1367 | ||
1368 | (mixed-text-file \"profile\" | |
1369 | \"export PATH=\" coreutils \"/bin:\" grep \"/bin\") | |
1370 | ||
1371 | This is the declarative counterpart of 'text-file*'." | |
1372 | (define build | |
1373 | (gexp (call-with-output-file (ungexp output "out") | |
1374 | (lambda (port) | |
1375 | (display (string-append (ungexp-splicing text)) port))))) | |
1376 | ||
1377 | (computed-file name build)) | |
1378 | ||
dedb512f LC |
1379 | (define (file-union name files) |
1380 | "Return a <computed-file> that builds a directory containing all of FILES. | |
1381 | Each item in FILES must be a two-element list where the first element is the | |
1382 | file name to use in the new directory, and the second element is a gexp | |
1383 | denoting the target file. Here's an example: | |
1384 | ||
1385 | (file-union \"etc\" | |
1386 | `((\"hosts\" ,(plain-file \"hosts\" | |
1387 | \"127.0.0.1 localhost\")) | |
1388 | (\"bashrc\" ,(plain-file \"bashrc\" | |
1389 | \"alias ls='ls --color'\")))) | |
1390 | ||
1391 | This yields an 'etc' directory containing these two files." | |
1392 | (computed-file name | |
1393 | (gexp | |
1394 | (begin | |
1395 | (mkdir (ungexp output)) | |
1396 | (chdir (ungexp output)) | |
1397 | (ungexp-splicing | |
1398 | (map (match-lambda | |
1399 | ((target source) | |
1400 | (gexp | |
1401 | (begin | |
1402 | ;; Stat the source to abort early if it does | |
1403 | ;; not exist. | |
1404 | (stat (ungexp source)) | |
1405 | ||
1406 | (symlink (ungexp source) | |
1407 | (ungexp target)))))) | |
1408 | files)))))) | |
1409 | ||
59523429 | 1410 | (define* (directory-union name things |
b244ae25 LC |
1411 | #:key (copy? #f) (quiet? #f) |
1412 | (resolve-collision 'warn-about-collision)) | |
d298c815 LC |
1413 | "Return a directory that is the union of THINGS, where THINGS is a list of |
1414 | file-like objects denoting directories. For example: | |
1415 | ||
1416 | (directory-union \"guile+emacs\" (list guile emacs)) | |
1417 | ||
59523429 LC |
1418 | yields a directory that is the union of the 'guile' and 'emacs' packages. |
1419 | ||
b244ae25 LC |
1420 | Call RESOLVE-COLLISION when several files collide, passing it the list of |
1421 | colliding files. RESOLVE-COLLISION must return the chosen file or #f, in | |
1422 | which case the colliding entry is skipped altogether. | |
1423 | ||
de98b302 LC |
1424 | When HARD-LINKS? is true, create hard links instead of symlinks. When QUIET? |
1425 | is true, the derivation will not print anything." | |
59523429 LC |
1426 | (define symlink |
1427 | (if copy? | |
1428 | (gexp (lambda (old new) | |
1429 | (if (file-is-directory? old) | |
1430 | (symlink old new) | |
1431 | (copy-file old new)))) | |
1432 | (gexp symlink))) | |
1433 | ||
de98b302 LC |
1434 | (define log-port |
1435 | (if quiet? | |
1436 | (gexp (%make-void-port "w")) | |
1437 | (gexp (current-error-port)))) | |
1438 | ||
d298c815 LC |
1439 | (match things |
1440 | ((one) | |
1441 | ;; Only one thing; return it. | |
1442 | one) | |
1443 | (_ | |
1444 | (computed-file name | |
1445 | (with-imported-modules '((guix build union)) | |
1446 | (gexp (begin | |
b244ae25 LC |
1447 | (use-modules (guix build union) |
1448 | (srfi srfi-1)) ;for 'first' and 'last' | |
1449 | ||
d298c815 | 1450 | (union-build (ungexp output) |
59523429 LC |
1451 | '(ungexp things) |
1452 | ||
de98b302 | 1453 | #:log-port (ungexp log-port) |
b244ae25 LC |
1454 | #:symlink (ungexp symlink) |
1455 | #:resolve-collision | |
1456 | (ungexp resolve-collision))))))))) | |
d298c815 | 1457 | |
21b679f6 LC |
1458 | \f |
1459 | ;;; | |
1460 | ;;; Syntactic sugar. | |
1461 | ;;; | |
1462 | ||
1463 | (eval-when (expand load eval) | |
667b2508 LC |
1464 | (define* (read-ungexp chr port #:optional native?) |
1465 | "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is | |
1466 | true, use 'ungexp-native' and 'ungexp-native-splicing' instead." | |
21b679f6 LC |
1467 | (define unquote-symbol |
1468 | (match (peek-char port) | |
1469 | (#\@ | |
1470 | (read-char port) | |
667b2508 LC |
1471 | (if native? |
1472 | 'ungexp-native-splicing | |
1473 | 'ungexp-splicing)) | |
21b679f6 | 1474 | (_ |
667b2508 LC |
1475 | (if native? |
1476 | 'ungexp-native | |
1477 | 'ungexp)))) | |
21b679f6 LC |
1478 | |
1479 | (match (read port) | |
1480 | ((? symbol? symbol) | |
1481 | (let ((str (symbol->string symbol))) | |
1482 | (match (string-index-right str #\:) | |
1483 | (#f | |
1484 | `(,unquote-symbol ,symbol)) | |
1485 | (colon | |
1486 | (let ((name (string->symbol (substring str 0 colon))) | |
1487 | (output (substring str (+ colon 1)))) | |
1488 | `(,unquote-symbol ,name ,output)))))) | |
1489 | (x | |
1490 | `(,unquote-symbol ,x)))) | |
1491 | ||
1492 | (define (read-gexp chr port) | |
1493 | "Read a 'gexp' form from PORT." | |
1494 | `(gexp ,(read port))) | |
1495 | ||
1496 | ;; Extend the reader | |
1497 | (read-hash-extend #\~ read-gexp) | |
667b2508 LC |
1498 | (read-hash-extend #\$ read-ungexp) |
1499 | (read-hash-extend #\+ (cut read-ungexp <> <> #t))) | |
21b679f6 LC |
1500 | |
1501 | ;;; gexp.scm ends here |