Commit | Line | Data |
---|---|---|
21b679f6 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> | |
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) | |
20 | #:use-module ((guix store) | |
21 | #:select (direct-store-path?)) | |
22 | #:use-module (guix monads) | |
23 | #:use-module ((guix derivations) | |
24 | #:select (derivation? derivation->output-path | |
25 | %guile-for-build derivation)) | |
26 | #:use-module (guix packages) | |
27 | #:use-module (srfi srfi-1) | |
28 | #:use-module (srfi srfi-9) | |
7560b00b | 29 | #:use-module (srfi srfi-9 gnu) |
21b679f6 LC |
30 | #:use-module (srfi srfi-26) |
31 | #:use-module (ice-9 match) | |
32 | #:export (gexp | |
33 | gexp? | |
34 | gexp->derivation | |
35 | gexp->file | |
36 | gexp->script)) | |
37 | ||
38 | ;;; Commentary: | |
39 | ;;; | |
40 | ;;; This module implements "G-expressions", or "gexps". Gexps are like | |
41 | ;;; S-expressions (sexps), with two differences: | |
42 | ;;; | |
43 | ;;; 1. References (un-quotations) to derivations or packages in a gexp are | |
44 | ;;; replaced by the corresponding output file name; | |
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> | |
55 | (make-gexp references proc) | |
56 | gexp? | |
57 | (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) | |
58 | (proc gexp-proc)) ; procedure | |
59 | ||
7560b00b LC |
60 | (define (write-gexp gexp port) |
61 | "Write GEXP on PORT." | |
62 | (display "#<gexp " port) | |
2cf0ea0d LC |
63 | |
64 | ;; Try to write the underlying sexp. Now, this trick doesn't work when | |
65 | ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure | |
66 | ;; tries to use 'append' on that, which fails with wrong-type-arg. | |
67 | (false-if-exception | |
68 | (write (apply (gexp-proc gexp) (gexp-references gexp)) port)) | |
7560b00b LC |
69 | (format port " ~a>" |
70 | (number->string (object-address gexp) 16))) | |
71 | ||
72 | (set-record-type-printer! <gexp> write-gexp) | |
73 | ||
21b679f6 LC |
74 | ;; Reference to one of the derivation's outputs, for gexps used in |
75 | ;; derivations. | |
76 | (define-record-type <output-ref> | |
77 | (output-ref name) | |
78 | output-ref? | |
79 | (name output-ref-name)) | |
80 | ||
81 | (define raw-derivation | |
82 | (store-lift derivation)) | |
83 | ||
ada3df03 | 84 | (define (lower-inputs inputs) |
21b679f6 LC |
85 | "Turn any package from INPUTS into a derivation; return the corresponding |
86 | input list as a monadic value." | |
21b679f6 LC |
87 | (with-monad %store-monad |
88 | (sequence %store-monad | |
89 | (map (match-lambda | |
90 | (((? package? package) sub-drv ...) | |
91 | (mlet %store-monad ((drv (package->derivation package))) | |
92 | (return `(,drv ,@sub-drv)))) | |
79c0c8cd LC |
93 | (((? origin? origin) sub-drv ...) |
94 | (mlet %store-monad ((drv (origin->derivation origin))) | |
95 | (return `(,drv ,@sub-drv)))) | |
21b679f6 LC |
96 | (input |
97 | (return input))) | |
98 | inputs)))) | |
99 | ||
100 | (define* (gexp->derivation name exp | |
101 | #:key | |
5d098459 | 102 | system |
21b679f6 LC |
103 | hash hash-algo recursive? |
104 | (env-vars '()) | |
105 | (modules '()) | |
106 | (guile-for-build (%guile-for-build)) | |
107 | references-graphs | |
108 | local-build?) | |
109 | "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a | |
110 | derivation) on SYSTEM. | |
111 | ||
112 | Make MODULES available in the evaluation context of EXP; MODULES is a list of | |
113 | names of Guile modules from the current search path to be copied in the store, | |
114 | compiled, and made available in the load path during the execution of | |
115 | EXP---e.g., '((guix build utils) (guix build gnu-build-system)). | |
116 | ||
117 | The other arguments are as for 'derivation'." | |
118 | (define %modules modules) | |
119 | (define outputs (gexp-outputs exp)) | |
120 | ||
ada3df03 | 121 | (mlet* %store-monad ((inputs (lower-inputs (gexp-inputs exp))) |
5d098459 | 122 | (system -> (or system (%current-system))) |
bfd9eed9 | 123 | (sexp (gexp->sexp exp)) |
21b679f6 LC |
124 | (builder (text-file (string-append name "-builder") |
125 | (object->string sexp))) | |
126 | (modules (if (pair? %modules) | |
127 | (imported-modules %modules | |
128 | #:system system | |
129 | #:guile guile-for-build) | |
130 | (return #f))) | |
131 | (compiled (if (pair? %modules) | |
132 | (compiled-modules %modules | |
133 | #:system system | |
134 | #:guile guile-for-build) | |
135 | (return #f))) | |
136 | (guile (if guile-for-build | |
137 | (return guile-for-build) | |
53e89b17 LC |
138 | (package->derivation (default-guile) |
139 | system)))) | |
21b679f6 LC |
140 | (raw-derivation name |
141 | (string-append (derivation->output-path guile) | |
142 | "/bin/guile") | |
143 | `("--no-auto-compile" | |
144 | ,@(if (pair? %modules) | |
145 | `("-L" ,(derivation->output-path modules) | |
146 | "-C" ,(derivation->output-path compiled)) | |
147 | '()) | |
148 | ,builder) | |
149 | #:outputs outputs | |
150 | #:env-vars env-vars | |
151 | #:system system | |
152 | #:inputs `((,guile) | |
153 | (,builder) | |
154 | ,@(if modules | |
155 | `((,modules) (,compiled) ,@inputs) | |
156 | inputs)) | |
157 | #:hash hash #:hash-algo hash-algo #:recursive? recursive? | |
158 | #:references-graphs references-graphs | |
159 | #:local-build? local-build?))) | |
160 | ||
161 | (define (gexp-inputs exp) | |
162 | "Return the input list for EXP." | |
163 | (define (add-reference-inputs ref result) | |
164 | (match ref | |
165 | (((? derivation?) (? string?)) | |
166 | (cons ref result)) | |
167 | (((? package?) (? string?)) | |
168 | (cons ref result)) | |
79c0c8cd LC |
169 | (((? origin?) (? string?)) |
170 | (cons ref result)) | |
21b679f6 LC |
171 | ((? gexp? exp) |
172 | (append (gexp-inputs exp) result)) | |
173 | (((? string? file)) | |
174 | (if (direct-store-path? file) | |
175 | (cons ref result) | |
176 | result)) | |
177 | ((refs ...) | |
178 | (fold-right add-reference-inputs result refs)) | |
179 | (_ | |
180 | ;; Ignore references to other kinds of objects. | |
181 | result))) | |
182 | ||
183 | (fold-right add-reference-inputs | |
184 | '() | |
185 | (gexp-references exp))) | |
186 | ||
187 | (define (gexp-outputs exp) | |
188 | "Return the outputs referred to by EXP as a list of strings." | |
189 | (define (add-reference-output ref result) | |
190 | (match ref | |
191 | (($ <output-ref> name) | |
192 | (cons name result)) | |
193 | ((? gexp? exp) | |
194 | (append (gexp-outputs exp) result)) | |
195 | (_ | |
196 | result))) | |
197 | ||
198 | (fold-right add-reference-output | |
199 | '() | |
200 | (gexp-references exp))) | |
201 | ||
bfd9eed9 | 202 | (define* (gexp->sexp exp) |
21b679f6 LC |
203 | "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, |
204 | and in the current monad setting (system type, etc.)" | |
205 | (define (reference->sexp ref) | |
206 | (with-monad %store-monad | |
207 | (match ref | |
208 | (((? derivation? drv) (? string? output)) | |
209 | (return (derivation->output-path drv output))) | |
210 | (((? package? p) (? string? output)) | |
211 | (package-file p #:output output)) | |
79c0c8cd LC |
212 | (((? origin? o) (? string? output)) |
213 | (mlet %store-monad ((drv (origin->derivation o))) | |
214 | (return (derivation->output-path drv output)))) | |
21b679f6 | 215 | (($ <output-ref> output) |
bfd9eed9 LC |
216 | ;; Output file names are not known in advance but the daemon defines |
217 | ;; an environment variable for each of them at build time, so use | |
218 | ;; that trick. | |
219 | (return `((@ (guile) getenv) ,output))) | |
21b679f6 | 220 | ((? gexp? exp) |
bfd9eed9 | 221 | (gexp->sexp exp)) |
21b679f6 LC |
222 | (((? string? str)) |
223 | (return (if (direct-store-path? str) str ref))) | |
224 | ((refs ...) | |
225 | (sequence %store-monad (map reference->sexp refs))) | |
226 | (x | |
227 | (return x))))) | |
228 | ||
229 | (mlet %store-monad | |
230 | ((args (sequence %store-monad | |
231 | (map reference->sexp (gexp-references exp))))) | |
232 | (return (apply (gexp-proc exp) args)))) | |
233 | ||
234 | (define (canonicalize-reference ref) | |
235 | "Return a canonical variant of REF, which adds any missing output part in | |
236 | package/derivation references." | |
237 | (match ref | |
238 | ((? package? p) | |
239 | `(,p "out")) | |
79c0c8cd LC |
240 | ((? origin? o) |
241 | `(,o "out")) | |
21b679f6 LC |
242 | ((? derivation? d) |
243 | `(,d "out")) | |
244 | (((? package?) (? string?)) | |
245 | ref) | |
79c0c8cd LC |
246 | (((? origin?) (? string?)) |
247 | ref) | |
21b679f6 LC |
248 | (((? derivation?) (? string?)) |
249 | ref) | |
250 | ((? string? s) | |
251 | (if (direct-store-path? s) `(,s) s)) | |
252 | ((refs ...) | |
253 | (map canonicalize-reference refs)) | |
254 | (x x))) | |
255 | ||
256 | (define (syntax-location-string s) | |
257 | "Return a string representing the source code location of S." | |
258 | (let ((props (syntax-source s))) | |
259 | (if props | |
260 | (let ((file (assoc-ref props 'filename)) | |
261 | (line (and=> (assoc-ref props 'line) 1+)) | |
262 | (column (assoc-ref props 'column))) | |
263 | (if file | |
264 | (simple-format #f "~a:~a:~a" | |
265 | file line column) | |
266 | (simple-format #f "~a:~a" line column))) | |
267 | "<unknown location>"))) | |
268 | ||
269 | (define-syntax gexp | |
270 | (lambda (s) | |
271 | (define (collect-escapes exp) | |
272 | ;; Return all the 'ungexp' present in EXP. | |
273 | (let loop ((exp exp) | |
274 | (result '())) | |
275 | (syntax-case exp (ungexp ungexp-splicing) | |
276 | ((ungexp _) | |
277 | (cons exp result)) | |
278 | ((ungexp _ _) | |
279 | (cons exp result)) | |
280 | ((ungexp-splicing _ ...) | |
281 | (cons exp result)) | |
282 | ((exp0 exp ...) | |
283 | (let ((result (loop #'exp0 result))) | |
284 | (fold loop result #'(exp ...)))) | |
285 | (_ | |
286 | result)))) | |
287 | ||
288 | (define (escape->ref exp) | |
289 | ;; Turn 'ungexp' form EXP into a "reference". | |
290 | (syntax-case exp (ungexp ungexp-splicing output) | |
291 | ((ungexp output) | |
292 | #'(output-ref "out")) | |
293 | ((ungexp output name) | |
294 | #'(output-ref name)) | |
295 | ((ungexp thing) | |
296 | #'thing) | |
297 | ((ungexp drv-or-pkg out) | |
298 | #'(list drv-or-pkg out)) | |
299 | ((ungexp-splicing lst) | |
300 | #'lst))) | |
301 | ||
302 | (define (substitute-references exp substs) | |
303 | ;; Return a variant of EXP where all the cars of SUBSTS have been | |
304 | ;; replaced by the corresponding cdr. | |
305 | (syntax-case exp (ungexp ungexp-splicing) | |
306 | ((ungexp _ ...) | |
307 | (match (assoc exp substs) | |
308 | ((_ id) | |
309 | id) | |
310 | (_ | |
311 | #'(syntax-error "error: no 'ungexp' substitution" | |
312 | #'ref)))) | |
313 | (((ungexp-splicing _ ...) rest ...) | |
314 | (syntax-case exp () | |
315 | ((exp rest ...) | |
316 | (match (assoc #'exp substs) | |
317 | ((_ id) | |
318 | (with-syntax ((id id)) | |
319 | #`(append id | |
320 | #,(substitute-references #'(rest ...) substs)))) | |
321 | (_ | |
322 | #'(syntax-error "error: no 'ungexp-splicing' substitution" | |
323 | #'ref)))))) | |
324 | ((exp0 exp ...) | |
325 | #`(cons #,(substitute-references #'exp0 substs) | |
326 | #,(substitute-references #'(exp ...) substs))) | |
327 | (x #''x))) | |
328 | ||
329 | (syntax-case s (ungexp output) | |
330 | ((_ exp) | |
331 | (let* ((escapes (delete-duplicates (collect-escapes #'exp))) | |
332 | (formals (generate-temporaries escapes)) | |
333 | (sexp (substitute-references #'exp (zip escapes formals))) | |
334 | (refs (map escape->ref escapes))) | |
335 | #`(make-gexp (map canonicalize-reference (list #,@refs)) | |
336 | (lambda #,formals | |
337 | #,sexp))))))) | |
338 | ||
339 | \f | |
340 | ;;; | |
341 | ;;; Convenience procedures. | |
342 | ;;; | |
343 | ||
53e89b17 LC |
344 | (define (default-guile) |
345 | ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) | |
346 | ;; modules directly, to avoid circular dependencies, hence this hack. | |
347 | (module-ref (resolve-interface '(gnu packages base)) | |
348 | 'guile-final)) | |
349 | ||
21b679f6 | 350 | (define* (gexp->script name exp |
53e89b17 | 351 | #:key (modules '()) (guile (default-guile))) |
21b679f6 LC |
352 | "Return an executable script NAME that runs EXP using GUILE with MODULES in |
353 | its search path." | |
354 | (mlet %store-monad ((modules (imported-modules modules)) | |
355 | (compiled (compiled-modules modules))) | |
356 | (gexp->derivation name | |
357 | (gexp | |
358 | (call-with-output-file (ungexp output) | |
359 | (lambda (port) | |
c17b5ab4 LC |
360 | ;; Note: that makes a long shebang. When the store |
361 | ;; is /gnu/store, that fits within the 128-byte | |
362 | ;; limit imposed by Linux, but that may go beyond | |
363 | ;; when running tests. | |
21b679f6 LC |
364 | (format port |
365 | "#!~a/bin/guile --no-auto-compile~%!#~%" | |
366 | (ungexp guile)) | |
367 | (write | |
368 | '(set! %load-path | |
369 | (cons (ungexp modules) %load-path)) | |
370 | port) | |
371 | (write | |
372 | '(set! %load-compiled-path | |
373 | (cons (ungexp compiled) | |
374 | %load-compiled-path)) | |
375 | port) | |
376 | (write '(ungexp exp) port) | |
377 | (chmod port #o555))))))) | |
378 | ||
379 | (define (gexp->file name exp) | |
380 | "Return a derivation that builds a file NAME containing EXP." | |
381 | (gexp->derivation name | |
382 | (gexp | |
383 | (call-with-output-file (ungexp output) | |
384 | (lambda (port) | |
dc254e05 LC |
385 | (write '(ungexp exp) port)))) |
386 | #:local-build? #t)) | |
21b679f6 LC |
387 | |
388 | ||
389 | \f | |
390 | ;;; | |
391 | ;;; Syntactic sugar. | |
392 | ;;; | |
393 | ||
394 | (eval-when (expand load eval) | |
395 | (define (read-ungexp chr port) | |
396 | "Read an 'ungexp' or 'ungexp-splicing' form from PORT." | |
397 | (define unquote-symbol | |
398 | (match (peek-char port) | |
399 | (#\@ | |
400 | (read-char port) | |
401 | 'ungexp-splicing) | |
402 | (_ | |
403 | 'ungexp))) | |
404 | ||
405 | (match (read port) | |
406 | ((? symbol? symbol) | |
407 | (let ((str (symbol->string symbol))) | |
408 | (match (string-index-right str #\:) | |
409 | (#f | |
410 | `(,unquote-symbol ,symbol)) | |
411 | (colon | |
412 | (let ((name (string->symbol (substring str 0 colon))) | |
413 | (output (substring str (+ colon 1)))) | |
414 | `(,unquote-symbol ,name ,output)))))) | |
415 | (x | |
416 | `(,unquote-symbol ,x)))) | |
417 | ||
418 | (define (read-gexp chr port) | |
419 | "Read a 'gexp' form from PORT." | |
420 | `(gexp ,(read port))) | |
421 | ||
422 | ;; Extend the reader | |
423 | (read-hash-extend #\~ read-gexp) | |
424 | (read-hash-extend #\$ read-ungexp)) | |
425 | ||
426 | ;;; gexp.scm ends here |