gnu: proot: Install man page under the right name.
[jackhill/guix/guix.git] / guix / packages.scm
CommitLineData
233e7676 1;;; GNU Guix --- Functional package management for GNU
3b0fcc67 2;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
bedba064 3;;; Copyright © 2014, 2015, 2017 Mark H Weaver <mhw@netris.org>
a6d0b306 4;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
8d65c71f 5;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
59d0f067 6;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
e3ce5d70 7;;;
233e7676 8;;; This file is part of GNU Guix.
e3ce5d70 9;;;
233e7676 10;;; GNU Guix is free software; you can redistribute it and/or modify it
e3ce5d70
LC
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
233e7676 15;;; GNU Guix is distributed in the hope that it will be useful, but
e3ce5d70
LC
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
233e7676 21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
e3ce5d70
LC
22
23(define-module (guix packages)
24 #:use-module (guix utils)
c0cd1b3e 25 #:use-module (guix records)
e3ce5d70 26 #:use-module (guix store)
e87f0591 27 #:use-module (guix monads)
ff40e9b7 28 #:use-module (guix gexp)
ddc29a78 29 #:use-module (guix base32)
7adf9b84 30 #:use-module (guix grafts)
d510ab46 31 #:use-module (guix derivations)
c9134e82 32 #:use-module (guix memoization)
e3ce5d70 33 #:use-module (guix build-system)
e89431bf 34 #:use-module (guix search-paths)
c22a1324 35 #:use-module (guix sets)
e3ce5d70 36 #:use-module (ice-9 match)
c37a74bd 37 #:use-module (ice-9 vlist)
062c6927 38 #:use-module (srfi srfi-1)
946b72c9 39 #:use-module (srfi srfi-9 gnu)
05962f29 40 #:use-module (srfi srfi-11)
a63062b5 41 #:use-module (srfi srfi-26)
d36622dc
LC
42 #:use-module (srfi srfi-34)
43 #:use-module (srfi srfi-35)
3b4d0103 44 #:use-module (web uri)
cd52703a 45 #:re-export (%current-system
e89431bf
LC
46 %current-target-system
47 search-path-specification) ;for convenience
ff352cfb 48 #:export (origin
90c68be8
LC
49 origin?
50 origin-uri
51 origin-method
52 origin-sha256
53 origin-file-name
3b4d0103 54 origin-actual-file-name
ac10e0e1
LC
55 origin-patches
56 origin-patch-flags
57 origin-patch-inputs
58 origin-patch-guile
f9cc8971
LC
59 origin-snippet
60 origin-modules
e4c245f8 61 base32
e3ce5d70
LC
62
63 package
64 package?
65 package-name
3b0fcc67 66 package-upstream-name
e3ce5d70 67 package-version
2847050a 68 package-full-name
e3ce5d70
LC
69 package-source
70 package-build-system
71 package-arguments
72 package-inputs
73 package-native-inputs
062c6927 74 package-propagated-inputs
e3ce5d70 75 package-outputs
a18eda27 76 package-native-search-paths
e3ce5d70 77 package-search-paths
05962f29 78 package-replacement
d45122f5 79 package-synopsis
e3ce5d70 80 package-description
e3ce5d70 81 package-license
52bda18a 82 package-home-page
4e097f86 83 package-supported-systems
e3ce5d70 84 package-maintainers
062c6927 85 package-properties
35f3c5f5 86 package-location
6980511b
LC
87 hidden-package
88 hidden-package?
01afdab8
LC
89 package-superseded
90 deprecated-package
d66c7096 91 package-field-location
e3ce5d70 92
f77bcbc3
EB
93 package-direct-sources
94 package-transitive-sources
7d193ec3 95 package-direct-inputs
a3d73f59 96 package-transitive-inputs
9c1edabd
LC
97 package-transitive-target-inputs
98 package-transitive-native-inputs
113aef68 99 package-transitive-propagated-inputs
aa8e0515 100 package-transitive-native-search-paths
7c3c0374 101 package-transitive-supported-systems
f37f2b83 102 package-mapping
2a75b0b6 103 package-input-rewriting
e3ce5d70
LC
104 package-source-derivation
105 package-derivation
d36622dc 106 package-cross-derivation
d510ab46 107 package-output
05962f29 108 package-grafts
bedba064 109 package/inherit
d36622dc 110
a6d0b306
EB
111 transitive-input-references
112
4e097f86 113 %supported-systems
035b6ff7 114 %hurd-systems
abcbda48 115 %hydra-supported-systems
bbceb0ef 116 supported-package?
4e097f86 117
d36622dc 118 &package-error
07783858 119 package-error?
d36622dc
LC
120 package-error-package
121 &package-input-error
07783858 122 package-input-error?
9b222abe
LC
123 package-error-invalid-input
124 &package-cross-build-system-error
0d5a559f
LC
125 package-cross-build-system-error?
126
127 package->bag
d3d337d2 128 bag->derivation
cceab875 129 bag-direct-inputs
0d5a559f
LC
130 bag-transitive-inputs
131 bag-transitive-host-inputs
132 bag-transitive-build-inputs
e87f0591
LC
133 bag-transitive-target-inputs
134
135 default-guile
ff40e9b7 136 default-guile-derivation
e87f0591
LC
137 set-guile-for-build
138 package-file
139 package->derivation
140 package->cross-derivation
141 origin->derivation))
e3ce5d70
LC
142
143;;; Commentary:
144;;;
145;;; This module provides a high-level mechanism to define packages in a
146;;; Guix-based distribution.
147;;;
148;;; Code:
149
90c68be8
LC
150;; The source of a package, such as a tarball URL and fetcher---called
151;; "origin" to avoid name clash with `package-source', `source', etc.
152(define-record-type* <origin>
153 origin make-origin
154 origin?
155 (uri origin-uri) ; string
9b5b5c17 156 (method origin-method) ; procedure
90c68be8 157 (sha256 origin-sha256) ; bytevector
ac10e0e1 158 (file-name origin-file-name (default #f)) ; optional file name
6b1f9721
LC
159
160 ;; Patches are delayed so that the 'search-patch' calls are made lazily,
161 ;; which reduces I/O on startup and allows patch-not-found errors to be
162 ;; gracefully handled at run time.
163 (patches origin-patches ; list of file names
164 (default '()) (delayed))
165
f9cc8971 166 (snippet origin-snippet (default #f)) ; sexp or #f
ac10e0e1
LC
167 (patch-flags origin-patch-flags ; list of strings
168 (default '("-p1")))
1d9bc459
LC
169
170 ;; Patching requires Guile, GNU Patch, and a few more. These two fields are
171 ;; used to specify these dependencies when needed.
ac10e0e1
LC
172 (patch-inputs origin-patch-inputs ; input list or #f
173 (default #f))
f9cc8971
LC
174 (modules origin-modules ; list of module names
175 (default '()))
1929fdba 176
1d9bc459 177 (patch-guile origin-patch-guile ; package or #f
ac10e0e1 178 (default #f)))
e3ce5d70 179
f1096964
LC
180(define (print-origin origin port)
181 "Write a concise representation of ORIGIN to PORT."
182 (match origin
183 (($ <origin> uri method sha256 file-name patches)
184 (simple-format port "#<origin ~s ~a ~s ~a>"
185 uri (bytevector->base32-string sha256)
6b1f9721 186 (force patches)
f1096964
LC
187 (number->string (object-address origin) 16)))))
188
189(set-record-type-printer! <origin> print-origin)
190
e4c245f8
LC
191(define-syntax base32
192 (lambda (s)
193 "Return the bytevector corresponding to the given Nix-base32
194representation."
195 (syntax-case s ()
196 ((_ str)
197 (string? (syntax->datum #'str))
aba326f7 198 ;; A literal string: do the conversion at expansion time.
e4c245f8
LC
199 (with-syntax ((bv (nix-base32-string->bytevector
200 (syntax->datum #'str))))
aba326f7
LC
201 #''bv))
202 ((_ str)
203 #'(nix-base32-string->bytevector str)))))
e4c245f8 204
3b4d0103
EB
205(define (origin-actual-file-name origin)
206 "Return the file name of ORIGIN, either its 'file-name' field or the file
207name of its URI."
208 (define (uri->file-name uri)
209 ;; Return the 'base name' of URI or URI itself, where URI is a string.
210 (let ((path (and=> (string->uri uri) uri-path)))
211 (if path
212 (basename path)
213 uri)))
214
215 (or (origin-file-name origin)
216 (match (origin-uri origin)
217 ((head . tail)
218 (uri->file-name head))
219 ((? string? uri)
220 (uri->file-name uri))
221 (else
222 ;; git, svn, cvs, etc. reference
223 #f))))
224
4e097f86
LC
225(define %supported-systems
226 ;; This is the list of system types that are supported. By default, we
227 ;; expect all packages to build successfully here.
59d0f067 228 '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux"))
4e097f86 229
035b6ff7
LC
230(define %hurd-systems
231 ;; The GNU/Hurd systems for which support is being developed.
232 '("i585-gnu" "i686-gnu"))
233
abcbda48 234(define %hydra-supported-systems
cdb3f734
LC
235 ;; This is the list of system types for which build machines are available.
236 ;;
237 ;; XXX: MIPS is temporarily unavailable on Hydra:
238 ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
59d0f067 239 (fold delete %supported-systems '("aarch64-linux" "mips64el-linux")))
abcbda48
LC
240
241
a18eda27 242;; A package.
e3ce5d70
LC
243(define-record-type* <package>
244 package make-package
245 package?
246 (name package-name) ; string
247 (version package-version) ; string
90c68be8 248 (source package-source) ; <origin> instance
e3ce5d70 249 (build-system package-build-system) ; build system
64fddd74 250 (arguments package-arguments ; arguments for the build method
21c203a5 251 (default '()) (thunked))
062c6927 252
e3ce5d70 253 (inputs package-inputs ; input packages or derivations
dd6b9a37 254 (default '()) (thunked))
062c6927 255 (propagated-inputs package-propagated-inputs ; same, but propagated
9d97a1b3 256 (default '()) (thunked))
e3ce5d70 257 (native-inputs package-native-inputs ; native input packages/derivations
a7dc055b 258 (default '()) (thunked))
c9d01150
LC
259 (self-native-input? package-self-native-input? ; whether to use itself as
260 ; a native input when cross-
261 (default #f)) ; compiling
062c6927 262
e3ce5d70
LC
263 (outputs package-outputs ; list of strings
264 (default '("out")))
a18eda27
LC
265
266 ; lists of
267 ; <search-path-specification>,
268 ; for native and cross
269 ; inputs
270 (native-search-paths package-native-search-paths (default '()))
271 (search-paths package-search-paths (default '()))
05962f29
LC
272 (replacement package-replacement ; package | #f
273 (default #f) (thunked))
e3ce5d70 274
d45122f5
LC
275 (synopsis package-synopsis) ; one-line description
276 (description package-description) ; one or two paragraphs
1fb78cb2 277 (license package-license)
45753b65 278 (home-page package-home-page)
4e097f86
LC
279 (supported-systems package-supported-systems ; list of strings
280 (default %supported-systems))
35f3c5f5 281 (maintainers package-maintainers (default '()))
45753b65 282
062c6927
LC
283 (properties package-properties (default '())) ; alist for anything else
284
35f3c5f5
LC
285 (location package-location
286 (default (and=> (current-source-location)
0004c590
LC
287 source-properties->location))
288 (innate)))
e3ce5d70 289
946b72c9
LC
290(set-record-type-printer! <package>
291 (lambda (package port)
292 (let ((loc (package-location package))
293 (format simple-format))
74e667d1 294 (format port "#<package ~a@~a ~a~a>"
946b72c9
LC
295 (package-name package)
296 (package-version package)
2e1bafb0
LC
297 (if loc
298 (format #f "~a:~a "
299 (location-file loc)
300 (location-line loc))
301 "")
946b72c9
LC
302 (number->string (object-address
303 package)
304 16)))))
305
3b0fcc67
LC
306(define (package-upstream-name package)
307 "Return the upstream name of PACKAGE, which could be different from the name
308it has in Guix."
309 (or (assq-ref (package-properties package) 'upstream-name)
310 (package-name package)))
311
6980511b
LC
312(define (hidden-package p)
313 "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
314user interfaces, ignores."
315 (package
316 (inherit p)
317 (properties `((hidden? . #t)
318 ,@(package-properties p)))))
319
320(define (hidden-package? p)
321 "Return true if P is \"hidden\"--i.e., must not be visible to user
322interfaces."
323 (assoc-ref (package-properties p) 'hidden?))
324
01afdab8
LC
325(define (package-superseded p)
326 "Return the package the supersedes P, or #f if P is still current."
327 (assoc-ref (package-properties p) 'superseded))
328
329(define (deprecated-package old-name p)
330 "Return a package called OLD-NAME and marked as superseded by P, a package
331object."
332 (package
333 (inherit p)
334 (name old-name)
335 (properties `((superseded . ,p)))))
336
d66c7096 337(define (package-field-location package field)
f903dc05
LC
338 "Return the source code location of the definition of FIELD for PACKAGE, or
339#f if it could not be determined."
340 (define (goto port line column)
341 (unless (and (= (port-column port) (- column 1))
342 (= (port-line port) (- line 1)))
343 (unless (eof-object? (read-char port))
344 (goto port line column))))
d66c7096
LC
345
346 (match (package-location package)
347 (($ <location> file line column)
348 (catch 'system
349 (lambda ()
0b8749b7
LC
350 ;; In general we want to keep relative file names for modules.
351 (with-fluids ((%file-port-name-canonicalization 'relative))
352 (call-with-input-file (search-path %load-path file)
353 (lambda (port)
354 (goto port line column)
355 (match (read port)
356 (('package inits ...)
357 (let ((field (assoc field inits)))
358 (match field
359 ((_ value)
360 ;; Put the `or' here, and not in the first argument of
361 ;; `and=>', to work around a compiler bug in 2.0.5.
362 (or (and=> (source-properties value)
363 source-properties->location)
364 (and=> (source-properties field)
365 source-properties->location)))
366 (_
367 #f))))
368 (_
369 #f))))))
d66c7096 370 (lambda _
f903dc05 371 #f)))
d66c7096
LC
372 (_ #f)))
373
d36622dc
LC
374
375;; Error conditions.
376
377(define-condition-type &package-error &error
378 package-error?
379 (package package-error-package))
380
381(define-condition-type &package-input-error &package-error
382 package-input-error?
383 (input package-error-invalid-input))
384
9b222abe
LC
385(define-condition-type &package-cross-build-system-error &package-error
386 package-cross-build-system-error?)
387
d36622dc 388
2847050a
LC
389(define (package-full-name package)
390 "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
391 (string-append (package-name package) "-" (package-version package)))
392
ac10e0e1 393(define (%standard-patch-inputs)
5ae4169c
LC
394 (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
395 'canonical-package))
396 (ref (lambda (module var)
397 (canonical
398 (module-ref (resolve-interface module) var)))))
ac10e0e1
LC
399 `(("tar" ,(ref '(gnu packages base) 'tar))
400 ("xz" ,(ref '(gnu packages compression) 'xz))
401 ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
402 ("gzip" ,(ref '(gnu packages compression) 'gzip))
403 ("lzip" ,(ref '(gnu packages compression) 'lzip))
17287d7d 404 ("unzip" ,(ref '(gnu packages zip) 'unzip))
9cca706c 405 ("patch" ,(ref '(gnu packages base) 'patch))
5ae4169c 406 ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
ac10e0e1 407
1d9bc459 408(define (default-guile)
e87f0591
LC
409 "Return the default Guile package used to run the build code of
410derivations."
bdb36958 411 (let ((distro (resolve-interface '(gnu packages commencement))))
1d9bc459 412 (module-ref distro 'guile-final)))
ac10e0e1 413
ff40e9b7
LC
414(define* (default-guile-derivation #:optional (system (%current-system)))
415 "Return the derivation for SYSTEM of the default Guile package used to run
416the build code of derivation."
417 (package->derivation (default-guile) system
418 #:graft? #f))
419
cf87cc89 420(define* (patch-and-repack source patches
ac10e0e1 421 #:key
a158484d 422 inputs
f9cc8971 423 (snippet #f)
ac10e0e1 424 (flags '("-p1"))
f9cc8971 425 (modules '())
ac10e0e1
LC
426 (guile-for-build (%guile-for-build))
427 (system (%current-system)))
f9cc8971
LC
428 "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
429repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
430it must be an s-expression that will run from within the directory where
1929fdba
LC
431SOURCE was unpacked, after all of PATCHES have been applied. MODULES
432specifies modules in scope when evaluating SNIPPET."
f9cc8971
LC
433 (define source-file-name
434 ;; SOURCE is usually a derivation, but it could be a store file.
435 (if (derivation? source)
436 (derivation->output-path source)
437 source))
438
a158484d
LC
439 (define lookup-input
440 ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
441 ;; so deal with that.
442 (let ((inputs (or inputs (%standard-patch-inputs))))
443 (lambda (name)
444 (match (assoc-ref inputs name)
445 ((package) package)
446 (#f #f)))))
cf87cc89 447
ac10e0e1 448 (define decompression-type
f9cc8971 449 (cond ((string-suffix? "gz" source-file-name) "gzip")
5257ab6d 450 ((string-suffix? "Z" source-file-name) "gzip")
f9cc8971
LC
451 ((string-suffix? "bz2" source-file-name) "bzip2")
452 ((string-suffix? "lz" source-file-name) "lzip")
17287d7d 453 ((string-suffix? "zip" source-file-name) "unzip")
f9cc8971 454 (else "xz")))
ac10e0e1
LC
455
456 (define original-file-name
f9cc8971
LC
457 ;; Remove the store prefix plus the slash, hash, and hyphen.
458 (let* ((sans (string-drop source-file-name
459 (+ (string-length (%store-prefix)) 1)))
460 (dash (string-index sans #\-)))
461 (string-drop sans (+ 1 dash))))
ac10e0e1 462
3ca00bb5
LC
463 (define (numeric-extension? file-name)
464 ;; Return true if FILE-NAME ends with digits.
857ecb3d
LC
465 (and=> (file-extension file-name)
466 (cut string-every char-set:hex-digit <>)))
3ca00bb5
LC
467
468 (define (tarxz-name file-name)
469 ;; Return a '.tar.xz' file name based on FILE-NAME.
470 (let ((base (if (numeric-extension? file-name)
471 original-file-name
472 (file-sans-extension file-name))))
473 (string-append base
474 (if (equal? (file-extension base) "tar")
475 ".xz"
476 ".tar.xz"))))
477
cf87cc89
LC
478 (define instantiate-patch
479 (match-lambda
480 ((? string? patch)
481 (interned-file patch #:recursive? #t))
482 ((? origin? patch)
483 (origin->derivation patch system))))
484
485 (mlet %store-monad ((tar -> (lookup-input "tar"))
486 (xz -> (lookup-input "xz"))
487 (patch -> (lookup-input "patch"))
488 (locales -> (lookup-input "locales"))
489 (decomp -> (lookup-input decompression-type))
490 (patches (sequence %store-monad
491 (map instantiate-patch patches))))
492 (define build
1929fdba
LC
493 (with-imported-modules '((guix build utils))
494 #~(begin
495 (use-modules (ice-9 ftw)
496 (srfi srfi-1)
497 (guix build utils))
498
499 ;; The --sort option was added to GNU tar in version 1.28, released
500 ;; 2014-07-28. During bootstrap we must cope with older versions.
501 (define tar-supports-sort?
502 (zero? (system* (string-append #+tar "/bin/tar")
503 "cf" "/dev/null" "--files-from=/dev/null"
504 "--sort=name")))
505
506 (define (apply-patch patch)
507 (format (current-error-port) "applying '~a'...~%" patch)
508
509 ;; Use '--force' so that patches that do not apply perfectly are
8d65c71f
AK
510 ;; rejected. Use '--no-backup-if-mismatch' to prevent making
511 ;; "*.orig" file if a patch is applied with offset.
1929fdba 512 (zero? (system* (string-append #+patch "/bin/patch")
8d65c71f
AK
513 "--force" "--no-backup-if-mismatch"
514 #+@flags "--input" patch)))
1929fdba
LC
515
516 (define (first-file directory)
517 ;; Return the name of the first file in DIRECTORY.
518 (car (scandir directory
519 (lambda (name)
520 (not (member name '("." "..")))))))
521
522 ;; Encoding/decoding errors shouldn't be silent.
523 (fluid-set! %default-port-conversion-strategy 'error)
524
525 (when #+locales
526 ;; First of all, install a UTF-8 locale so that UTF-8 file names
527 ;; are correctly interpreted. During bootstrap, LOCALES is #f.
528 (setenv "LOCPATH"
529 (string-append #+locales "/lib/locale/"
530 #+(and locales
531 (package-version locales))))
532 (setlocale LC_ALL "en_US.utf8"))
533
534 (setenv "PATH" (string-append #+xz "/bin" ":"
535 #+decomp "/bin"))
536
537 ;; SOURCE may be either a directory or a tarball.
538 (and (if (file-is-directory? #+source)
539 (let* ((store (%store-directory))
540 (len (+ 1 (string-length store)))
541 (base (string-drop #+source len))
542 (dash (string-index base #\-))
543 (directory (string-drop base (+ 1 dash))))
544 (mkdir directory)
545 (copy-recursively #+source directory)
546 #t)
547 #+(if (string=? decompression-type "unzip")
548 #~(zero? (system* "unzip" #+source))
549 #~(zero? (system* (string-append #+tar "/bin/tar")
550 "xvf" #+source))))
551 (let ((directory (first-file ".")))
552 (format (current-error-port)
553 "source is under '~a'~%" directory)
554 (chdir directory)
555
556 (and (every apply-patch '#+patches)
557 #+@(if snippet
558 #~((let ((module (make-fresh-user-module)))
559 (module-use-interfaces!
560 module
561 (map resolve-interface '#+modules))
562 ((@ (system base compile) compile)
563 '#+snippet
564 #:to 'value
565 #:opts %auto-compilation-options
566 #:env module)))
567 #~())
568
569 (begin (chdir "..") #t)
570
571 (unless tar-supports-sort?
572 (call-with-output-file ".file_list"
573 (lambda (port)
574 (for-each (lambda (name)
575 (format port "~a~%" name))
576 (find-files directory
577 #:directories? #t
578 #:fail-on-error? #t)))))
579 (zero? (apply system*
580 (string-append #+tar "/bin/tar")
581 "cvfa" #$output
582 ;; avoid non-determinism in the archive
583 "--mtime=@0"
584 "--owner=root:0"
585 "--group=root:0"
586 (if tar-supports-sort?
587 `("--sort=name"
588 ,directory)
589 '("--no-recursion"
590 "--files-from=.file_list"))))))))))
591
592 (let ((name (tarxz-name original-file-name)))
cf87cc89
LC
593 (gexp->derivation name build
594 #:graft? #f
595 #:system system
cf87cc89 596 #:guile-for-build guile-for-build))))
ac10e0e1 597
113aef68 598(define (transitive-inputs inputs)
161094c8
LC
599 "Return the closure of INPUTS when considering the 'propagated-inputs'
600edges. Omit duplicate inputs, except for those already present in INPUTS
601itself.
602
603This is implemented as a breadth-first traversal such that INPUTS is
604preserved, and only duplicate propagated inputs are removed."
605 (define (seen? seen item outputs)
606 (match (vhash-assq item seen)
607 ((_ . o) (equal? o outputs))
608 (_ #f)))
609
610 (let loop ((inputs inputs)
611 (result '())
612 (propagated '())
613 (first? #t)
614 (seen vlist-null))
a3d73f59
LC
615 (match inputs
616 (()
161094c8
LC
617 (if (null? propagated)
618 (reverse result)
619 (loop (reverse (concatenate propagated)) result '() #f seen)))
620 (((and input (label (? package? package) outputs ...)) rest ...)
621 (if (and (not first?) (seen? seen package outputs))
622 (loop rest result propagated first? seen)
623 (loop rest
624 (cons input result)
625 (cons (package-propagated-inputs package) propagated)
626 first?
627 (vhash-consq package outputs seen))))
a3d73f59 628 ((input rest ...)
161094c8 629 (loop rest (cons input result) propagated first? seen)))))
a3d73f59 630
f77bcbc3
EB
631(define (package-direct-sources package)
632 "Return all source origins associated with PACKAGE; including origins in
633PACKAGE's inputs."
634 `(,@(or (and=> (package-source package) list) '())
635 ,@(filter-map (match-lambda
636 ((_ (? origin? orig) _ ...)
637 orig)
638 (_ #f))
639 (package-direct-inputs package))))
640
641(define (package-transitive-sources package)
642 "Return PACKAGE's direct sources, and their direct sources, recursively."
643 (delete-duplicates
644 (concatenate (filter-map (match-lambda
645 ((_ (? origin? orig) _ ...)
646 (list orig))
647 ((_ (? package? p) _ ...)
648 (package-direct-sources p))
649 (_ #f))
650 (bag-transitive-inputs
651 (package->bag package))))))
652
7d193ec3
EB
653(define (package-direct-inputs package)
654 "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
655with their propagated inputs."
656 (append (package-native-inputs package)
657 (package-inputs package)
658 (package-propagated-inputs package)))
659
113aef68
LC
660(define (package-transitive-inputs package)
661 "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
662with their propagated inputs, recursively."
7d193ec3 663 (transitive-inputs (package-direct-inputs package)))
113aef68 664
9c1edabd
LC
665(define (package-transitive-target-inputs package)
666 "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
667along with their propagated inputs, recursively. This only includes inputs
668for the target system, and not native inputs."
669 (transitive-inputs (append (package-inputs package)
670 (package-propagated-inputs package))))
671
672(define (package-transitive-native-inputs package)
673 "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
674along with their propagated inputs, recursively. This only includes inputs
675for the host system (\"native inputs\"), and not target inputs."
676 (transitive-inputs (package-native-inputs package)))
677
113aef68
LC
678(define (package-transitive-propagated-inputs package)
679 "Return the propagated inputs of PACKAGE, and their propagated inputs,
680recursively."
681 (transitive-inputs (package-propagated-inputs package)))
682
aa8e0515
LC
683(define (package-transitive-native-search-paths package)
684 "Return the list of search paths for PACKAGE and its propagated inputs,
685recursively."
686 (append (package-native-search-paths package)
687 (append-map (match-lambda
688 ((label (? package? p) _ ...)
689 (package-native-search-paths p))
690 (_
691 '()))
692 (package-transitive-propagated-inputs package))))
693
a6d0b306
EB
694(define (transitive-input-references alist inputs)
695 "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
696in INPUTS and their transitive propagated inputs."
697 (define label
698 (match-lambda
699 ((label . _)
700 label)))
701
702 (map (lambda (input)
703 `(assoc-ref ,alist ,(label input)))
704 (transitive-inputs inputs)))
705
c9134e82
LC
706(define package-transitive-supported-systems
707 (mlambdaq (package)
708 "Return the intersection of the systems supported by PACKAGE and those
7c3c0374 709supported by its dependencies."
c9134e82
LC
710 (fold (lambda (input systems)
711 (match input
712 ((label (? package? p) . _)
713 (lset-intersection
714 string=? systems (package-transitive-supported-systems p)))
715 (_
716 systems)))
717 (package-supported-systems package)
718 (bag-direct-inputs (package->bag package)))))
7c3c0374 719
bbceb0ef
LC
720(define* (supported-package? package #:optional (system (%current-system)))
721 "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
722dependencies are known to build on SYSTEM."
723 (member system (package-transitive-supported-systems package)))
724
cceab875
LC
725(define (bag-direct-inputs bag)
726 "Same as 'package-direct-inputs', but applied to a bag."
727 (append (bag-build-inputs bag)
728 (bag-host-inputs bag)
729 (bag-target-inputs bag)))
730
0d5a559f
LC
731(define (bag-transitive-inputs bag)
732 "Same as 'package-transitive-inputs', but applied to a bag."
cceab875 733 (transitive-inputs (bag-direct-inputs bag)))
0d5a559f
LC
734
735(define (bag-transitive-build-inputs bag)
736 "Same as 'package-transitive-native-inputs', but applied to a bag."
737 (transitive-inputs (bag-build-inputs bag)))
738
739(define (bag-transitive-host-inputs bag)
740 "Same as 'package-transitive-target-inputs', but applied to a bag."
741 (transitive-inputs (bag-host-inputs bag)))
742
743(define (bag-transitive-target-inputs bag)
744 "Return the \"target inputs\" of BAG, recursively."
745 (transitive-inputs (bag-target-inputs bag)))
746
f37f2b83
LC
747(define* (package-mapping proc #:optional (cut? (const #f)))
748 "Return a procedure that, given a package, applies PROC to all the packages
749depended on and returns the resulting package. The procedure stops recursion
750when CUT? returns true for a given package."
2a75b0b6
LC
751 (define (rewrite input)
752 (match input
753 ((label (? package? package) outputs ...)
f37f2b83
LC
754 (let ((proc (if (cut? package) proc replace)))
755 (cons* label (proc package) outputs)))
2a75b0b6
LC
756 (_
757 input)))
758
c9134e82
LC
759 (define replace
760 (mlambdaq (p)
f37f2b83
LC
761 ;; Return a variant of P with PROC applied to P and its explicit
762 ;; dependencies, recursively. Memoize the transformations. Failing to
763 ;; do that, we would build a huge object graph with lots of duplicates,
764 ;; which in turns prevents us from benefiting from memoization in
765 ;; 'package-derivation'.
766 (let ((p (proc p)))
767 (package
768 (inherit p)
769 (location (package-location p))
770 (inputs (map rewrite (package-inputs p)))
771 (native-inputs (map rewrite (package-native-inputs p)))
772 (propagated-inputs (map rewrite (package-propagated-inputs p)))))))
2a75b0b6
LC
773
774 replace)
775
f37f2b83
LC
776(define* (package-input-rewriting replacements
777 #:optional (rewrite-name identity))
778 "Return a procedure that, when passed a package, replaces its direct and
779indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
780REPLACEMENTS is a list of package pairs; the first element of each pair is the
781package to replace, and the second one is the replacement.
782
783Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
784package and returns its new name after rewrite."
785 (define (rewrite p)
786 (match (assq-ref replacements p)
787 (#f (package
788 (inherit p)
789 (name (rewrite-name (package-name p)))))
790 (new new)))
791
792 (package-mapping rewrite (cut assq <> replacements)))
793
bedba064
MW
794(define-syntax-rule (package/inherit p overrides ...)
795 "Like (package (inherit P) OVERRIDES ...), except that the same
796transformation is done to the package replacement, if any. P must be a bare
797identifier, and will be bound to either P or its replacement when evaluating
798OVERRIDES."
799 (let loop ((p p))
800 (package (inherit p)
801 overrides ...
802 (replacement (and=> (package-replacement p) loop)))))
803
a2ebaddd
LC
804\f
805;;;
806;;; Package derivations.
807;;;
808
809(define %derivation-cache
810 ;; Package to derivation-path mapping.
e4588af9 811 (make-weak-key-hash-table 100))
a2ebaddd 812
198d84b7
LC
813(define (cache! cache package system thunk)
814 "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
e509d152 815SYSTEM."
bce7526f
LC
816 ;; FIXME: This memoization should be associated with the open store, because
817 ;; otherwise it breaks when switching to a different store.
e509d152
LC
818 (let ((vals (call-with-values thunk list)))
819 ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
820 ;; same value for all structs (as of Guile 2.0.6), and because pointer
821 ;; equality is sufficient in practice.
198d84b7 822 (hashq-set! cache package
8dcec914 823 `((,system ,@vals)
198d84b7 824 ,@(or (hashq-ref cache package) '())))
e509d152
LC
825 (apply values vals)))
826
198d84b7
LC
827(define-syntax cached
828 (syntax-rules (=>)
829 "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
e509d152 830Return the cached result when available."
198d84b7
LC
831 ((_ (=> cache) package system body ...)
832 (let ((thunk (lambda () body ...))
833 (key system))
834 (match (hashq-ref cache package)
835 ((alist (... ...))
836 (match (assoc-ref alist key)
837 ((vals (... ...))
838 (apply values vals))
839 (#f
840 (cache! cache package key thunk))))
e509d152 841 (#f
198d84b7
LC
842 (cache! cache package key thunk)))))
843 ((_ package system body ...)
844 (cached (=> %derivation-cache) package system body ...))))
a2ebaddd 845
a63062b5
LC
846(define* (expand-input store package input system #:optional cross-system)
847 "Expand INPUT, an input tuple, such that it contains only references to
848derivation paths or store paths. PACKAGE is only used to provide contextual
849information in exceptions."
592ef6c8
LC
850 (define (intern file)
851 ;; Add FILE to the store. Set the `recursive?' bit to #t, so that
852 ;; file permissions are preserved.
a9ebd9ef 853 (add-to-store store (basename file) #t "sha256" file))
592ef6c8 854
a63062b5
LC
855 (define derivation
856 (if cross-system
05962f29
LC
857 (cut package-cross-derivation store <> cross-system system
858 #:graft? #f)
859 (cut package-derivation store <> system #:graft? #f)))
a63062b5
LC
860
861 (match input
862 (((? string? name) (? package? package))
863 (list name (derivation package)))
864 (((? string? name) (? package? package)
865 (? string? sub-drv))
866 (list name (derivation package)
867 sub-drv))
868 (((? string? name)
869 (and (? string?) (? derivation-path?) drv))
870 (list name drv))
871 (((? string? name)
872 (and (? string?) (? file-exists? file)))
873 ;; Add FILE to the store. When FILE is in the sub-directory of a
874 ;; store path, it needs to be added anyway, so it can be used as a
875 ;; source.
876 (list name (intern file)))
da675305 877 (((? string? name) (? struct? source))
76c48619
LC
878 ;; 'package-source-derivation' calls 'lower-object', which can throw
879 ;; '&gexp-input-error'. However '&gexp-input-error' lacks source
880 ;; location info, so we catch and rethrow here (XXX: not optimal
881 ;; performance-wise).
882 (guard (c ((gexp-input-error? c)
883 (raise (condition
884 (&package-input-error
885 (package package)
886 (input (gexp-error-invalid-input c)))))))
887 (list name (package-source-derivation store source system))))
a63062b5
LC
888 (x
889 (raise (condition (&package-input-error
890 (package package)
891 (input x)))))))
592ef6c8 892
9775412e
LC
893(define %bag-cache
894 ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
895 ;; It significantly speeds things up when doing repeated calls to
896 ;; 'package->bag' as is the case when building a profile.
897 (make-weak-key-hash-table 200))
898
0d5a559f
LC
899(define* (package->bag package #:optional
900 (system (%current-system))
05962f29
LC
901 (target (%current-target-system))
902 #:key (graft? (%graft?)))
0d5a559f
LC
903 "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
904and return it."
9775412e
LC
905 (cached (=> %bag-cache)
906 package (list system target graft?)
907 ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
908 ;; field values can refer to it.
909 (parameterize ((%current-system system)
910 (%current-target-system target))
911 (match (if graft?
912 (or (package-replacement package) package)
913 package)
914 (($ <package> name version source build-system
915 args inputs propagated-inputs native-inputs
916 self-native-input? outputs)
917 (or (make-bag build-system (string-append name "-" version)
918 #:system system
919 #:target target
920 #:source source
921 #:inputs (append (inputs)
922 (propagated-inputs))
923 #:outputs outputs
924 #:native-inputs `(,@(if (and target
925 self-native-input?)
926 `(("self" ,package))
927 '())
928 ,@(native-inputs))
929 #:arguments (args))
930 (raise (if target
931 (condition
932 (&package-cross-build-system-error
933 (package package)))
934 (condition
935 (&package-error
936 (package package)))))))))))
0d5a559f 937
ced71ac7
LC
938(define %graft-cache
939 ;; 'eq?' cache mapping package objects to a graft corresponding to their
940 ;; replacement package.
941 (make-weak-key-hash-table 200))
942
05962f29 943(define (input-graft store system)
c22a1324
LC
944 "Return a procedure that, given a package with a graft, returns a graft, and
945#f otherwise."
05962f29 946 (match-lambda
c22a1324
LC
947 ((? package? package)
948 (let ((replacement (package-replacement package)))
949 (and replacement
ced71ac7
LC
950 (cached (=> %graft-cache) package system
951 (let ((orig (package-derivation store package system
952 #:graft? #f))
d0025d01
LC
953 (new (package-derivation store replacement system
954 #:graft? #t)))
ced71ac7
LC
955 (graft
956 (origin orig)
957 (replacement new)))))))
c22a1324
LC
958 (x
959 #f)))
05962f29
LC
960
961(define (input-cross-graft store target system)
962 "Same as 'input-graft', but for cross-compilation inputs."
963 (match-lambda
c22a1324 964 ((? package? package)
05962f29
LC
965 (let ((replacement (package-replacement package)))
966 (and replacement
967 (let ((orig (package-cross-derivation store package target system
968 #:graft? #f))
969 (new (package-cross-derivation store replacement
d0025d01
LC
970 target system
971 #:graft? #t)))
05962f29
LC
972 (graft
973 (origin orig)
c22a1324 974 (replacement new))))))
05962f29
LC
975 (_
976 #f)))
977
c22a1324
LC
978(define* (fold-bag-dependencies proc seed bag
979 #:key (native? #t))
980 "Fold PROC over the packages BAG depends on. Each package is visited only
981once, in depth-first order. If NATIVE? is true, restrict to native
982dependencies; otherwise, restrict to target dependencies."
983 (define nodes
984 (match (if native?
985 (append (bag-build-inputs bag)
986 (bag-target-inputs bag)
987 (if (bag-target bag)
988 '()
989 (bag-host-inputs bag)))
990 (bag-host-inputs bag))
991 (((labels things _ ...) ...)
992 things)))
993
994 (let loop ((nodes nodes)
995 (result seed)
996 (visited (setq)))
997 (match nodes
998 (()
999 result)
1000 (((? package? head) . tail)
1001 (if (set-contains? visited head)
1002 (loop tail result visited)
1003 (let ((inputs (bag-direct-inputs (package->bag head))))
1004 (loop (match inputs
1005 (((labels things _ ...) ...)
1006 (append things tail)))
1007 (proc head result)
1008 (set-insert head visited)))))
1009 ((head . tail)
1010 (loop tail result visited)))))
1011
05962f29 1012(define* (bag-grafts store bag)
c22a1324
LC
1013 "Return the list of grafts potentially applicable to BAG. Potentially
1014applicable grafts are collected by looking at direct or indirect dependencies
1015of BAG that have a 'replacement'. Whether a graft is actually applicable
1016depends on whether the outputs of BAG depend on the items the grafts refer
1017to (see 'graft-derivation'.)"
1018 (define system (bag-system bag))
1019 (define target (bag-target bag))
1020
1021 (define native-grafts
1022 (let ((->graft (input-graft store system)))
1023 (fold-bag-dependencies (lambda (package grafts)
1024 (match (->graft package)
1025 (#f grafts)
1026 (graft (cons graft grafts))))
1027 '()
1028 bag)))
1029
1030 (define target-grafts
1031 (if target
1032 (let ((->graft (input-cross-graft store target system)))
1033 (fold-bag-dependencies (lambda (package grafts)
1034 (match (->graft package)
1035 (#f grafts)
1036 (graft (cons graft grafts))))
1037 '()
1038 bag
1039 #:native? #f))
1040 '()))
1041
fcadd9ff
LC
1042 ;; We can end up with several identical grafts if we stumble upon packages
1043 ;; that are not 'eq?' but map to the same derivation (this can happen when
1044 ;; using things like 'package-with-explicit-inputs'.) Hence the
1045 ;; 'delete-duplicates' call.
1046 (delete-duplicates
1047 (append native-grafts target-grafts)))
05962f29
LC
1048
1049(define* (package-grafts store package
1050 #:optional (system (%current-system))
1051 #:key target)
1052 "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
1053TARGET."
1054 (let* ((package (or (package-replacement package) package))
1055 (bag (package->bag package system target)))
1056 (bag-grafts store bag)))
1057
d3d337d2
LC
1058(define* (bag->derivation store bag
1059 #:optional context)
1060 "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
1061a package object describing the context in which the call occurs, for improved
1062error reporting."
1063 (if (bag-target bag)
1064 (bag->cross-derivation store bag)
1065 (let* ((system (bag-system bag))
1066 (inputs (bag-transitive-inputs bag))
1067 (input-drvs (map (cut expand-input store context <> system)
1068 inputs))
1069 (paths (delete-duplicates
1070 (append-map (match-lambda
1071 ((_ (? package? p) _ ...)
1072 (package-native-search-paths
1073 p))
1074 (_ '()))
1075 inputs))))
1076
1077 (apply (bag-build bag)
1078 store (bag-name bag) input-drvs
1079 #:search-paths paths
1080 #:outputs (bag-outputs bag) #:system system
1081 (bag-arguments bag)))))
1082
1083(define* (bag->cross-derivation store bag
1084 #:optional context)
1085 "Return the derivation to build BAG, which is actually a cross build.
1086Optionally, CONTEXT can be a package object denoting the context of the call.
1087This is an internal procedure."
1088 (let* ((system (bag-system bag))
1089 (target (bag-target bag))
1090 (host (bag-transitive-host-inputs bag))
1091 (host-drvs (map (cut expand-input store context <> system target)
1092 host))
1093 (target* (bag-transitive-target-inputs bag))
1094 (target-drvs (map (cut expand-input store context <> system)
1095 target*))
1096 (build (bag-transitive-build-inputs bag))
1097 (build-drvs (map (cut expand-input store context <> system)
1098 build))
1099 (all (append build target* host))
1100 (paths (delete-duplicates
1101 (append-map (match-lambda
1102 ((_ (? package? p) _ ...)
1103 (package-search-paths p))
1104 (_ '()))
1105 all)))
1106 (npaths (delete-duplicates
1107 (append-map (match-lambda
1108 ((_ (? package? p) _ ...)
1109 (package-native-search-paths
1110 p))
1111 (_ '()))
1112 all))))
1113
1114 (apply (bag-build bag)
1115 store (bag-name bag)
1116 #:native-drvs build-drvs
1117 #:target-drvs (append host-drvs target-drvs)
1118 #:search-paths paths
1119 #:native-search-paths npaths
1120 #:outputs (bag-outputs bag)
1121 #:system system #:target target
1122 (bag-arguments bag))))
1123
a63062b5 1124(define* (package-derivation store package
05962f29
LC
1125 #:optional (system (%current-system))
1126 #:key (graft? (%graft?)))
59688fc4
LC
1127 "Return the <derivation> object of PACKAGE for SYSTEM."
1128
e509d152
LC
1129 ;; Compute the derivation and cache the result. Caching is important
1130 ;; because some derivations, such as the implicit inputs of the GNU build
1131 ;; system, will be queried many, many times in a row.
05962f29
LC
1132 (cached package (cons system graft?)
1133 (let* ((bag (package->bag package system #f #:graft? graft?))
1134 (drv (bag->derivation store bag package)))
1135 (if graft?
1136 (match (bag-grafts store bag)
1137 (()
1138 drv)
1139 (grafts
1140 (let ((guile (package-derivation store (default-guile)
1141 system #:graft? #f)))
c22a1324
LC
1142 ;; TODO: As an optimization, we can simply graft the tip
1143 ;; of the derivation graph since 'graft-derivation'
1144 ;; recurses anyway.
b0fef4d6 1145 (graft-derivation store drv grafts
05962f29
LC
1146 #:system system
1147 #:guile guile))))
1148 drv))))
e3ce5d70 1149
9c1edabd 1150(define* (package-cross-derivation store package target
05962f29
LC
1151 #:optional (system (%current-system))
1152 #:key (graft? (%graft?)))
9c1edabd
LC
1153 "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
1154system identifying string)."
05962f29
LC
1155 (cached package (list system target graft?)
1156 (let* ((bag (package->bag package system target #:graft? graft?))
1157 (drv (bag->derivation store bag package)))
1158 (if graft?
1159 (match (bag-grafts store bag)
1160 (()
1161 drv)
1162 (grafts
b0fef4d6 1163 (graft-derivation store drv grafts
05962f29
LC
1164 #:system system
1165 #:guile
1166 (package-derivation store (default-guile)
1167 system #:graft? #f))))
1168 drv))))
d510ab46 1169
de8bcdae
LC
1170(define* (package-output store package
1171 #:optional (output "out") (system (%current-system)))
d510ab46
LC
1172 "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
1173symbolic output name, such as \"out\". Note that this procedure calls
1174`package-derivation', which is costly."
59688fc4
LC
1175 (let ((drv (package-derivation store package system)))
1176 (derivation->output-path drv output)))
e87f0591
LC
1177
1178\f
1179;;;
1180;;; Monadic interface.
1181;;;
1182
1183(define (set-guile-for-build guile)
1184 "This monadic procedure changes the Guile currently used to run the build
1185code of derivations to GUILE, a package object."
1186 (lambda (store)
1187 (let ((guile (package-derivation store guile)))
4e190c28 1188 (values (%guile-for-build guile) store))))
e87f0591
LC
1189
1190(define* (package-file package
1191 #:optional file
1192 #:key
1193 system (output "out") target)
1194 "Return as a monadic value the absolute file name of FILE within the
1195OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the
1196OUTPUT directory of PACKAGE. When TARGET is true, use it as a
1197cross-compilation target triplet."
1198 (lambda (store)
1199 (define compute-derivation
1200 (if target
1201 (cut package-cross-derivation <> <> target <>)
1202 package-derivation))
1203
1204 (let* ((system (or system (%current-system)))
1205 (drv (compute-derivation store package system))
1206 (out (derivation->output-path drv output)))
4e190c28
LC
1207 (values (if file
1208 (string-append out "/" file)
1209 out)
1210 store))))
e87f0591
LC
1211
1212(define package->derivation
1213 (store-lift package-derivation))
1214
1215(define package->cross-derivation
1216 (store-lift package-cross-derivation))
1217
1cdecf24 1218(define-gexp-compiler (package-compiler (package <package>) system target)
ff40e9b7
LC
1219 ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
1220 ;; TARGET. This is used when referring to a package from within a gexp.
1221 (if target
1222 (package->cross-derivation package target system)
1223 (package->derivation package system)))
1224
78951064 1225(define* (origin->derivation origin
f220a838 1226 #:optional (system (%current-system)))
78951064
LC
1227 "Return the derivation corresponding to ORIGIN."
1228 (match origin
6b1f9721 1229 (($ <origin> uri method sha256 name (= force ()) #f)
f220a838
LC
1230 ;; No patches, no snippet: this is a fixed-output derivation.
1231 (method uri 'sha256 sha256 name #:system system))
6b1f9721 1232 (($ <origin> uri method sha256 name (= force (patches ...)) snippet
1929fdba 1233 (flags ...) inputs (modules ...) guile-for-build)
f220a838
LC
1234 ;; Patches and/or a snippet.
1235 (mlet %store-monad ((source (method uri 'sha256 sha256 name
1236 #:system system))
1237 (guile (package->derivation (or guile-for-build
1238 (default-guile))
1239 system
1240 #:graft? #f)))
cf87cc89
LC
1241 (patch-and-repack source patches
1242 #:inputs inputs
1243 #:snippet snippet
1244 #:flags flags
1245 #:system system
1246 #:modules modules
78951064 1247 #:guile-for-build guile)))))
f220a838 1248
1cdecf24 1249(define-gexp-compiler (origin-compiler (origin <origin>) system target)
ff40e9b7
LC
1250 ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring
1251 ;; to an origin from within a gexp.
1252 (origin->derivation origin system))
1253
78951064 1254(define package-source-derivation ;somewhat deprecated
da675305 1255 (let ((lower (store-lower lower-object)))
78951064
LC
1256 (lambda* (store source #:optional (system (%current-system)))
1257 "Return the derivation or file corresponding to SOURCE, which can be an
da675305
LC
1258a file name or any object handled by 'lower-object', such as an <origin>.
1259When SOURCE is a file name, return either the interned file name (if SOURCE is
1260outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
78951064
LC
1261 (match source
1262 ((and (? string?) (? direct-store-path?) file)
1263 file)
1264 ((? string? file)
1265 (add-to-store store (basename file) #t "sha256" file))
1266 (_
1267 (lower store source system))))))