build-system/gnu: Augment `package-with-explicit-inputs' for cross builds.

* guix/build-system/gnu.scm (package-with-explicit-inputs): Add
  `native-inputs' keyword parameter.  Allow INPUTS and NATIVE-INPUTS to
  be thunks.
This commit is contained in:
Ludovic Courtès 2013-06-25 20:54:56 +02:00
parent ac5c1cec86
commit 7e873a6708
1 changed files with 49 additions and 31 deletions

View File

@ -41,42 +41,60 @@
;;
;; Code:
(define* (package-with-explicit-inputs p boot-inputs
(define* (package-with-explicit-inputs p inputs
#:optional
(loc (current-source-location))
#:key guile)
"Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take
BOOT-INPUTS as explicit inputs instead of the implicit default, and
return it. Use GUILE to run the builder, or the distro's final Guile
when GUILE is #f."
(define rewritten-input
(match-lambda
((name (? package? p) sub-drv ...)
(cons* name
(package-with-explicit-inputs p boot-inputs #:guile guile)
sub-drv))
(x x)))
#:key (native-inputs '())
guile)
"Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take INPUTS and
NATIVE-INPUTS as explicit inputs instead of the implicit default, and return
it. INPUTS and NATIVE-INPUTS can be either input lists or thunks; in the
latter case, they will be called in a context where the `%current-system' and
`%current-target-system' are suitably parametrized. Use GUILE to run the
builder, or the distro's final Guile when GUILE is #f."
(define inputs* inputs)
(define native-inputs* native-inputs)
(define boot-input-names
(map car boot-inputs))
(define (call inputs)
(if (procedure? inputs)
(inputs)
inputs))
(define (filtered-inputs inputs)
(fold alist-delete inputs boot-input-names))
(define (duplicate-filter inputs)
(let ((names (match (call inputs)
(((name _ ...) ...)
name))))
(lambda (inputs)
(fold alist-delete inputs names))))
(package (inherit p)
(location (if (pair? loc) (source-properties->location loc) loc))
(arguments
(let ((args (package-arguments p)))
`(#:guile ,guile
#:implicit-inputs? #f ,@args)))
(native-inputs (map rewritten-input
(filtered-inputs (package-native-inputs p))))
(propagated-inputs (map rewritten-input
(filtered-inputs
(package-propagated-inputs p))))
(inputs `(,@boot-inputs
,@(map rewritten-input
(filtered-inputs (package-inputs p)))))))
(let loop ((p p))
(define rewritten-input
(memoize
(match-lambda
((name (? package? p) sub-drv ...)
(cons* name (loop p) sub-drv))
(x x))))
(package (inherit p)
(location (if (pair? loc) (source-properties->location loc) loc))
(arguments
(let ((args (package-arguments p)))
`(#:guile ,guile
#:implicit-inputs? #f
,@args)))
(native-inputs
(let ((filtered (duplicate-filter native-inputs*)))
`(,@(call native-inputs*)
,@(map rewritten-input
(filtered (package-native-inputs p))))))
(propagated-inputs
(map rewritten-input
(package-propagated-inputs p)))
(inputs
(let ((filtered (duplicate-filter inputs*)))
`(,@(call inputs*)
,@(map rewritten-input
(filtered (package-inputs p)))))))))
(define (package-with-extra-configure-variable p variable value)
"Return a version of P with VARIABLE=VALUE specified as an extra `configure'