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