Commit | Line | Data |
---|---|---|
21b679f6 | 1 | ;;; GNU Guix --- Functional package management for GNU |
4a6e889f | 2 | ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
21b679f6 LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix gexp) | |
e87f0591 | 20 | #:use-module (guix store) |
21b679f6 | 21 | #:use-module (guix monads) |
e87f0591 | 22 | #:use-module (guix derivations) |
7adf9b84 | 23 | #:use-module (guix grafts) |
aa72d9af | 24 | #:use-module (guix utils) |
21b679f6 LC |
25 | #:use-module (srfi srfi-1) |
26 | #:use-module (srfi srfi-9) | |
7560b00b | 27 | #:use-module (srfi srfi-9 gnu) |
21b679f6 LC |
28 | #:use-module (srfi srfi-26) |
29 | #:use-module (ice-9 match) | |
30 | #:export (gexp | |
31 | gexp? | |
0bb9929e | 32 | with-imported-modules |
0dbea56b LC |
33 | |
34 | gexp-input | |
35 | gexp-input? | |
558e8b11 | 36 | |
d9ae938f LC |
37 | local-file |
38 | local-file? | |
74d441ab | 39 | local-file-file |
9d3994f7 | 40 | local-file-absolute-file-name |
74d441ab LC |
41 | local-file-name |
42 | local-file-recursive? | |
0dbea56b | 43 | |
558e8b11 LC |
44 | plain-file |
45 | plain-file? | |
46 | plain-file-name | |
47 | plain-file-content | |
48 | ||
91937029 LC |
49 | computed-file |
50 | computed-file? | |
51 | computed-file-name | |
52 | computed-file-gexp | |
91937029 LC |
53 | computed-file-options |
54 | ||
15a01c72 LC |
55 | program-file |
56 | program-file? | |
57 | program-file-name | |
58 | program-file-gexp | |
15a01c72 LC |
59 | program-file-guile |
60 | ||
e1c153e0 LC |
61 | scheme-file |
62 | scheme-file? | |
63 | scheme-file-name | |
64 | scheme-file-gexp | |
65 | ||
a9e5e92f LC |
66 | file-append |
67 | file-append? | |
68 | file-append-base | |
69 | file-append-suffix | |
70 | ||
64fc9f65 RJ |
71 | load-path-expression |
72 | gexp-modules | |
73 | ||
21b679f6 LC |
74 | gexp->derivation |
75 | gexp->file | |
462a3fa3 | 76 | gexp->script |
aa72d9af | 77 | text-file* |
b751cde3 | 78 | mixed-text-file |
aa72d9af LC |
79 | imported-files |
80 | imported-modules | |
ff40e9b7 LC |
81 | compiled-modules |
82 | ||
83 | define-gexp-compiler | |
6b6298ae | 84 | gexp-compiler? |
c2b84676 | 85 | lower-object |
6b6298ae LC |
86 | |
87 | lower-inputs)) | |
21b679f6 LC |
88 | |
89 | ;;; Commentary: | |
90 | ;;; | |
91 | ;;; This module implements "G-expressions", or "gexps". Gexps are like | |
92 | ;;; S-expressions (sexps), with two differences: | |
93 | ;;; | |
94 | ;;; 1. References (un-quotations) to derivations or packages in a gexp are | |
667b2508 LC |
95 | ;;; replaced by the corresponding output file name; in addition, the |
96 | ;;; 'ungexp-native' unquote-like form allows code to explicitly refer to | |
97 | ;;; the native code of a given package, in case of cross-compilation; | |
21b679f6 LC |
98 | ;;; |
99 | ;;; 2. Gexps embed information about the derivations they refer to. | |
100 | ;;; | |
101 | ;;; Gexps make it easy to write to files Scheme code that refers to store | |
102 | ;;; items, or to write Scheme code to build derivations. | |
103 | ;;; | |
104 | ;;; Code: | |
105 | ||
106 | ;; "G expressions". | |
107 | (define-record-type <gexp> | |
0bb9929e | 108 | (make-gexp references modules proc) |
21b679f6 | 109 | gexp? |
affd7761 | 110 | (references gexp-references) ;list of <gexp-input> |
0bb9929e | 111 | (modules gexp-self-modules) ;list of module names |
affd7761 | 112 | (proc gexp-proc)) ;procedure |
21b679f6 | 113 | |
7560b00b LC |
114 | (define (write-gexp gexp port) |
115 | "Write GEXP on PORT." | |
116 | (display "#<gexp " port) | |
2cf0ea0d LC |
117 | |
118 | ;; Try to write the underlying sexp. Now, this trick doesn't work when | |
119 | ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure | |
120 | ;; tries to use 'append' on that, which fails with wrong-type-arg. | |
121 | (false-if-exception | |
667b2508 | 122 | (write (apply (gexp-proc gexp) |
affd7761 | 123 | (gexp-references gexp)) |
667b2508 | 124 | port)) |
7560b00b LC |
125 | (format port " ~a>" |
126 | (number->string (object-address gexp) 16))) | |
127 | ||
128 | (set-record-type-printer! <gexp> write-gexp) | |
129 | ||
bcb13287 LC |
130 | \f |
131 | ;;; | |
132 | ;;; Methods. | |
133 | ;;; | |
134 | ||
135 | ;; Compiler for a type of objects that may be introduced in a gexp. | |
136 | (define-record-type <gexp-compiler> | |
1cdecf24 | 137 | (gexp-compiler type lower expand) |
bcb13287 | 138 | gexp-compiler? |
1cdecf24 | 139 | (type gexp-compiler-type) ;record type descriptor |
ebdfd776 | 140 | (lower gexp-compiler-lower) |
1cdecf24 | 141 | (expand gexp-compiler-expand)) ;#f | DRV -> sexp |
bcb13287 LC |
142 | |
143 | (define %gexp-compilers | |
1cdecf24 LC |
144 | ;; 'eq?' mapping of record type descriptor to <gexp-compiler>. |
145 | (make-hash-table 20)) | |
bcb13287 | 146 | |
ebdfd776 LC |
147 | (define (default-expander thing obj output) |
148 | "This is the default expander for \"things\" that appear in gexps. It | |
149 | returns its output file name of OBJ's OUTPUT." | |
150 | (match obj | |
151 | ((? derivation? drv) | |
152 | (derivation->output-path drv output)) | |
153 | ((? string? file) | |
154 | file))) | |
155 | ||
bcb13287 LC |
156 | (define (register-compiler! compiler) |
157 | "Register COMPILER as a gexp compiler." | |
1cdecf24 LC |
158 | (hashq-set! %gexp-compilers |
159 | (gexp-compiler-type compiler) compiler)) | |
bcb13287 LC |
160 | |
161 | (define (lookup-compiler object) | |
ebdfd776 | 162 | "Search for a compiler for OBJECT. Upon success, return the three argument |
bcb13287 | 163 | procedure to lower it; otherwise return #f." |
1cdecf24 LC |
164 | (and=> (hashq-ref %gexp-compilers (struct-vtable object)) |
165 | gexp-compiler-lower)) | |
bcb13287 | 166 | |
ebdfd776 LC |
167 | (define (lookup-expander object) |
168 | "Search for an expander for OBJECT. Upon success, return the three argument | |
169 | procedure to expand it; otherwise return #f." | |
1cdecf24 LC |
170 | (and=> (hashq-ref %gexp-compilers (struct-vtable object)) |
171 | gexp-compiler-expand)) | |
ebdfd776 | 172 | |
c2b84676 LC |
173 | (define* (lower-object obj |
174 | #:optional (system (%current-system)) | |
175 | #:key target) | |
176 | "Return as a value in %STORE-MONAD the derivation or store item | |
177 | corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. | |
178 | OBJ must be an object that has an associated gexp compiler, such as a | |
179 | <package>." | |
180 | (let ((lower (lookup-compiler obj))) | |
181 | (lower obj system target))) | |
182 | ||
ebdfd776 LC |
183 | (define-syntax define-gexp-compiler |
184 | (syntax-rules (=> compiler expander) | |
185 | "Define NAME as a compiler for objects matching PREDICATE encountered in | |
186 | gexps. | |
187 | ||
188 | In the simplest form of the macro, BODY must return a derivation for PARAM, an | |
189 | object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is | |
190 | #f except when cross-compiling.) | |
191 | ||
192 | The more elaborate form allows you to specify an expander: | |
193 | ||
194 | (define-gexp-compiler something something? | |
195 | compiler => (lambda (param system target) ...) | |
196 | expander => (lambda (param drv output) ...)) | |
197 | ||
198 | The expander specifies how an object is converted to its sexp representation." | |
1cdecf24 LC |
199 | ((_ (name (param record-type) system target) body ...) |
200 | (define-gexp-compiler name record-type | |
ebdfd776 LC |
201 | compiler => (lambda (param system target) body ...) |
202 | expander => default-expander)) | |
1cdecf24 | 203 | ((_ name record-type |
ebdfd776 LC |
204 | compiler => compile |
205 | expander => expand) | |
206 | (begin | |
207 | (define name | |
1cdecf24 | 208 | (gexp-compiler record-type compile expand)) |
ebdfd776 | 209 | (register-compiler! name))))) |
bcb13287 | 210 | |
1cdecf24 | 211 | (define-gexp-compiler (derivation-compiler (drv <derivation>) system target) |
2924f0d6 LC |
212 | ;; Derivations are the lowest-level representation, so this is the identity |
213 | ;; compiler. | |
214 | (with-monad %store-monad | |
215 | (return drv))) | |
216 | ||
bcb13287 | 217 | \f |
d9ae938f | 218 | ;;; |
558e8b11 | 219 | ;;; File declarations. |
d9ae938f LC |
220 | ;;; |
221 | ||
9d3994f7 LC |
222 | ;; A local file name. FILE is the file name the user entered, which can be a |
223 | ;; relative file name, and ABSOLUTE is a promise that computes its canonical | |
224 | ;; absolute file name. We keep it in a promise to compute it lazily and avoid | |
225 | ;; repeated 'stat' calls. | |
d9ae938f | 226 | (define-record-type <local-file> |
0687fc9c | 227 | (%%local-file file absolute name recursive? select?) |
d9ae938f LC |
228 | local-file? |
229 | (file local-file-file) ;string | |
9d3994f7 | 230 | (absolute %local-file-absolute-file-name) ;promise string |
d9ae938f | 231 | (name local-file-name) ;string |
0687fc9c LC |
232 | (recursive? local-file-recursive?) ;Boolean |
233 | (select? local-file-select?)) ;string stat -> Boolean | |
234 | ||
235 | (define (true file stat) #t) | |
d9ae938f | 236 | |
9d3994f7 | 237 | (define* (%local-file file promise #:optional (name (basename file)) |
0687fc9c | 238 | #:key recursive? (select? true)) |
9d3994f7 LC |
239 | ;; This intermediate procedure is part of our ABI, but the underlying |
240 | ;; %%LOCAL-FILE is not. | |
0687fc9c | 241 | (%%local-file file promise name recursive? select?)) |
9d3994f7 | 242 | |
9d3994f7 LC |
243 | (define (absolute-file-name file directory) |
244 | "Return the canonical absolute file name for FILE, which lives in the | |
245 | vicinity of DIRECTORY." | |
246 | (canonicalize-path | |
247 | (cond ((string-prefix? "/" file) file) | |
248 | ((not directory) file) | |
249 | ((string-prefix? "/" directory) | |
250 | (string-append directory "/" file)) | |
251 | (else file)))) | |
252 | ||
253 | (define-syntax-rule (local-file file rest ...) | |
d9ae938f | 254 | "Return an object representing local file FILE to add to the store; this |
9d3994f7 LC |
255 | object can be used in a gexp. If FILE is a relative file name, it is looked |
256 | up relative to the source file where this form appears. FILE will be added to | |
257 | the store under NAME--by default the base name of FILE. | |
d9ae938f LC |
258 | |
259 | When RECURSIVE? is true, the contents of FILE are added recursively; if FILE | |
260 | designates a flat file and RECURSIVE? is true, its contents are added, and its | |
261 | permission bits are kept. | |
262 | ||
0687fc9c LC |
263 | When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, |
264 | where FILE is the entry's absolute file name and STAT is the result of | |
265 | 'lstat'; exclude entries for which SELECT? does not return true. | |
266 | ||
d9ae938f | 267 | This is the declarative counterpart of the 'interned-file' monadic procedure." |
9d3994f7 LC |
268 | (%local-file file |
269 | (delay (absolute-file-name file (current-source-directory))) | |
270 | rest ...)) | |
271 | ||
272 | (define (local-file-absolute-file-name file) | |
273 | "Return the absolute file name for FILE, a <local-file> instance. A | |
274 | 'system-error' exception is raised if FILE could not be found." | |
275 | (force (%local-file-absolute-file-name file))) | |
d9ae938f | 276 | |
1cdecf24 | 277 | (define-gexp-compiler (local-file-compiler (file <local-file>) system target) |
d9ae938f LC |
278 | ;; "Compile" FILE by adding it to the store. |
279 | (match file | |
0687fc9c | 280 | (($ <local-file> file (= force absolute) name recursive? select?) |
9d3994f7 LC |
281 | ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing |
282 | ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling | |
283 | ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would | |
284 | ;; just throw an error, both of which are inconvenient. | |
0687fc9c LC |
285 | (interned-file absolute name |
286 | #:recursive? recursive? #:select? select?)))) | |
d9ae938f | 287 | |
558e8b11 LC |
288 | (define-record-type <plain-file> |
289 | (%plain-file name content references) | |
290 | plain-file? | |
291 | (name plain-file-name) ;string | |
292 | (content plain-file-content) ;string | |
293 | (references plain-file-references)) ;list (currently unused) | |
294 | ||
295 | (define (plain-file name content) | |
296 | "Return an object representing a text file called NAME with the given | |
297 | CONTENT (a string) to be added to the store. | |
298 | ||
299 | This is the declarative counterpart of 'text-file'." | |
300 | ;; XXX: For now just ignore 'references' because it's not clear how to use | |
301 | ;; them in a declarative context. | |
302 | (%plain-file name content '())) | |
303 | ||
1cdecf24 | 304 | (define-gexp-compiler (plain-file-compiler (file <plain-file>) system target) |
558e8b11 LC |
305 | ;; "Compile" FILE by adding it to the store. |
306 | (match file | |
307 | (($ <plain-file> name content references) | |
308 | (text-file name content references)))) | |
309 | ||
91937029 | 310 | (define-record-type <computed-file> |
a769bffb | 311 | (%computed-file name gexp options) |
91937029 LC |
312 | computed-file? |
313 | (name computed-file-name) ;string | |
314 | (gexp computed-file-gexp) ;gexp | |
91937029 LC |
315 | (options computed-file-options)) ;list of arguments |
316 | ||
317 | (define* (computed-file name gexp | |
a769bffb | 318 | #:key (options '(#:local-build? #t))) |
91937029 | 319 | "Return an object representing the store item NAME, a file or directory |
a769bffb | 320 | computed by GEXP. OPTIONS is a list of additional arguments to pass |
91937029 LC |
321 | to 'gexp->derivation'. |
322 | ||
323 | This is the declarative counterpart of 'gexp->derivation'." | |
a769bffb | 324 | (%computed-file name gexp options)) |
91937029 | 325 | |
1cdecf24 | 326 | (define-gexp-compiler (computed-file-compiler (file <computed-file>) |
91937029 LC |
327 | system target) |
328 | ;; Compile FILE by returning a derivation whose build expression is its | |
329 | ;; gexp. | |
330 | (match file | |
a769bffb LC |
331 | (($ <computed-file> name gexp options) |
332 | (apply gexp->derivation name gexp options)))) | |
91937029 | 333 | |
15a01c72 | 334 | (define-record-type <program-file> |
9c14a487 | 335 | (%program-file name gexp guile) |
15a01c72 LC |
336 | program-file? |
337 | (name program-file-name) ;string | |
338 | (gexp program-file-gexp) ;gexp | |
15a01c72 LC |
339 | (guile program-file-guile)) ;package |
340 | ||
9c14a487 | 341 | (define* (program-file name gexp #:key (guile #f)) |
15a01c72 | 342 | "Return an object representing the executable store item NAME that runs |
9c14a487 | 343 | GEXP. GUILE is the Guile package used to execute that script. |
15a01c72 LC |
344 | |
345 | This is the declarative counterpart of 'gexp->script'." | |
9c14a487 | 346 | (%program-file name gexp guile)) |
15a01c72 | 347 | |
1cdecf24 | 348 | (define-gexp-compiler (program-file-compiler (file <program-file>) |
15a01c72 LC |
349 | system target) |
350 | ;; Compile FILE by returning a derivation that builds the script. | |
351 | (match file | |
9c14a487 | 352 | (($ <program-file> name gexp guile) |
15a01c72 | 353 | (gexp->script name gexp |
15a01c72 LC |
354 | #:guile (or guile (default-guile)))))) |
355 | ||
e1c153e0 LC |
356 | (define-record-type <scheme-file> |
357 | (%scheme-file name gexp) | |
358 | scheme-file? | |
359 | (name scheme-file-name) ;string | |
360 | (gexp scheme-file-gexp)) ;gexp | |
361 | ||
362 | (define* (scheme-file name gexp) | |
363 | "Return an object representing the Scheme file NAME that contains GEXP. | |
364 | ||
365 | This is the declarative counterpart of 'gexp->file'." | |
366 | (%scheme-file name gexp)) | |
367 | ||
1cdecf24 | 368 | (define-gexp-compiler (scheme-file-compiler (file <scheme-file>) |
e1c153e0 LC |
369 | system target) |
370 | ;; Compile FILE by returning a derivation that builds the file. | |
371 | (match file | |
372 | (($ <scheme-file> name gexp) | |
373 | (gexp->file name gexp)))) | |
374 | ||
a9e5e92f LC |
375 | ;; Appending SUFFIX to BASE's output file name. |
376 | (define-record-type <file-append> | |
377 | (%file-append base suffix) | |
378 | file-append? | |
379 | (base file-append-base) ;<package> | <derivation> | ... | |
380 | (suffix file-append-suffix)) ;list of strings | |
381 | ||
382 | (define (file-append base . suffix) | |
383 | "Return a <file-append> object that expands to the concatenation of BASE and | |
384 | SUFFIX." | |
385 | (%file-append base suffix)) | |
386 | ||
1cdecf24 | 387 | (define-gexp-compiler file-append-compiler <file-append> |
a9e5e92f LC |
388 | compiler => (lambda (obj system target) |
389 | (match obj | |
390 | (($ <file-append> base _) | |
391 | (lower-object base system #:target target)))) | |
392 | expander => (lambda (obj lowered output) | |
393 | (match obj | |
394 | (($ <file-append> base suffix) | |
395 | (let* ((expand (lookup-expander base)) | |
396 | (base (expand base lowered output))) | |
397 | (string-append base (string-concatenate suffix))))))) | |
398 | ||
d9ae938f | 399 | \f |
bcb13287 LC |
400 | ;;; |
401 | ;;; Inputs & outputs. | |
402 | ;;; | |
403 | ||
e39d1461 LC |
404 | ;; The input of a gexp. |
405 | (define-record-type <gexp-input> | |
0dbea56b | 406 | (%gexp-input thing output native?) |
e39d1461 LC |
407 | gexp-input? |
408 | (thing gexp-input-thing) ;<package> | <origin> | <derivation> | ... | |
409 | (output gexp-input-output) ;string | |
410 | (native? gexp-input-native?)) ;Boolean | |
411 | ||
f7328634 LC |
412 | (define (write-gexp-input input port) |
413 | (match input | |
414 | (($ <gexp-input> thing output #f) | |
415 | (format port "#<gexp-input ~s:~a>" thing output)) | |
416 | (($ <gexp-input> thing output #t) | |
417 | (format port "#<gexp-input native ~s:~a>" thing output)))) | |
418 | ||
419 | (set-record-type-printer! <gexp-input> write-gexp-input) | |
420 | ||
0dbea56b LC |
421 | (define* (gexp-input thing ;convenience procedure |
422 | #:optional (output "out") | |
423 | #:key native?) | |
424 | "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines | |
425 | whether this should be considered a \"native\" input or not." | |
426 | (%gexp-input thing output native?)) | |
427 | ||
21b679f6 LC |
428 | ;; Reference to one of the derivation's outputs, for gexps used in |
429 | ;; derivations. | |
1e87da58 LC |
430 | (define-record-type <gexp-output> |
431 | (gexp-output name) | |
432 | gexp-output? | |
433 | (name gexp-output-name)) | |
21b679f6 | 434 | |
f7328634 LC |
435 | (define (write-gexp-output output port) |
436 | (match output | |
437 | (($ <gexp-output> name) | |
438 | (format port "#<gexp-output ~a>" name)))) | |
439 | ||
440 | (set-record-type-printer! <gexp-output> write-gexp-output) | |
441 | ||
0bb9929e LC |
442 | (define (gexp-modules gexp) |
443 | "Return the list of Guile module names GEXP relies on." | |
444 | (delete-duplicates | |
445 | (append (gexp-self-modules gexp) | |
446 | (append-map (match-lambda | |
447 | (($ <gexp-input> (? gexp? exp)) | |
448 | (gexp-modules exp)) | |
449 | (($ <gexp-input> (lst ...)) | |
450 | (append-map (lambda (item) | |
451 | (if (gexp? item) | |
452 | (gexp-modules item) | |
453 | '())) | |
454 | lst)) | |
455 | (_ | |
456 | '())) | |
457 | (gexp-references gexp))))) | |
458 | ||
68a61e9f LC |
459 | (define* (lower-inputs inputs |
460 | #:key system target) | |
461 | "Turn any package from INPUTS into a derivation for SYSTEM; return the | |
462 | corresponding input list as a monadic value. When TARGET is true, use it as | |
463 | the cross-compilation target triplet." | |
21b679f6 LC |
464 | (with-monad %store-monad |
465 | (sequence %store-monad | |
466 | (map (match-lambda | |
2242ff45 | 467 | (((? struct? thing) sub-drv ...) |
c2b84676 LC |
468 | (mlet %store-monad ((drv (lower-object |
469 | thing system #:target target))) | |
2242ff45 LC |
470 | (return `(,drv ,@sub-drv)))) |
471 | (input | |
472 | (return input))) | |
21b679f6 LC |
473 | inputs)))) |
474 | ||
b53833b2 LC |
475 | (define* (lower-reference-graphs graphs #:key system target) |
476 | "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a | |
477 | #:reference-graphs argument, lower it such that each INPUT is replaced by the | |
478 | corresponding derivation." | |
479 | (match graphs | |
480 | (((file-names . inputs) ...) | |
481 | (mlet %store-monad ((inputs (lower-inputs inputs | |
482 | #:system system | |
483 | #:target target))) | |
484 | (return (map cons file-names inputs)))))) | |
485 | ||
c8351d9a LC |
486 | (define* (lower-references lst #:key system target) |
487 | "Based on LST, a list of output names and packages, return a list of output | |
488 | names and file names suitable for the #:allowed-references argument to | |
489 | 'derivation'." | |
c8351d9a LC |
490 | (with-monad %store-monad |
491 | (define lower | |
492 | (match-lambda | |
493 | ((? string? output) | |
494 | (return output)) | |
accb682c | 495 | (($ <gexp-input> thing output native?) |
c2b84676 LC |
496 | (mlet %store-monad ((drv (lower-object thing system |
497 | #:target (if native? | |
498 | #f target)))) | |
accb682c | 499 | (return (derivation->output-path drv output)))) |
bcb13287 | 500 | (thing |
c2b84676 LC |
501 | (mlet %store-monad ((drv (lower-object thing system |
502 | #:target target))) | |
c8351d9a LC |
503 | (return (derivation->output-path drv)))))) |
504 | ||
505 | (sequence %store-monad (map lower lst)))) | |
506 | ||
ff40e9b7 LC |
507 | (define default-guile-derivation |
508 | ;; Here we break the abstraction by talking to the higher-level layer. | |
509 | ;; Thus, do the resolution lazily to hide the circular dependency. | |
510 | (let ((proc (delay | |
511 | (let ((iface (resolve-interface '(guix packages)))) | |
512 | (module-ref iface 'default-guile-derivation))))) | |
513 | (lambda (system) | |
514 | ((force proc) system)))) | |
515 | ||
21b679f6 LC |
516 | (define* (gexp->derivation name exp |
517 | #:key | |
68a61e9f | 518 | system (target 'current) |
21b679f6 LC |
519 | hash hash-algo recursive? |
520 | (env-vars '()) | |
521 | (modules '()) | |
4684f301 | 522 | (module-path %load-path) |
21b679f6 | 523 | (guile-for-build (%guile-for-build)) |
ce45eb4c | 524 | (graft? (%graft?)) |
21b679f6 | 525 | references-graphs |
3f4ecf32 | 526 | allowed-references disallowed-references |
c0468155 | 527 | leaked-env-vars |
0309e1b0 LC |
528 | local-build? (substitutable? #t) |
529 | (script-name (string-append name "-builder"))) | |
21b679f6 | 530 | "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a |
0309e1b0 LC |
531 | derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When |
532 | TARGET is true, it is used as the cross-compilation target triplet for | |
533 | packages referred to by EXP. | |
21b679f6 | 534 | |
0bb9929e LC |
535 | MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to |
536 | make MODULES available in the evaluation context of EXP; MODULES is a list of | |
4684f301 | 537 | names of Guile modules searched in MODULE-PATH to be copied in the store, |
21b679f6 LC |
538 | compiled, and made available in the load path during the execution of |
539 | EXP---e.g., '((guix build utils) (guix build gnu-build-system)). | |
540 | ||
ce45eb4c LC |
541 | GRAFT? determines whether packages referred to by EXP should be grafted when |
542 | applicable. | |
543 | ||
b53833b2 LC |
544 | When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the |
545 | following forms: | |
546 | ||
547 | (FILE-NAME PACKAGE) | |
548 | (FILE-NAME PACKAGE OUTPUT) | |
549 | (FILE-NAME DERIVATION) | |
550 | (FILE-NAME DERIVATION OUTPUT) | |
551 | (FILE-NAME STORE-ITEM) | |
552 | ||
553 | The right-hand-side of each element of REFERENCES-GRAPHS is automatically made | |
554 | an input of the build process of EXP. In the build environment, each | |
555 | FILE-NAME contains the reference graph of the corresponding item, in a simple | |
556 | text format. | |
557 | ||
c8351d9a LC |
558 | ALLOWED-REFERENCES must be either #f or a list of output names and packages. |
559 | In the latter case, the list denotes store items that the result is allowed to | |
560 | refer to. Any reference to another store item will lead to a build error. | |
3f4ecf32 LC |
561 | Similarly for DISALLOWED-REFERENCES, which can list items that must not be |
562 | referenced by the outputs. | |
b53833b2 | 563 | |
21b679f6 | 564 | The other arguments are as for 'derivation'." |
0bb9929e LC |
565 | (define %modules |
566 | (delete-duplicates | |
567 | (append modules (gexp-modules exp)))) | |
21b679f6 LC |
568 | (define outputs (gexp-outputs exp)) |
569 | ||
b53833b2 LC |
570 | (define (graphs-file-names graphs) |
571 | ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. | |
572 | (map (match-lambda | |
2924f0d6 | 573 | ;; TODO: Remove 'derivation?' special cases. |
b53833b2 LC |
574 | ((file-name (? derivation? drv)) |
575 | (cons file-name (derivation->output-path drv))) | |
576 | ((file-name (? derivation? drv) sub-drv) | |
577 | (cons file-name (derivation->output-path drv sub-drv))) | |
578 | ((file-name thing) | |
579 | (cons file-name thing))) | |
580 | graphs)) | |
581 | ||
ce45eb4c LC |
582 | (mlet* %store-monad (;; The following binding forces '%current-system' and |
583 | ;; '%current-target-system' to be looked up at >>= | |
584 | ;; time. | |
585 | (graft? (set-grafting graft?)) | |
68a61e9f | 586 | |
5d098459 | 587 | (system -> (or system (%current-system))) |
68a61e9f LC |
588 | (target -> (if (eq? target 'current) |
589 | (%current-target-system) | |
590 | target)) | |
667b2508 | 591 | (normals (lower-inputs (gexp-inputs exp) |
68a61e9f LC |
592 | #:system system |
593 | #:target target)) | |
667b2508 LC |
594 | (natives (lower-inputs (gexp-native-inputs exp) |
595 | #:system system | |
596 | #:target #f)) | |
597 | (inputs -> (append normals natives)) | |
68a61e9f LC |
598 | (sexp (gexp->sexp exp |
599 | #:system system | |
600 | #:target target)) | |
0309e1b0 | 601 | (builder (text-file script-name |
21b679f6 LC |
602 | (object->string sexp))) |
603 | (modules (if (pair? %modules) | |
604 | (imported-modules %modules | |
605 | #:system system | |
4684f301 | 606 | #:module-path module-path |
21b679f6 LC |
607 | #:guile guile-for-build) |
608 | (return #f))) | |
609 | (compiled (if (pair? %modules) | |
610 | (compiled-modules %modules | |
611 | #:system system | |
4684f301 | 612 | #:module-path module-path |
21b679f6 LC |
613 | #:guile guile-for-build) |
614 | (return #f))) | |
b53833b2 LC |
615 | (graphs (if references-graphs |
616 | (lower-reference-graphs references-graphs | |
617 | #:system system | |
618 | #:target target) | |
619 | (return #f))) | |
c8351d9a LC |
620 | (allowed (if allowed-references |
621 | (lower-references allowed-references | |
622 | #:system system | |
623 | #:target target) | |
624 | (return #f))) | |
3f4ecf32 LC |
625 | (disallowed (if disallowed-references |
626 | (lower-references disallowed-references | |
627 | #:system system | |
628 | #:target target) | |
629 | (return #f))) | |
21b679f6 LC |
630 | (guile (if guile-for-build |
631 | (return guile-for-build) | |
ff40e9b7 | 632 | (default-guile-derivation system)))) |
ce45eb4c LC |
633 | (mbegin %store-monad |
634 | (set-grafting graft?) ;restore the initial setting | |
635 | (raw-derivation name | |
636 | (string-append (derivation->output-path guile) | |
637 | "/bin/guile") | |
638 | `("--no-auto-compile" | |
639 | ,@(if (pair? %modules) | |
640 | `("-L" ,(derivation->output-path modules) | |
641 | "-C" ,(derivation->output-path compiled)) | |
642 | '()) | |
643 | ,builder) | |
644 | #:outputs outputs | |
645 | #:env-vars env-vars | |
646 | #:system system | |
647 | #:inputs `((,guile) | |
648 | (,builder) | |
649 | ,@(if modules | |
650 | `((,modules) (,compiled) ,@inputs) | |
651 | inputs) | |
652 | ,@(match graphs | |
653 | (((_ . inputs) ...) inputs) | |
654 | (_ '()))) | |
655 | #:hash hash #:hash-algo hash-algo #:recursive? recursive? | |
656 | #:references-graphs (and=> graphs graphs-file-names) | |
657 | #:allowed-references allowed | |
3f4ecf32 | 658 | #:disallowed-references disallowed |
c0468155 | 659 | #:leaked-env-vars leaked-env-vars |
4a6aeb67 LC |
660 | #:local-build? local-build? |
661 | #:substitutable? substitutable?)))) | |
21b679f6 | 662 | |
1123759b LC |
663 | (define* (gexp-inputs exp #:key native?) |
664 | "Return the input list for EXP. When NATIVE? is true, return only native | |
665 | references; otherwise, return only non-native references." | |
21b679f6 LC |
666 | (define (add-reference-inputs ref result) |
667 | (match ref | |
1123759b LC |
668 | (($ <gexp-input> (? gexp? exp) _ #t) |
669 | (if native? | |
670 | (append (gexp-inputs exp) | |
671 | (gexp-inputs exp #:native? #t) | |
672 | result) | |
673 | result)) | |
674 | (($ <gexp-input> (? gexp? exp) _ #f) | |
d343a60f LC |
675 | (append (gexp-inputs exp #:native? native?) |
676 | result)) | |
e39d1461 LC |
677 | (($ <gexp-input> (? string? str)) |
678 | (if (direct-store-path? str) | |
679 | (cons `(,str) result) | |
21b679f6 | 680 | result)) |
5b14a790 LC |
681 | (($ <gexp-input> (? struct? thing) output n?) |
682 | (if (and (eqv? n? native?) (lookup-compiler thing)) | |
bcb13287 LC |
683 | ;; THING is a derivation, or a package, or an origin, etc. |
684 | (cons `(,thing ,output) result) | |
685 | result)) | |
1123759b | 686 | (($ <gexp-input> (lst ...) output n?) |
5b14a790 LC |
687 | (if (eqv? native? n?) |
688 | (fold-right add-reference-inputs result | |
689 | ;; XXX: For now, automatically convert LST to a list of | |
690 | ;; gexp-inputs. | |
691 | (map (match-lambda | |
692 | ((? gexp-input? x) x) | |
693 | (x (%gexp-input x "out" (or n? native?)))) | |
694 | lst)) | |
695 | result)) | |
21b679f6 LC |
696 | (_ |
697 | ;; Ignore references to other kinds of objects. | |
698 | result))) | |
699 | ||
700 | (fold-right add-reference-inputs | |
701 | '() | |
5b14a790 | 702 | (gexp-references exp))) |
667b2508 LC |
703 | |
704 | (define gexp-native-inputs | |
1123759b | 705 | (cut gexp-inputs <> #:native? #t)) |
21b679f6 LC |
706 | |
707 | (define (gexp-outputs exp) | |
708 | "Return the outputs referred to by EXP as a list of strings." | |
709 | (define (add-reference-output ref result) | |
710 | (match ref | |
1e87da58 | 711 | (($ <gexp-output> name) |
21b679f6 | 712 | (cons name result)) |
e39d1461 | 713 | (($ <gexp-input> (? gexp? exp)) |
21b679f6 | 714 | (append (gexp-outputs exp) result)) |
e39d1461 LC |
715 | (($ <gexp-input> (lst ...) output native?) |
716 | ;; XXX: Automatically convert LST. | |
0dbea56b LC |
717 | (add-reference-output (map (match-lambda |
718 | ((? gexp-input? x) x) | |
719 | (x (%gexp-input x "out" native?))) | |
720 | lst) | |
e39d1461 | 721 | result)) |
f9efe568 LC |
722 | ((lst ...) |
723 | (fold-right add-reference-output result lst)) | |
21b679f6 LC |
724 | (_ |
725 | result))) | |
726 | ||
7e75a673 LC |
727 | (delete-duplicates |
728 | (add-reference-output (gexp-references exp) '()))) | |
21b679f6 | 729 | |
68a61e9f LC |
730 | (define* (gexp->sexp exp #:key |
731 | (system (%current-system)) | |
732 | (target (%current-target-system))) | |
21b679f6 LC |
733 | "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, |
734 | and in the current monad setting (system type, etc.)" | |
667b2508 | 735 | (define* (reference->sexp ref #:optional native?) |
21b679f6 LC |
736 | (with-monad %store-monad |
737 | (match ref | |
1e87da58 | 738 | (($ <gexp-output> output) |
bfd9eed9 LC |
739 | ;; Output file names are not known in advance but the daemon defines |
740 | ;; an environment variable for each of them at build time, so use | |
741 | ;; that trick. | |
742 | (return `((@ (guile) getenv) ,output))) | |
e39d1461 | 743 | (($ <gexp-input> (? gexp? exp) output n?) |
667b2508 LC |
744 | (gexp->sexp exp |
745 | #:system system | |
e39d1461 LC |
746 | #:target (if (or n? native?) #f target))) |
747 | (($ <gexp-input> (refs ...) output n?) | |
667b2508 | 748 | (sequence %store-monad |
e39d1461 LC |
749 | (map (lambda (ref) |
750 | ;; XXX: Automatically convert REF to an gexp-input. | |
0dbea56b LC |
751 | (reference->sexp |
752 | (if (gexp-input? ref) | |
753 | ref | |
754 | (%gexp-input ref "out" n?)) | |
affd7761 | 755 | (or n? native?))) |
e39d1461 | 756 | refs))) |
bcb13287 | 757 | (($ <gexp-input> (? struct? thing) output n?) |
ebdfd776 LC |
758 | (let ((target (if (or n? native?) #f target)) |
759 | (expand (lookup-expander thing))) | |
c2b84676 LC |
760 | (mlet %store-monad ((obj (lower-object thing system |
761 | #:target target))) | |
d9ae938f | 762 | ;; OBJ must be either a derivation or a store file name. |
ebdfd776 | 763 | (return (expand thing obj output))))) |
e39d1461 LC |
764 | (($ <gexp-input> x) |
765 | (return x)) | |
21b679f6 LC |
766 | (x |
767 | (return x))))) | |
768 | ||
769 | (mlet %store-monad | |
770 | ((args (sequence %store-monad | |
affd7761 | 771 | (map reference->sexp (gexp-references exp))))) |
21b679f6 LC |
772 | (return (apply (gexp-proc exp) args)))) |
773 | ||
21b679f6 LC |
774 | (define (syntax-location-string s) |
775 | "Return a string representing the source code location of S." | |
776 | (let ((props (syntax-source s))) | |
777 | (if props | |
778 | (let ((file (assoc-ref props 'filename)) | |
779 | (line (and=> (assoc-ref props 'line) 1+)) | |
780 | (column (assoc-ref props 'column))) | |
781 | (if file | |
782 | (simple-format #f "~a:~a:~a" | |
783 | file line column) | |
784 | (simple-format #f "~a:~a" line column))) | |
785 | "<unknown location>"))) | |
786 | ||
0bb9929e LC |
787 | (define-syntax-parameter current-imported-modules |
788 | ;; Current list of imported modules. | |
789 | (identifier-syntax '())) | |
790 | ||
791 | (define-syntax-rule (with-imported-modules modules body ...) | |
792 | "Mark the gexps defined in BODY... as requiring MODULES in their execution | |
793 | environment." | |
794 | (syntax-parameterize ((current-imported-modules | |
795 | (identifier-syntax modules))) | |
796 | body ...)) | |
797 | ||
21b679f6 LC |
798 | (define-syntax gexp |
799 | (lambda (s) | |
800 | (define (collect-escapes exp) | |
801 | ;; Return all the 'ungexp' present in EXP. | |
802 | (let loop ((exp exp) | |
803 | (result '())) | |
607e1b51 LC |
804 | (syntax-case exp (ungexp |
805 | ungexp-splicing | |
806 | ungexp-native | |
807 | ungexp-native-splicing) | |
21b679f6 LC |
808 | ((ungexp _) |
809 | (cons exp result)) | |
810 | ((ungexp _ _) | |
811 | (cons exp result)) | |
812 | ((ungexp-splicing _ ...) | |
813 | (cons exp result)) | |
607e1b51 | 814 | ((ungexp-native _ ...) |
667b2508 LC |
815 | (cons exp result)) |
816 | ((ungexp-native-splicing _ ...) | |
817 | (cons exp result)) | |
5e2e4a51 | 818 | ((exp0 . exp) |
667b2508 | 819 | (let ((result (loop #'exp0 result))) |
5e2e4a51 | 820 | (loop #'exp result))) |
667b2508 LC |
821 | (_ |
822 | result)))) | |
823 | ||
21b679f6 LC |
824 | (define (escape->ref exp) |
825 | ;; Turn 'ungexp' form EXP into a "reference". | |
667b2508 LC |
826 | (syntax-case exp (ungexp ungexp-splicing |
827 | ungexp-native ungexp-native-splicing | |
828 | output) | |
21b679f6 | 829 | ((ungexp output) |
1e87da58 | 830 | #'(gexp-output "out")) |
21b679f6 | 831 | ((ungexp output name) |
1e87da58 | 832 | #'(gexp-output name)) |
21b679f6 | 833 | ((ungexp thing) |
0dbea56b | 834 | #'(%gexp-input thing "out" #f)) |
21b679f6 | 835 | ((ungexp drv-or-pkg out) |
0dbea56b | 836 | #'(%gexp-input drv-or-pkg out #f)) |
21b679f6 | 837 | ((ungexp-splicing lst) |
0dbea56b | 838 | #'(%gexp-input lst "out" #f)) |
667b2508 | 839 | ((ungexp-native thing) |
0dbea56b | 840 | #'(%gexp-input thing "out" #t)) |
667b2508 | 841 | ((ungexp-native drv-or-pkg out) |
0dbea56b | 842 | #'(%gexp-input drv-or-pkg out #t)) |
667b2508 | 843 | ((ungexp-native-splicing lst) |
0dbea56b | 844 | #'(%gexp-input lst "out" #t)))) |
21b679f6 | 845 | |
667b2508 LC |
846 | (define (substitute-ungexp exp substs) |
847 | ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with | |
848 | ;; the corresponding form in SUBSTS. | |
849 | (match (assoc exp substs) | |
850 | ((_ id) | |
851 | id) | |
4a6e889f LC |
852 | (_ ;internal error |
853 | (with-syntax ((exp exp)) | |
854 | #'(syntax-error "error: no 'ungexp' substitution" exp))))) | |
667b2508 LC |
855 | |
856 | (define (substitute-ungexp-splicing exp substs) | |
857 | (syntax-case exp () | |
858 | ((exp rest ...) | |
859 | (match (assoc #'exp substs) | |
860 | ((_ id) | |
861 | (with-syntax ((id id)) | |
862 | #`(append id | |
863 | #,(substitute-references #'(rest ...) substs)))) | |
864 | (_ | |
865 | #'(syntax-error "error: no 'ungexp-splicing' substitution" | |
4a6e889f | 866 | exp)))))) |
667b2508 | 867 | |
21b679f6 LC |
868 | (define (substitute-references exp substs) |
869 | ;; Return a variant of EXP where all the cars of SUBSTS have been | |
870 | ;; replaced by the corresponding cdr. | |
667b2508 LC |
871 | (syntax-case exp (ungexp ungexp-native |
872 | ungexp-splicing ungexp-native-splicing) | |
21b679f6 | 873 | ((ungexp _ ...) |
667b2508 LC |
874 | (substitute-ungexp exp substs)) |
875 | ((ungexp-native _ ...) | |
876 | (substitute-ungexp exp substs)) | |
21b679f6 | 877 | (((ungexp-splicing _ ...) rest ...) |
667b2508 LC |
878 | (substitute-ungexp-splicing exp substs)) |
879 | (((ungexp-native-splicing _ ...) rest ...) | |
880 | (substitute-ungexp-splicing exp substs)) | |
5e2e4a51 | 881 | ((exp0 . exp) |
21b679f6 | 882 | #`(cons #,(substitute-references #'exp0 substs) |
5e2e4a51 | 883 | #,(substitute-references #'exp substs))) |
21b679f6 LC |
884 | (x #''x))) |
885 | ||
886 | (syntax-case s (ungexp output) | |
887 | ((_ exp) | |
affd7761 | 888 | (let* ((escapes (delete-duplicates (collect-escapes #'exp))) |
21b679f6 LC |
889 | (formals (generate-temporaries escapes)) |
890 | (sexp (substitute-references #'exp (zip escapes formals))) | |
affd7761 LC |
891 | (refs (map escape->ref escapes))) |
892 | #`(make-gexp (list #,@refs) | |
0bb9929e | 893 | current-imported-modules |
21b679f6 LC |
894 | (lambda #,formals |
895 | #,sexp))))))) | |
896 | ||
897 | \f | |
aa72d9af LC |
898 | ;;; |
899 | ;;; Module handling. | |
900 | ;;; | |
901 | ||
df2d51f0 LC |
902 | (define %utils-module |
903 | ;; This file provides 'mkdir-p', needed to implement 'imported-files' and | |
a9601e23 LC |
904 | ;; other primitives below. Note: We give the file name relative to this |
905 | ;; file you are currently reading; 'search-path' could return a file name | |
906 | ;; relative to the current working directory. | |
907 | (local-file "build/utils.scm" | |
df2d51f0 | 908 | "build-utils.scm")) |
aa72d9af LC |
909 | |
910 | (define* (imported-files files | |
911 | #:key (name "file-import") | |
912 | (system (%current-system)) | |
913 | (guile (%guile-for-build))) | |
914 | "Return a derivation that imports FILES into STORE. FILES must be a list | |
915 | of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file | |
916 | system, imported, and appears under FINAL-PATH in the resulting store path." | |
917 | (define file-pair | |
918 | (match-lambda | |
919 | ((final-path . file-name) | |
920 | (mlet %store-monad ((file (interned-file file-name | |
921 | (basename final-path)))) | |
922 | (return (list final-path file)))))) | |
923 | ||
924 | (mlet %store-monad ((files (sequence %store-monad | |
925 | (map file-pair files)))) | |
926 | (define build | |
927 | (gexp | |
928 | (begin | |
df2d51f0 | 929 | (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' |
aa72d9af LC |
930 | (use-modules (ice-9 match)) |
931 | ||
aa72d9af LC |
932 | (mkdir (ungexp output)) (chdir (ungexp output)) |
933 | (for-each (match-lambda | |
934 | ((final-path store-path) | |
935 | (mkdir-p (dirname final-path)) | |
936 | (symlink store-path final-path))) | |
937 | '(ungexp files))))) | |
938 | ||
939 | ;; TODO: Pass FILES as an environment variable so that BUILD remains | |
940 | ;; exactly the same regardless of FILES: less disk space, and fewer | |
941 | ;; 'add-to-store' RPCs. | |
942 | (gexp->derivation name build | |
943 | #:system system | |
944 | #:guile-for-build guile | |
945 | #:local-build? #t))) | |
946 | ||
aa72d9af LC |
947 | (define* (imported-modules modules |
948 | #:key (name "module-import") | |
949 | (system (%current-system)) | |
950 | (guile (%guile-for-build)) | |
951 | (module-path %load-path)) | |
952 | "Return a derivation that contains the source files of MODULES, a list of | |
953 | module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH | |
954 | search path." | |
955 | ;; TODO: Determine the closure of MODULES, build the `.go' files, | |
956 | ;; canonicalize the source files through read/write, etc. | |
957 | (let ((files (map (lambda (m) | |
6985335f | 958 | (let ((f (module->source-file-name m))) |
aa72d9af LC |
959 | (cons f (search-path* module-path f)))) |
960 | modules))) | |
961 | (imported-files files #:name name #:system system | |
962 | #:guile guile))) | |
963 | ||
964 | (define* (compiled-modules modules | |
965 | #:key (name "module-import-compiled") | |
966 | (system (%current-system)) | |
967 | (guile (%guile-for-build)) | |
968 | (module-path %load-path)) | |
969 | "Return a derivation that builds a tree containing the `.go' files | |
970 | corresponding to MODULES. All the MODULES are built in a context where | |
971 | they can refer to each other." | |
972 | (mlet %store-monad ((modules (imported-modules modules | |
973 | #:system system | |
974 | #:guile guile | |
975 | #:module-path | |
976 | module-path))) | |
977 | (define build | |
978 | (gexp | |
979 | (begin | |
df2d51f0 LC |
980 | (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' |
981 | ||
aa72d9af | 982 | (use-modules (ice-9 ftw) |
aa72d9af LC |
983 | (srfi srfi-26) |
984 | (system base compile)) | |
985 | ||
aa72d9af LC |
986 | (define (regular? file) |
987 | (not (member file '("." "..")))) | |
988 | ||
989 | (define (process-directory directory output) | |
990 | (let ((entries (map (cut string-append directory "/" <>) | |
991 | (scandir directory regular?)))) | |
992 | (for-each (lambda (entry) | |
993 | (if (file-is-directory? entry) | |
994 | (let ((output (string-append output "/" | |
995 | (basename entry)))) | |
996 | (mkdir-p output) | |
997 | (process-directory entry output)) | |
998 | (let* ((base (string-drop-right | |
999 | (basename entry) | |
1000 | 4)) ;.scm | |
1001 | (output (string-append output "/" base | |
1002 | ".go"))) | |
1003 | (compile-file entry | |
1004 | #:output-file output | |
1005 | #:opts | |
1006 | %auto-compilation-options)))) | |
1007 | entries))) | |
1008 | ||
1009 | (set! %load-path (cons (ungexp modules) %load-path)) | |
1010 | (mkdir (ungexp output)) | |
1011 | (chdir (ungexp modules)) | |
1012 | (process-directory "." (ungexp output))))) | |
1013 | ||
1014 | ;; TODO: Pass MODULES as an environment variable. | |
1015 | (gexp->derivation name build | |
1016 | #:system system | |
1017 | #:guile-for-build guile | |
1018 | #:local-build? #t))) | |
1019 | ||
1020 | \f | |
21b679f6 LC |
1021 | ;;; |
1022 | ;;; Convenience procedures. | |
1023 | ;;; | |
1024 | ||
53e89b17 LC |
1025 | (define (default-guile) |
1026 | ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) | |
1027 | ;; modules directly, to avoid circular dependencies, hence this hack. | |
bdb36958 | 1028 | (module-ref (resolve-interface '(gnu packages commencement)) |
53e89b17 LC |
1029 | 'guile-final)) |
1030 | ||
dd8d1a30 LC |
1031 | (define (load-path-expression modules) |
1032 | "Return as a monadic value a gexp that sets '%load-path' and | |
1033 | '%load-compiled-path' to point to MODULES, a list of module names." | |
1034 | (mlet %store-monad ((modules (imported-modules modules)) | |
1035 | (compiled (compiled-modules modules))) | |
1036 | (return (gexp (eval-when (expand load eval) | |
1037 | (set! %load-path | |
1038 | (cons (ungexp modules) %load-path)) | |
1039 | (set! %load-compiled-path | |
1040 | (cons (ungexp compiled) | |
1041 | %load-compiled-path))))))) | |
1042 | ||
21b679f6 | 1043 | (define* (gexp->script name exp |
9c14a487 LC |
1044 | #:key (guile (default-guile))) |
1045 | "Return an executable script NAME that runs EXP using GUILE, with EXP's | |
1046 | imported modules in its search path." | |
1047 | (mlet %store-monad ((set-load-path | |
1048 | (load-path-expression (gexp-modules exp)))) | |
21b679f6 LC |
1049 | (gexp->derivation name |
1050 | (gexp | |
1051 | (call-with-output-file (ungexp output) | |
1052 | (lambda (port) | |
c17b5ab4 LC |
1053 | ;; Note: that makes a long shebang. When the store |
1054 | ;; is /gnu/store, that fits within the 128-byte | |
1055 | ;; limit imposed by Linux, but that may go beyond | |
1056 | ;; when running tests. | |
21b679f6 LC |
1057 | (format port |
1058 | "#!~a/bin/guile --no-auto-compile~%!#~%" | |
1059 | (ungexp guile)) | |
4a4cbd0b | 1060 | |
dd8d1a30 | 1061 | (write '(ungexp set-load-path) port) |
21b679f6 LC |
1062 | (write '(ungexp exp) port) |
1063 | (chmod port #o555))))))) | |
1064 | ||
2b418579 LC |
1065 | (define* (gexp->file name exp #:key (set-load-path? #t)) |
1066 | "Return a derivation that builds a file NAME containing EXP. When | |
1067 | SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path' | |
1068 | and '%load-compiled-path' to honor EXP's imported modules." | |
1069 | (match (if set-load-path? (gexp-modules exp) '()) | |
1070 | (() ;zero modules | |
1071 | (gexp->derivation name | |
1072 | (gexp | |
1073 | (call-with-output-file (ungexp output) | |
1074 | (lambda (port) | |
1075 | (write '(ungexp exp) port)))) | |
1076 | #:local-build? #t | |
1077 | #:substitutable? #f)) | |
1078 | ((modules ...) | |
1079 | (mlet %store-monad ((set-load-path (load-path-expression modules))) | |
1080 | (gexp->derivation name | |
1081 | (gexp | |
1082 | (call-with-output-file (ungexp output) | |
1083 | (lambda (port) | |
1084 | (write '(ungexp set-load-path) port) | |
1085 | (write '(ungexp exp) port)))) | |
1086 | #:local-build? #t | |
1087 | #:substitutable? #f))))) | |
21b679f6 | 1088 | |
462a3fa3 LC |
1089 | (define* (text-file* name #:rest text) |
1090 | "Return as a monadic value a derivation that builds a text file containing | |
d9ae938f LC |
1091 | all of TEXT. TEXT may list, in addition to strings, objects of any type that |
1092 | can be used in a gexp: packages, derivations, local file objects, etc. The | |
1093 | resulting store file holds references to all these." | |
462a3fa3 LC |
1094 | (define builder |
1095 | (gexp (call-with-output-file (ungexp output "out") | |
1096 | (lambda (port) | |
1097 | (display (string-append (ungexp-splicing text)) port))))) | |
1098 | ||
851b6f62 LC |
1099 | (gexp->derivation name builder |
1100 | #:local-build? #t | |
1101 | #:substitutable? #f)) | |
462a3fa3 | 1102 | |
b751cde3 LC |
1103 | (define* (mixed-text-file name #:rest text) |
1104 | "Return an object representing store file NAME containing TEXT. TEXT is a | |
1105 | sequence of strings and file-like objects, as in: | |
1106 | ||
1107 | (mixed-text-file \"profile\" | |
1108 | \"export PATH=\" coreutils \"/bin:\" grep \"/bin\") | |
1109 | ||
1110 | This is the declarative counterpart of 'text-file*'." | |
1111 | (define build | |
1112 | (gexp (call-with-output-file (ungexp output "out") | |
1113 | (lambda (port) | |
1114 | (display (string-append (ungexp-splicing text)) port))))) | |
1115 | ||
1116 | (computed-file name build)) | |
1117 | ||
21b679f6 LC |
1118 | \f |
1119 | ;;; | |
1120 | ;;; Syntactic sugar. | |
1121 | ;;; | |
1122 | ||
1123 | (eval-when (expand load eval) | |
667b2508 LC |
1124 | (define* (read-ungexp chr port #:optional native?) |
1125 | "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is | |
1126 | true, use 'ungexp-native' and 'ungexp-native-splicing' instead." | |
21b679f6 LC |
1127 | (define unquote-symbol |
1128 | (match (peek-char port) | |
1129 | (#\@ | |
1130 | (read-char port) | |
667b2508 LC |
1131 | (if native? |
1132 | 'ungexp-native-splicing | |
1133 | 'ungexp-splicing)) | |
21b679f6 | 1134 | (_ |
667b2508 LC |
1135 | (if native? |
1136 | 'ungexp-native | |
1137 | 'ungexp)))) | |
21b679f6 LC |
1138 | |
1139 | (match (read port) | |
1140 | ((? symbol? symbol) | |
1141 | (let ((str (symbol->string symbol))) | |
1142 | (match (string-index-right str #\:) | |
1143 | (#f | |
1144 | `(,unquote-symbol ,symbol)) | |
1145 | (colon | |
1146 | (let ((name (string->symbol (substring str 0 colon))) | |
1147 | (output (substring str (+ colon 1)))) | |
1148 | `(,unquote-symbol ,name ,output)))))) | |
1149 | (x | |
1150 | `(,unquote-symbol ,x)))) | |
1151 | ||
1152 | (define (read-gexp chr port) | |
1153 | "Read a 'gexp' form from PORT." | |
1154 | `(gexp ,(read port))) | |
1155 | ||
1156 | ;; Extend the reader | |
1157 | (read-hash-extend #\~ read-gexp) | |
667b2508 LC |
1158 | (read-hash-extend #\$ read-ungexp) |
1159 | (read-hash-extend #\+ (cut read-ungexp <> <> #t))) | |
21b679f6 LC |
1160 | |
1161 | ;;; gexp.scm ends here |