diff options
Diffstat (limited to 'guix/packages.scm')
| -rw-r--r-- | guix/packages.scm | 100 |
1 files changed, 57 insertions, 43 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index 6fa761f569..4caaa9cb79 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -167,6 +168,25 @@ ;;; ;;; Code: +(define-syntax-rule (define-compile-time-decoder name string->bytevector) + "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time +if possible." + (define-syntax name + (lambda (s) + "Return the bytevector corresponding to the given textual +representation." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + ;; A literal string: do the conversion at expansion time. + (with-syntax ((bv (string->bytevector (syntax->datum #'str)))) + #''bv)) + ((_ str) + #'(string->bytevector str)))))) + +(define-compile-time-decoder base32 nix-base32-string->bytevector) +(define-compile-time-decoder base64 base64-decode) + ;; Crytographic content hash. (define-immutable-record-type <content-hash> (%content-hash algorithm value) @@ -302,25 +322,6 @@ specifications to 'hash'." (set-record-type-printer! <origin> print-origin) -(define-syntax-rule (define-compile-time-decoder name string->bytevector) - "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time -if possible." - (define-syntax name - (lambda (s) - "Return the bytevector corresponding to the given textual -representation." - (syntax-case s () - ((_ str) - (string? (syntax->datum #'str)) - ;; A literal string: do the conversion at expansion time. - (with-syntax ((bv (string->bytevector (syntax->datum #'str)))) - #''bv)) - ((_ str) - #'(string->bytevector str)))))) - -(define-compile-time-decoder base32 nix-base32-string->bytevector) -(define-compile-time-decoder base64 base64-decode) - (define (origin-actual-file-name origin) "Return the file name of ORIGIN, either its 'file-name' field or the file name of its URI." @@ -704,6 +705,8 @@ specifies modules in scope when evaluating SNIPPET." (setenv "PATH" (string-append #+xz "/bin" ":" #+decomp "/bin")) + (setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args))) + ;; SOURCE may be either a directory or a tarball. (if (file-is-directory? #+source) (let* ((store (%store-directory)) @@ -725,26 +728,17 @@ specifies modules in scope when evaluating SNIPPET." (for-each apply-patch '#+patches) - (let ((result #+(if snippet - #~(let ((module (make-fresh-user-module))) - (module-use-interfaces! - module - (map resolve-interface '#+modules)) - ((@ (system base compile) compile) - '#+snippet - #:to 'value - #:opts %auto-compilation-options - #:env module)) - #~#t))) - ;; Issue a warning unless the result is #t. - (unless (eqv? result #t) - (format (current-error-port) "\ -## WARNING: the snippet returned `~s'. Return values other than #t -## are deprecated. Please migrate this package so that its snippet -## reports errors by raising an exception, and otherwise returns #t.~%" - result)) - (unless result - (error "snippet returned false"))) + #+(if snippet + #~(let ((module (make-fresh-user-module))) + (module-use-interfaces! + module + (map resolve-interface '#+modules)) + ((@ (system base compile) compile) + '#+snippet + #:to 'value + #:opts %auto-compilation-options + #:env module)) + #~#t) (chdir "..") @@ -1408,6 +1402,22 @@ TARGET." (bag (package->bag package system target))) (bag-grafts store bag))) +(define-inlinable (derivation=? drv1 drv2) + "Return true if DRV1 and DRV2 are equal." + (or (eq? drv1 drv2) + (string=? (derivation-file-name drv1) + (derivation-file-name drv2)))) + +(define (input=? input1 input2) + "Return true if INPUT1 and INPUT2 are equivalent." + (match input1 + ((label1 drv1 . outputs1) + (match input2 + ((label2 drv2 . outputs2) + (and (string=? label1 label2) + (equal? outputs1 outputs2) + (derivation=? drv1 drv2))))))) + (define* (bag->derivation store bag #:optional context) "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be @@ -1426,9 +1436,12 @@ error reporting." p)) (_ '())) inputs)))) - + ;; It's possible that INPUTS contains packages that are not 'eq?' but + ;; that lead to the same derivation. Delete those duplicates to avoid + ;; issues down the road, such as duplicate entries in '%build-inputs'. (apply (bag-build bag) - store (bag-name bag) input-drvs + store (bag-name bag) + (delete-duplicates input-drvs input=?) #:search-paths paths #:outputs (bag-outputs bag) #:system system (bag-arguments bag))))) @@ -1466,8 +1479,9 @@ This is an internal procedure." (apply (bag-build bag) store (bag-name bag) - #:native-drvs build-drvs - #:target-drvs (append host-drvs target-drvs) + #:native-drvs (delete-duplicates build-drvs input=?) + #:target-drvs (delete-duplicates (append host-drvs target-drvs) + input=?) #:search-paths paths #:native-search-paths npaths #:outputs (bag-outputs bag) |