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) |
21b679f6 LC |
23 | #:use-module (guix packages) |
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? | |
31 | gexp->derivation | |
32 | gexp->file | |
462a3fa3 LC |
33 | gexp->script |
34 | text-file*)) | |
21b679f6 LC |
35 | |
36 | ;;; Commentary: | |
37 | ;;; | |
38 | ;;; This module implements "G-expressions", or "gexps". Gexps are like | |
39 | ;;; S-expressions (sexps), with two differences: | |
40 | ;;; | |
41 | ;;; 1. References (un-quotations) to derivations or packages in a gexp are | |
667b2508 LC |
42 | ;;; replaced by the corresponding output file name; in addition, the |
43 | ;;; 'ungexp-native' unquote-like form allows code to explicitly refer to | |
44 | ;;; the native code of a given package, in case of cross-compilation; | |
21b679f6 LC |
45 | ;;; |
46 | ;;; 2. Gexps embed information about the derivations they refer to. | |
47 | ;;; | |
48 | ;;; Gexps make it easy to write to files Scheme code that refers to store | |
49 | ;;; items, or to write Scheme code to build derivations. | |
50 | ;;; | |
51 | ;;; Code: | |
52 | ||
53 | ;; "G expressions". | |
54 | (define-record-type <gexp> | |
667b2508 | 55 | (make-gexp references natives proc) |
21b679f6 LC |
56 | gexp? |
57 | (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) | |
667b2508 | 58 | (natives gexp-native-references) ; ((DRV-OR-PKG OUTPUT) ...) |
21b679f6 LC |
59 | (proc gexp-proc)) ; procedure |
60 | ||
7560b00b LC |
61 | (define (write-gexp gexp port) |
62 | "Write GEXP on PORT." | |
63 | (display "#<gexp " port) | |
2cf0ea0d LC |
64 | |
65 | ;; Try to write the underlying sexp. Now, this trick doesn't work when | |
66 | ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure | |
67 | ;; tries to use 'append' on that, which fails with wrong-type-arg. | |
68 | (false-if-exception | |
667b2508 LC |
69 | (write (apply (gexp-proc gexp) |
70 | (append (gexp-references gexp) | |
71 | (gexp-native-references gexp))) | |
72 | port)) | |
7560b00b LC |
73 | (format port " ~a>" |
74 | (number->string (object-address gexp) 16))) | |
75 | ||
76 | (set-record-type-printer! <gexp> write-gexp) | |
77 | ||
21b679f6 LC |
78 | ;; Reference to one of the derivation's outputs, for gexps used in |
79 | ;; derivations. | |
80 | (define-record-type <output-ref> | |
81 | (output-ref name) | |
82 | output-ref? | |
83 | (name output-ref-name)) | |
84 | ||
85 | (define raw-derivation | |
86 | (store-lift derivation)) | |
87 | ||
68a61e9f LC |
88 | (define* (lower-inputs inputs |
89 | #:key system target) | |
90 | "Turn any package from INPUTS into a derivation for SYSTEM; return the | |
91 | corresponding input list as a monadic value. When TARGET is true, use it as | |
92 | the cross-compilation target triplet." | |
21b679f6 LC |
93 | (with-monad %store-monad |
94 | (sequence %store-monad | |
95 | (map (match-lambda | |
96 | (((? package? package) sub-drv ...) | |
68a61e9f LC |
97 | (mlet %store-monad |
98 | ((drv (if target | |
99 | (package->cross-derivation package target | |
100 | system) | |
101 | (package->derivation package system)))) | |
21b679f6 | 102 | (return `(,drv ,@sub-drv)))) |
79c0c8cd LC |
103 | (((? origin? origin) sub-drv ...) |
104 | (mlet %store-monad ((drv (origin->derivation origin))) | |
105 | (return `(,drv ,@sub-drv)))) | |
21b679f6 LC |
106 | (input |
107 | (return input))) | |
108 | inputs)))) | |
109 | ||
b53833b2 LC |
110 | (define* (lower-reference-graphs graphs #:key system target) |
111 | "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a | |
112 | #:reference-graphs argument, lower it such that each INPUT is replaced by the | |
113 | corresponding derivation." | |
114 | (match graphs | |
115 | (((file-names . inputs) ...) | |
116 | (mlet %store-monad ((inputs (lower-inputs inputs | |
117 | #:system system | |
118 | #:target target))) | |
119 | (return (map cons file-names inputs)))))) | |
120 | ||
c8351d9a LC |
121 | (define* (lower-references lst #:key system target) |
122 | "Based on LST, a list of output names and packages, return a list of output | |
123 | names and file names suitable for the #:allowed-references argument to | |
124 | 'derivation'." | |
125 | ;; XXX: Currently outputs other than "out" are not supported, and things | |
126 | ;; other than packages aren't either. | |
127 | (with-monad %store-monad | |
128 | (define lower | |
129 | (match-lambda | |
130 | ((? string? output) | |
131 | (return output)) | |
132 | ((? package? package) | |
133 | (mlet %store-monad ((drv | |
134 | (if target | |
135 | (package->cross-derivation package target | |
136 | #:system system | |
137 | #:graft? #f) | |
138 | (package->derivation package system | |
139 | #:graft? #f)))) | |
140 | (return (derivation->output-path drv)))))) | |
141 | ||
142 | (sequence %store-monad (map lower lst)))) | |
143 | ||
21b679f6 LC |
144 | (define* (gexp->derivation name exp |
145 | #:key | |
68a61e9f | 146 | system (target 'current) |
21b679f6 LC |
147 | hash hash-algo recursive? |
148 | (env-vars '()) | |
149 | (modules '()) | |
4684f301 | 150 | (module-path %load-path) |
21b679f6 LC |
151 | (guile-for-build (%guile-for-build)) |
152 | references-graphs | |
c8351d9a | 153 | allowed-references |
21b679f6 LC |
154 | local-build?) |
155 | "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a | |
68a61e9f LC |
156 | derivation) on SYSTEM. When TARGET is true, it is used as the |
157 | cross-compilation target triplet for packages referred to by EXP. | |
21b679f6 LC |
158 | |
159 | Make MODULES available in the evaluation context of EXP; MODULES is a list of | |
4684f301 | 160 | names of Guile modules searched in MODULE-PATH to be copied in the store, |
21b679f6 LC |
161 | compiled, and made available in the load path during the execution of |
162 | EXP---e.g., '((guix build utils) (guix build gnu-build-system)). | |
163 | ||
b53833b2 LC |
164 | When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the |
165 | following forms: | |
166 | ||
167 | (FILE-NAME PACKAGE) | |
168 | (FILE-NAME PACKAGE OUTPUT) | |
169 | (FILE-NAME DERIVATION) | |
170 | (FILE-NAME DERIVATION OUTPUT) | |
171 | (FILE-NAME STORE-ITEM) | |
172 | ||
173 | The right-hand-side of each element of REFERENCES-GRAPHS is automatically made | |
174 | an input of the build process of EXP. In the build environment, each | |
175 | FILE-NAME contains the reference graph of the corresponding item, in a simple | |
176 | text format. | |
177 | ||
c8351d9a LC |
178 | ALLOWED-REFERENCES must be either #f or a list of output names and packages. |
179 | In the latter case, the list denotes store items that the result is allowed to | |
180 | refer to. Any reference to another store item will lead to a build error. | |
b53833b2 | 181 | |
21b679f6 LC |
182 | The other arguments are as for 'derivation'." |
183 | (define %modules modules) | |
184 | (define outputs (gexp-outputs exp)) | |
185 | ||
b53833b2 LC |
186 | (define (graphs-file-names graphs) |
187 | ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. | |
188 | (map (match-lambda | |
189 | ((file-name (? derivation? drv)) | |
190 | (cons file-name (derivation->output-path drv))) | |
191 | ((file-name (? derivation? drv) sub-drv) | |
192 | (cons file-name (derivation->output-path drv sub-drv))) | |
193 | ((file-name thing) | |
194 | (cons file-name thing))) | |
195 | graphs)) | |
196 | ||
68a61e9f LC |
197 | (mlet* %store-monad (;; The following binding is here to force |
198 | ;; '%current-system' and '%current-target-system' to be | |
199 | ;; looked up at >>= time. | |
200 | (unused (return #f)) | |
201 | ||
5d098459 | 202 | (system -> (or system (%current-system))) |
68a61e9f LC |
203 | (target -> (if (eq? target 'current) |
204 | (%current-target-system) | |
205 | target)) | |
667b2508 | 206 | (normals (lower-inputs (gexp-inputs exp) |
68a61e9f LC |
207 | #:system system |
208 | #:target target)) | |
667b2508 LC |
209 | (natives (lower-inputs (gexp-native-inputs exp) |
210 | #:system system | |
211 | #:target #f)) | |
212 | (inputs -> (append normals natives)) | |
68a61e9f LC |
213 | (sexp (gexp->sexp exp |
214 | #:system system | |
215 | #:target target)) | |
21b679f6 LC |
216 | (builder (text-file (string-append name "-builder") |
217 | (object->string sexp))) | |
218 | (modules (if (pair? %modules) | |
219 | (imported-modules %modules | |
220 | #:system system | |
4684f301 | 221 | #:module-path module-path |
21b679f6 LC |
222 | #:guile guile-for-build) |
223 | (return #f))) | |
224 | (compiled (if (pair? %modules) | |
225 | (compiled-modules %modules | |
226 | #:system system | |
4684f301 | 227 | #:module-path module-path |
21b679f6 LC |
228 | #:guile guile-for-build) |
229 | (return #f))) | |
b53833b2 LC |
230 | (graphs (if references-graphs |
231 | (lower-reference-graphs references-graphs | |
232 | #:system system | |
233 | #:target target) | |
234 | (return #f))) | |
c8351d9a LC |
235 | (allowed (if allowed-references |
236 | (lower-references allowed-references | |
237 | #:system system | |
238 | #:target target) | |
239 | (return #f))) | |
21b679f6 LC |
240 | (guile (if guile-for-build |
241 | (return guile-for-build) | |
53e89b17 LC |
242 | (package->derivation (default-guile) |
243 | system)))) | |
21b679f6 LC |
244 | (raw-derivation name |
245 | (string-append (derivation->output-path guile) | |
246 | "/bin/guile") | |
247 | `("--no-auto-compile" | |
248 | ,@(if (pair? %modules) | |
249 | `("-L" ,(derivation->output-path modules) | |
250 | "-C" ,(derivation->output-path compiled)) | |
251 | '()) | |
252 | ,builder) | |
253 | #:outputs outputs | |
254 | #:env-vars env-vars | |
255 | #:system system | |
256 | #:inputs `((,guile) | |
257 | (,builder) | |
258 | ,@(if modules | |
259 | `((,modules) (,compiled) ,@inputs) | |
b53833b2 LC |
260 | inputs) |
261 | ,@(match graphs | |
262 | (((_ . inputs) ...) inputs) | |
263 | (_ '()))) | |
21b679f6 | 264 | #:hash hash #:hash-algo hash-algo #:recursive? recursive? |
b53833b2 | 265 | #:references-graphs (and=> graphs graphs-file-names) |
c8351d9a | 266 | #:allowed-references allowed |
21b679f6 LC |
267 | #:local-build? local-build?))) |
268 | ||
667b2508 LC |
269 | (define* (gexp-inputs exp #:optional (references gexp-references)) |
270 | "Return the input list for EXP, using REFERENCES to get its list of | |
271 | references." | |
21b679f6 LC |
272 | (define (add-reference-inputs ref result) |
273 | (match ref | |
274 | (((? derivation?) (? string?)) | |
275 | (cons ref result)) | |
276 | (((? package?) (? string?)) | |
277 | (cons ref result)) | |
79c0c8cd LC |
278 | (((? origin?) (? string?)) |
279 | (cons ref result)) | |
21b679f6 | 280 | ((? gexp? exp) |
667b2508 | 281 | (append (gexp-inputs exp references) result)) |
21b679f6 LC |
282 | (((? string? file)) |
283 | (if (direct-store-path? file) | |
284 | (cons ref result) | |
285 | result)) | |
286 | ((refs ...) | |
287 | (fold-right add-reference-inputs result refs)) | |
288 | (_ | |
289 | ;; Ignore references to other kinds of objects. | |
290 | result))) | |
291 | ||
292 | (fold-right add-reference-inputs | |
293 | '() | |
667b2508 LC |
294 | (references exp))) |
295 | ||
296 | (define gexp-native-inputs | |
297 | (cut gexp-inputs <> gexp-native-references)) | |
21b679f6 LC |
298 | |
299 | (define (gexp-outputs exp) | |
300 | "Return the outputs referred to by EXP as a list of strings." | |
301 | (define (add-reference-output ref result) | |
302 | (match ref | |
303 | (($ <output-ref> name) | |
304 | (cons name result)) | |
305 | ((? gexp? exp) | |
306 | (append (gexp-outputs exp) result)) | |
307 | (_ | |
308 | result))) | |
309 | ||
310 | (fold-right add-reference-output | |
311 | '() | |
312 | (gexp-references exp))) | |
313 | ||
68a61e9f LC |
314 | (define* (gexp->sexp exp #:key |
315 | (system (%current-system)) | |
316 | (target (%current-target-system))) | |
21b679f6 LC |
317 | "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, |
318 | and in the current monad setting (system type, etc.)" | |
667b2508 | 319 | (define* (reference->sexp ref #:optional native?) |
21b679f6 LC |
320 | (with-monad %store-monad |
321 | (match ref | |
322 | (((? derivation? drv) (? string? output)) | |
323 | (return (derivation->output-path drv output))) | |
324 | (((? package? p) (? string? output)) | |
68a61e9f LC |
325 | (package-file p |
326 | #:output output | |
327 | #:system system | |
667b2508 | 328 | #:target (if native? #f target))) |
79c0c8cd LC |
329 | (((? origin? o) (? string? output)) |
330 | (mlet %store-monad ((drv (origin->derivation o))) | |
331 | (return (derivation->output-path drv output)))) | |
21b679f6 | 332 | (($ <output-ref> output) |
bfd9eed9 LC |
333 | ;; Output file names are not known in advance but the daemon defines |
334 | ;; an environment variable for each of them at build time, so use | |
335 | ;; that trick. | |
336 | (return `((@ (guile) getenv) ,output))) | |
21b679f6 | 337 | ((? gexp? exp) |
667b2508 LC |
338 | (gexp->sexp exp |
339 | #:system system | |
340 | #:target (if native? #f target))) | |
21b679f6 LC |
341 | (((? string? str)) |
342 | (return (if (direct-store-path? str) str ref))) | |
343 | ((refs ...) | |
667b2508 LC |
344 | (sequence %store-monad |
345 | (map (cut reference->sexp <> native?) refs))) | |
21b679f6 LC |
346 | (x |
347 | (return x))))) | |
348 | ||
349 | (mlet %store-monad | |
350 | ((args (sequence %store-monad | |
667b2508 LC |
351 | (append (map reference->sexp (gexp-references exp)) |
352 | (map (cut reference->sexp <> #t) | |
353 | (gexp-native-references exp)))))) | |
21b679f6 LC |
354 | (return (apply (gexp-proc exp) args)))) |
355 | ||
356 | (define (canonicalize-reference ref) | |
357 | "Return a canonical variant of REF, which adds any missing output part in | |
358 | package/derivation references." | |
359 | (match ref | |
360 | ((? package? p) | |
361 | `(,p "out")) | |
79c0c8cd LC |
362 | ((? origin? o) |
363 | `(,o "out")) | |
21b679f6 LC |
364 | ((? derivation? d) |
365 | `(,d "out")) | |
366 | (((? package?) (? string?)) | |
367 | ref) | |
79c0c8cd LC |
368 | (((? origin?) (? string?)) |
369 | ref) | |
21b679f6 LC |
370 | (((? derivation?) (? string?)) |
371 | ref) | |
372 | ((? string? s) | |
373 | (if (direct-store-path? s) `(,s) s)) | |
374 | ((refs ...) | |
375 | (map canonicalize-reference refs)) | |
376 | (x x))) | |
377 | ||
378 | (define (syntax-location-string s) | |
379 | "Return a string representing the source code location of S." | |
380 | (let ((props (syntax-source s))) | |
381 | (if props | |
382 | (let ((file (assoc-ref props 'filename)) | |
383 | (line (and=> (assoc-ref props 'line) 1+)) | |
384 | (column (assoc-ref props 'column))) | |
385 | (if file | |
386 | (simple-format #f "~a:~a:~a" | |
387 | file line column) | |
388 | (simple-format #f "~a:~a" line column))) | |
389 | "<unknown location>"))) | |
390 | ||
391 | (define-syntax gexp | |
392 | (lambda (s) | |
393 | (define (collect-escapes exp) | |
394 | ;; Return all the 'ungexp' present in EXP. | |
395 | (let loop ((exp exp) | |
396 | (result '())) | |
397 | (syntax-case exp (ungexp ungexp-splicing) | |
398 | ((ungexp _) | |
399 | (cons exp result)) | |
400 | ((ungexp _ _) | |
401 | (cons exp result)) | |
402 | ((ungexp-splicing _ ...) | |
403 | (cons exp result)) | |
404 | ((exp0 exp ...) | |
405 | (let ((result (loop #'exp0 result))) | |
406 | (fold loop result #'(exp ...)))) | |
407 | (_ | |
408 | result)))) | |
409 | ||
667b2508 LC |
410 | (define (collect-native-escapes exp) |
411 | ;; Return all the 'ungexp-native' forms present in EXP. | |
412 | (let loop ((exp exp) | |
413 | (result '())) | |
414 | (syntax-case exp (ungexp-native ungexp-native-splicing) | |
415 | ((ungexp-native _) | |
416 | (cons exp result)) | |
417 | ((ungexp-native _ _) | |
418 | (cons exp result)) | |
419 | ((ungexp-native-splicing _ ...) | |
420 | (cons exp result)) | |
421 | ((exp0 exp ...) | |
422 | (let ((result (loop #'exp0 result))) | |
423 | (fold loop result #'(exp ...)))) | |
424 | (_ | |
425 | result)))) | |
426 | ||
21b679f6 LC |
427 | (define (escape->ref exp) |
428 | ;; Turn 'ungexp' form EXP into a "reference". | |
667b2508 LC |
429 | (syntax-case exp (ungexp ungexp-splicing |
430 | ungexp-native ungexp-native-splicing | |
431 | output) | |
21b679f6 LC |
432 | ((ungexp output) |
433 | #'(output-ref "out")) | |
434 | ((ungexp output name) | |
435 | #'(output-ref name)) | |
436 | ((ungexp thing) | |
437 | #'thing) | |
438 | ((ungexp drv-or-pkg out) | |
439 | #'(list drv-or-pkg out)) | |
440 | ((ungexp-splicing lst) | |
667b2508 LC |
441 | #'lst) |
442 | ((ungexp-native thing) | |
443 | #'thing) | |
444 | ((ungexp-native drv-or-pkg out) | |
445 | #'(list drv-or-pkg out)) | |
446 | ((ungexp-native-splicing lst) | |
21b679f6 LC |
447 | #'lst))) |
448 | ||
667b2508 LC |
449 | (define (substitute-ungexp exp substs) |
450 | ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with | |
451 | ;; the corresponding form in SUBSTS. | |
452 | (match (assoc exp substs) | |
453 | ((_ id) | |
454 | id) | |
455 | (_ | |
456 | #'(syntax-error "error: no 'ungexp' substitution" | |
457 | #'ref)))) | |
458 | ||
459 | (define (substitute-ungexp-splicing exp substs) | |
460 | (syntax-case exp () | |
461 | ((exp rest ...) | |
462 | (match (assoc #'exp substs) | |
463 | ((_ id) | |
464 | (with-syntax ((id id)) | |
465 | #`(append id | |
466 | #,(substitute-references #'(rest ...) substs)))) | |
467 | (_ | |
468 | #'(syntax-error "error: no 'ungexp-splicing' substitution" | |
469 | #'ref)))))) | |
470 | ||
21b679f6 LC |
471 | (define (substitute-references exp substs) |
472 | ;; Return a variant of EXP where all the cars of SUBSTS have been | |
473 | ;; replaced by the corresponding cdr. | |
667b2508 LC |
474 | (syntax-case exp (ungexp ungexp-native |
475 | ungexp-splicing ungexp-native-splicing) | |
21b679f6 | 476 | ((ungexp _ ...) |
667b2508 LC |
477 | (substitute-ungexp exp substs)) |
478 | ((ungexp-native _ ...) | |
479 | (substitute-ungexp exp substs)) | |
21b679f6 | 480 | (((ungexp-splicing _ ...) rest ...) |
667b2508 LC |
481 | (substitute-ungexp-splicing exp substs)) |
482 | (((ungexp-native-splicing _ ...) rest ...) | |
483 | (substitute-ungexp-splicing exp substs)) | |
21b679f6 LC |
484 | ((exp0 exp ...) |
485 | #`(cons #,(substitute-references #'exp0 substs) | |
486 | #,(substitute-references #'(exp ...) substs))) | |
487 | (x #''x))) | |
488 | ||
489 | (syntax-case s (ungexp output) | |
490 | ((_ exp) | |
667b2508 LC |
491 | (let* ((normals (delete-duplicates (collect-escapes #'exp))) |
492 | (natives (delete-duplicates (collect-native-escapes #'exp))) | |
493 | (escapes (append normals natives)) | |
21b679f6 LC |
494 | (formals (generate-temporaries escapes)) |
495 | (sexp (substitute-references #'exp (zip escapes formals))) | |
667b2508 LC |
496 | (refs (map escape->ref normals)) |
497 | (nrefs (map escape->ref natives))) | |
21b679f6 | 498 | #`(make-gexp (map canonicalize-reference (list #,@refs)) |
667b2508 | 499 | (map canonicalize-reference (list #,@nrefs)) |
21b679f6 LC |
500 | (lambda #,formals |
501 | #,sexp))))))) | |
502 | ||
503 | \f | |
504 | ;;; | |
505 | ;;; Convenience procedures. | |
506 | ;;; | |
507 | ||
53e89b17 LC |
508 | (define (default-guile) |
509 | ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) | |
510 | ;; modules directly, to avoid circular dependencies, hence this hack. | |
bdb36958 | 511 | (module-ref (resolve-interface '(gnu packages commencement)) |
53e89b17 LC |
512 | 'guile-final)) |
513 | ||
21b679f6 | 514 | (define* (gexp->script name exp |
53e89b17 | 515 | #:key (modules '()) (guile (default-guile))) |
21b679f6 LC |
516 | "Return an executable script NAME that runs EXP using GUILE with MODULES in |
517 | its search path." | |
518 | (mlet %store-monad ((modules (imported-modules modules)) | |
519 | (compiled (compiled-modules modules))) | |
520 | (gexp->derivation name | |
521 | (gexp | |
522 | (call-with-output-file (ungexp output) | |
523 | (lambda (port) | |
c17b5ab4 LC |
524 | ;; Note: that makes a long shebang. When the store |
525 | ;; is /gnu/store, that fits within the 128-byte | |
526 | ;; limit imposed by Linux, but that may go beyond | |
527 | ;; when running tests. | |
21b679f6 LC |
528 | (format port |
529 | "#!~a/bin/guile --no-auto-compile~%!#~%" | |
530 | (ungexp guile)) | |
4a4cbd0b LC |
531 | |
532 | ;; Write the 'eval-when' form so that it can be | |
533 | ;; compiled. | |
21b679f6 | 534 | (write |
4a4cbd0b LC |
535 | '(eval-when (expand load eval) |
536 | (set! %load-path | |
537 | (cons (ungexp modules) %load-path)) | |
538 | (set! %load-compiled-path | |
539 | (cons (ungexp compiled) | |
540 | %load-compiled-path))) | |
21b679f6 LC |
541 | port) |
542 | (write '(ungexp exp) port) | |
543 | (chmod port #o555))))))) | |
544 | ||
545 | (define (gexp->file name exp) | |
546 | "Return a derivation that builds a file NAME containing EXP." | |
547 | (gexp->derivation name | |
548 | (gexp | |
549 | (call-with-output-file (ungexp output) | |
550 | (lambda (port) | |
dc254e05 LC |
551 | (write '(ungexp exp) port)))) |
552 | #:local-build? #t)) | |
21b679f6 | 553 | |
462a3fa3 LC |
554 | (define* (text-file* name #:rest text) |
555 | "Return as a monadic value a derivation that builds a text file containing | |
556 | all of TEXT. TEXT may list, in addition to strings, packages, derivations, | |
557 | and store file names; the resulting store file holds references to all these." | |
558 | (define builder | |
559 | (gexp (call-with-output-file (ungexp output "out") | |
560 | (lambda (port) | |
561 | (display (string-append (ungexp-splicing text)) port))))) | |
562 | ||
563 | (gexp->derivation name builder)) | |
564 | ||
565 | ||
21b679f6 LC |
566 | \f |
567 | ;;; | |
568 | ;;; Syntactic sugar. | |
569 | ;;; | |
570 | ||
571 | (eval-when (expand load eval) | |
667b2508 LC |
572 | (define* (read-ungexp chr port #:optional native?) |
573 | "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is | |
574 | true, use 'ungexp-native' and 'ungexp-native-splicing' instead." | |
21b679f6 LC |
575 | (define unquote-symbol |
576 | (match (peek-char port) | |
577 | (#\@ | |
578 | (read-char port) | |
667b2508 LC |
579 | (if native? |
580 | 'ungexp-native-splicing | |
581 | 'ungexp-splicing)) | |
21b679f6 | 582 | (_ |
667b2508 LC |
583 | (if native? |
584 | 'ungexp-native | |
585 | 'ungexp)))) | |
21b679f6 LC |
586 | |
587 | (match (read port) | |
588 | ((? symbol? symbol) | |
589 | (let ((str (symbol->string symbol))) | |
590 | (match (string-index-right str #\:) | |
591 | (#f | |
592 | `(,unquote-symbol ,symbol)) | |
593 | (colon | |
594 | (let ((name (string->symbol (substring str 0 colon))) | |
595 | (output (substring str (+ colon 1)))) | |
596 | `(,unquote-symbol ,name ,output)))))) | |
597 | (x | |
598 | `(,unquote-symbol ,x)))) | |
599 | ||
600 | (define (read-gexp chr port) | |
601 | "Read a 'gexp' form from PORT." | |
602 | `(gexp ,(read port))) | |
603 | ||
604 | ;; Extend the reader | |
605 | (read-hash-extend #\~ read-gexp) | |
667b2508 LC |
606 | (read-hash-extend #\$ read-ungexp) |
607 | (read-hash-extend #\+ (cut read-ungexp <> <> #t))) | |
21b679f6 LC |
608 | |
609 | ;;; gexp.scm ends here |