diff options
Diffstat (limited to 'guix/packages.scm')
| -rw-r--r-- | guix/packages.scm | 77 |
1 files changed, 29 insertions, 48 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index 56173e1204..6dc652fe7a 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1174,10 +1174,6 @@ matching package and returns a replacement for that package." ;;; Package derivations. ;;; -(define %derivation-cache - ;; Package to derivation-path mapping. - (make-weak-key-hash-table 100)) - (define (cache! cache package system thunk) "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on SYSTEM." @@ -1209,48 +1205,29 @@ Return the cached result when available." ((_ package system body ...) (cached (=> %derivation-cache) package system body ...)))) -(define* (expand-input store package input system #:optional cross-system) - "Expand INPUT, an input tuple, such that it contains only references to -derivation paths or store paths. PACKAGE is only used to provide contextual -information in exceptions." - (define (intern file) - ;; Add FILE to the store. Set the `recursive?' bit to #t, so that - ;; file permissions are preserved. - (add-to-store store (basename file) #t "sha256" file)) - - (define derivation - (if cross-system - (cut package-cross-derivation store <> cross-system system - #:graft? #f) - (cut package-derivation store <> system #:graft? #f))) +(define* (expand-input package input #:key native?) + "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is +only used to provide contextual information in exceptions." + (define (valid? x) + (or (package? x) (origin? x) (derivation? x))) (match input - (((? string? name) (? package? package)) - (list name (derivation package))) - (((? string? name) (? package? package) - (? string? sub-drv)) - (list name (derivation package) - sub-drv)) - (((? string? name) - (and (? string?) (? derivation-path?) drv)) - (list name drv)) + (((? string? name) (? valid? thing)) + (list name (gexp-input thing #:native? native?))) + (((? string? name) (? valid? thing) (? string? output)) + (list name (gexp-input thing output #:native? native?))) (((? string? name) (and (? string?) (? file-exists? file))) ;; Add FILE to the store. When FILE is in the sub-directory of a ;; store path, it needs to be added anyway, so it can be used as a ;; source. - (list name (intern file))) + (list name (gexp-input (local-file file #:recursive? #t) + #:native? native?))) (((? string? name) (? struct? source)) ;; 'package-source-derivation' calls 'lower-object', which can throw ;; '&gexp-input-error'. However '&gexp-input-error' lacks source - ;; location info, so we catch and rethrow here (XXX: not optimal - ;; performance-wise). - (guard (c ((gexp-input-error? c) - (raise (condition - (&package-input-error - (package package) - (input (gexp-error-invalid-input c))))))) - (list name (package-source-derivation store source system)))) + ;; location info, so we used to catch and rethrow here (FIXME!). + (list name (gexp-input source))) (x (raise (condition (&package-input-error (package package) @@ -1434,12 +1411,14 @@ TARGET." (define (input=? input1 input2) "Return true if INPUT1 and INPUT2 are equivalent." (match input1 - ((label1 drv1 . outputs1) + ((label1 obj1 . outputs1) (match input2 - ((label2 drv2 . outputs2) + ((label2 obj2 . outputs2) (and (string=? label1 label2) (equal? outputs1 outputs2) - (derivation=? drv1 drv2))))))) + (or (and (derivation? obj1) (derivation? obj2) + (derivation=? obj1 obj2)) + (equal? obj1 obj2)))))))) (define* (bag->derivation store bag #:optional context) @@ -1450,7 +1429,7 @@ error reporting." (bag->cross-derivation store bag) (let* ((system (bag-system bag)) (inputs (bag-transitive-inputs bag)) - (input-drvs (map (cut expand-input store context <> system) + (input-drvs (map (cut expand-input context <> #:native? #t) inputs)) (paths (delete-duplicates (append-map (match-lambda @@ -1462,7 +1441,8 @@ error reporting." ;; 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) + ;; TODO: Change to monadic style. + (apply (store-lower (bag-build bag)) store (bag-name bag) (delete-duplicates input-drvs input=?) #:search-paths paths @@ -1477,13 +1457,13 @@ This is an internal procedure." (let* ((system (bag-system bag)) (target (bag-target bag)) (host (bag-transitive-host-inputs bag)) - (host-drvs (map (cut expand-input store context <> system target) + (host-drvs (map (cut expand-input context <> #:native? #f) host)) (target* (bag-transitive-target-inputs bag)) - (target-drvs (map (cut expand-input store context <> system) + (target-drvs (map (cut expand-input context <> #:native? #t) target*)) (build (bag-transitive-build-inputs bag)) - (build-drvs (map (cut expand-input store context <> system) + (build-drvs (map (cut expand-input context <> #:native? #t) build)) (all (append build target* host)) (paths (delete-duplicates @@ -1500,11 +1480,12 @@ This is an internal procedure." (_ '())) all)))) - (apply (bag-build bag) + ;; TODO: Change to monadic style. + (apply (store-lower (bag-build bag)) store (bag-name bag) - #:native-drvs (delete-duplicates build-drvs input=?) - #:target-drvs (delete-duplicates (append host-drvs target-drvs) - input=?) + #:build-inputs (delete-duplicates build-drvs input=?) + #:host-inputs (delete-duplicates host-drvs input=?) + #:target-inputs (delete-duplicates target-drvs input=?) #:search-paths paths #:native-search-paths npaths #:outputs (bag-outputs bag) |