packages: Factorize things common to `package-{,cross-}derivation'.

* guix/packages.scm (expand-input): New procedure, moved out of...
  (package-derivation): ... here.  Adjust accordingly.
  (package-cross-derivation): Add `cross-system' and `system'
  parameters.
This commit is contained in:
Ludovic Courtès 2013-05-20 23:00:47 +02:00
parent 7046c48d72
commit a63062b55a
1 changed files with 41 additions and 31 deletions

View File

@ -27,6 +27,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:re-export (%current-system) #:re-export (%current-system)
@ -305,41 +306,47 @@ Return the cached result when available."
(#f (#f
(cache package system thunk))))) (cache package system thunk)))))
(define* (package-derivation store package (define* (expand-input store package input system #:optional cross-system)
#:optional (system (%current-system))) "Expand INPUT, an input tuple, such that it contains only references to
"Return the derivation path and corresponding <derivation> object of derivation paths or store paths. PACKAGE is only used to provide contextual
PACKAGE for SYSTEM." information in exceptions."
(define (intern file) (define (intern file)
;; Add FILE to the store. Set the `recursive?' bit to #t, so that ;; Add FILE to the store. Set the `recursive?' bit to #t, so that
;; file permissions are preserved. ;; file permissions are preserved.
(add-to-store store (basename file) #t "sha256" file)) (add-to-store store (basename file) #t "sha256" file))
(define expand-input (define derivation
;; Expand the given input tuple such that it contains only (if cross-system
;; references to derivation paths or store paths. (cut package-cross-derivation store <> cross-system system)
(match-lambda (cut package-derivation store <> system)))
(((? string? name) (? package? package))
(list name (package-derivation store package system)))
(((? string? name) (? package? package)
(? string? sub-drv))
(list name (package-derivation store package system)
sub-drv))
(((? string? name)
(and (? string?) (? derivation-path?) drv))
(list name drv))
(((? 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)))
(((? string? name) (? origin? source))
(list name (package-source-derivation store source system)))
(x
(raise (condition (&package-input-error
(package package)
(input 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)
(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)))
(((? string? name) (? origin? source))
(list name (package-source-derivation store source system)))
(x
(raise (condition (&package-input-error
(package package)
(input x)))))))
(define* (package-derivation store package
#:optional (system (%current-system)))
"Return the derivation path and corresponding <derivation> object of
PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important ;; Compute the derivation and cache the result. Caching is important
;; because some derivations, such as the implicit inputs of the GNU build ;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row. ;; system, will be queried many, many times in a row.
@ -353,7 +360,9 @@ PACKAGE for SYSTEM."
args inputs propagated-inputs native-inputs self-native-input? args inputs propagated-inputs native-inputs self-native-input?
outputs) outputs)
(let* ((inputs (package-transitive-inputs package)) (let* ((inputs (package-transitive-inputs package))
(input-drvs (map expand-input inputs)) (input-drvs (map (cut expand-input
store package <> system)
inputs))
(paths (delete-duplicates (paths (delete-duplicates
(append-map (match-lambda (append-map (match-lambda
((_ (? package? p) _ ...) ((_ (? package? p) _ ...)
@ -371,7 +380,8 @@ PACKAGE for SYSTEM."
#:outputs outputs #:system system #:outputs outputs #:system system
(args)))))))) (args))))))))
(define* (package-cross-derivation store package) (define* (package-cross-derivation store package cross-system
#:optional (system (%current-system)))
;; TODO ;; TODO
#f) #f)