diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | doc/guix.texi | 7 | ||||
| -rw-r--r-- | gnu/packages/bootstrap.scm | 76 | ||||
| -rw-r--r-- | gnu/packages/cross-base.scm | 22 | ||||
| -rw-r--r-- | guix/build-system.scm | 68 | ||||
| -rw-r--r-- | guix/build-system/cmake.scm | 115 | ||||
| -rw-r--r-- | guix/build-system/gnu.scm | 237 | ||||
| -rw-r--r-- | guix/build-system/perl.scm | 75 | ||||
| -rw-r--r-- | guix/build-system/python.scm | 76 | ||||
| -rw-r--r-- | guix/build-system/ruby.scm | 76 | ||||
| -rw-r--r-- | guix/build-system/trivial.scm | 45 | ||||
| -rw-r--r-- | guix/git-download.scm | 4 | ||||
| -rw-r--r-- | guix/packages.scm | 195 | ||||
| -rw-r--r-- | tests/builders.scm | 9 | ||||
| -rw-r--r-- | tests/packages.scm | 15 |
15 files changed, 567 insertions, 455 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index ce7033757d..edc964123f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -17,6 +17,8 @@ (eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'package 'scheme-indent-function 0)) (eval . (put 'origin 'scheme-indent-function 0)) + (eval . (put 'build-system 'scheme-indent-function 0)) + (eval . (put 'bag 'scheme-indent-function 0)) (eval . (put 'operating-system 'scheme-indent-function 0)) (eval . (put 'file-system 'scheme-indent-function 0)) (eval . (put 'manifest-entry 'scheme-indent-function 0)) diff --git a/doc/guix.texi b/doc/guix.texi index c75ca0c2c8..f6357bdaec 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1519,6 +1519,13 @@ Build systems are @code{<build-system>} objects. The interface to create and manipulate them is provided by the @code{(guix build-system)} module, and actual build systems are exported by specific modules. +Under the hood, build systems first compile package objects to +@dfn{bags}. A @dfn{bag} is like a package, but with less +ornamentation---in other words, a bag is a lower-level representation of +a package, which includes all the inputs of that package, including some +that were implicitly added by the build system. This intermediate +representation is then compiled to a derivation (@pxref{Derivations}). + Build systems accept an optional list of @dfn{arguments}. In package definitions, these are passed @i{via} the @code{arguments} field (@pxref{Defining Packages}). They are typically keyword arguments diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index 71ccb19597..efa8cd89eb 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -164,6 +164,46 @@ check whether everything is alright." ;;; Bootstrap packages. ;;; +(define* (raw-build store name inputs + #:key outputs system search-paths + #:allow-other-keys) + (define (->store file) + (add-to-store store file #t "sha256" + (or (search-bootstrap-binary file + system) + (error "bootstrap binary not found" + file system)))) + + (let* ((tar (->store "tar")) + (xz (->store "xz")) + (mkdir (->store "mkdir")) + (bash (->store "bash")) + (guile (->store "guile-2.0.9.tar.xz")) + (builder + (add-text-to-store store + "build-bootstrap-guile.sh" + (format #f " +echo \"unpacking bootstrap Guile to '$out'...\" +~a $out +cd $out +~a -dc < ~a | ~a xv + +# Sanity check. +$out/bin/guile --version~%" + mkdir xz guile tar) + (list mkdir xz guile tar)))) + (derivation store name + bash `(,builder) + #:system system + #:inputs `((,bash) (,builder))))) + +(define* (make-raw-bag name + #:key source inputs native-inputs outputs target) + (bag + (name name) + (build-inputs inputs) + (build raw-build))) + (define %bootstrap-guile ;; The Guile used to run the build scripts of the initial derivations. ;; It is just unpacked from a tarball containing a pre-built binary. @@ -172,39 +212,9 @@ check whether everything is alright." ;; XXX: Would need libc's `libnss_files2.so' for proper `getaddrinfo' ;; support (for /etc/services). (let ((raw (build-system - (name "raw") - (description "Raw build system with direct store access") - (build (lambda* (store name source inputs - #:key outputs system search-paths) - (define (->store file) - (add-to-store store file #t "sha256" - (or (search-bootstrap-binary file - system) - (error "bootstrap binary not found" - file system)))) - - (let* ((tar (->store "tar")) - (xz (->store "xz")) - (mkdir (->store "mkdir")) - (bash (->store "bash")) - (guile (->store "guile-2.0.9.tar.xz")) - (builder - (add-text-to-store store - "build-bootstrap-guile.sh" - (format #f " -echo \"unpacking bootstrap Guile to '$out'...\" -~a $out -cd $out -~a -dc < ~a | ~a xv - -# Sanity check. -$out/bin/guile --version~%" - mkdir xz guile tar) - (list mkdir xz guile tar)))) - (derivation store name - bash `(,builder) - #:system system - #:inputs `((,bash) (,builder))))))))) + (name 'raw) + (description "Raw build system with direct store access") + (lower make-raw-bag)))) (package (name "guile-bootstrap") (version "2.0") diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm index 90fc606d94..46909cb597 100644 --- a/gnu/packages/cross-base.scm +++ b/gnu/packages/cross-base.scm @@ -154,7 +154,7 @@ GCC that does not target a libc; otherwise, target that libc." ;; them from CPATH. (let ((libc (assoc-ref inputs "libc")) (linux (assoc-ref inputs - "libc/cross-linux-headers"))) + "libc/linux-headers"))) (define (cross? x) ;; Return #t if X is a cross-libc or cross Linux. (or (string-prefix? libc x) @@ -224,7 +224,9 @@ XBINUTILS and the cross tool chain." (name (string-append (package-name linux-libre-headers) "-cross-" target)) (arguments - (substitute-keyword-arguments (package-arguments linux-libre-headers) + (substitute-keyword-arguments + `(#:implicit-cross-inputs? #f + ,@(package-arguments linux-libre-headers)) ((#:phases phases) `(alist-replace 'build @@ -243,7 +245,14 @@ XBINUTILS and the cross tool chain." (name (string-append "glibc-cross-" target)) (arguments (substitute-keyword-arguments - `(#:strip-binaries? #f ; disable stripping (see above) + `(;; Disable stripping (see above.) + #:strip-binaries? #f + + ;; This package is used as a target input, but it should not have + ;; the usual cross-compilation inputs since that would include + ;; itself. + #:implicit-cross-inputs? #f + ,@(package-arguments glibc)) ((#:configure-flags flags) `(cons ,(string-append "--host=" target) @@ -252,13 +261,16 @@ XBINUTILS and the cross tool chain." `(alist-cons-before 'configure 'set-cross-linux-headers-path (lambda* (#:key inputs #:allow-other-keys) - (let ((linux (assoc-ref inputs "cross-linux-headers"))) + (let ((linux (assoc-ref inputs "linux-headers"))) (setenv "CROSS_CPATH" (string-append linux "/include")) #t)) ,phases)))) - (propagated-inputs `(("cross-linux-headers" ,xlinux-headers))) + ;; Shadow the native "linux-headers" because glibc's recipe expect the + ;; "linux-headers" input to point to the right thing. + (propagated-inputs `(("linux-headers" ,xlinux-headers))) + (native-inputs `(("cross-gcc" ,xgcc) ("cross-binutils" ,xbinutils) ,@(package-native-inputs glibc))))) diff --git a/guix/build-system.scm b/guix/build-system.scm index c618a5e243..f185d5704f 100644 --- a/guix/build-system.scm +++ b/guix/build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,17 +18,73 @@ (define-module (guix build-system) #:use-module (guix records) + #:use-module (ice-9 match) #:export (build-system build-system? build-system-name build-system-description - build-system-builder - build-system-cross-builder)) + build-system-lower + + bag + bag? + bag-name + bag-build-inputs + bag-host-inputs + bag-target-inputs + bag-outputs + bag-arguments + bag-build + + make-bag)) (define-record-type* <build-system> build-system make-build-system build-system? (name build-system-name) ; symbol (description build-system-description) ; short description - (build build-system-builder) ; (store system name source inputs) - (cross-build build-system-cross-builder ; (store system x-system ...) - (default #f))) + (lower build-system-lower)) ; args ... -> bags + +;; "Bags" are low-level representations of "packages". Here we use +;; build/host/target in the sense of the GNU tool chain (info "(autoconf) +;; Specifying Target Triplets"). +(define-record-type* <bag> bag %make-bag + bag? + (name bag-name) ;string + (build-inputs bag-build-inputs ;list of packages + (default '())) + (host-inputs bag-host-inputs ;list of packages + (default '())) + + ;; "Target inputs" are packages that are built natively, but that are used + ;; by target programs in a cross-compilation environment. Thus, they act + ;; like 'inputs' as far as search paths are concerned. The only example of + ;; that is the cross-libc: it is an input of 'cross-gcc', thus built + ;; natively; yet, we want it to be considered as a target input for the + ;; purposes of $CPATH, $LIBRARY_PATH, etc. + (target-inputs bag-target-inputs + (default '())) + + (outputs bag-outputs ;list of strings + (default '("out"))) + (arguments bag-arguments ;list + (default '())) + (build bag-build)) ;bag -> derivation + +(define* (make-bag build-system name + #:key source (inputs '()) (native-inputs '()) + (outputs '()) (arguments '()) + target) + "Ask BUILD-SYSTEM to return a 'bag' for NAME, with the given SOURCE, +INPUTS, NATIVE-INPUTS, OUTPUTS, and additional ARGUMENTS. If TARGET is not +#f, it must be a string with the GNU triplet of a cross-compilation target. + +This is the mechanism by which a package is \"lowered\" to a bag, which is the +intermediate representation just above derivations." + (match build-system + (($ <build-system> _ description lower) + (apply lower name + #:source source + #:inputs inputs + #:native-inputs native-inputs + #:outputs outputs + #:target target + arguments)))) diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 5e7fba0ac3..0e750c0e11 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -42,44 +42,71 @@ (let ((module (resolve-interface '(gnu packages cmake)))) (module-ref module 'cmake))) -(define* (cmake-build store name source inputs - #:key (guile #f) - (outputs '("out")) (configure-flags ''()) - (search-paths '()) - (make-flags ''()) - (cmake (default-cmake)) - (out-of-source? #t) - (build-type "RelWithDebInfo") - (tests? #t) - (test-target "test") - (parallel-build? #t) (parallel-tests? #f) - (patch-shebangs? #t) - (strip-binaries? #t) - (strip-flags ''("--strip-debug")) - (strip-directories ''("lib" "lib64" "libexec" - "bin" "sbin")) - (phases '(@ (guix build cmake-build-system) - %standard-phases)) - (system (%current-system)) - (imported-modules '((guix build cmake-build-system) - (guix build gnu-build-system) - (guix build utils))) - (modules '((guix build cmake-build-system) - (guix build utils)))) +(define* (lower name + #:key source inputs native-inputs outputs target + (cmake (default-cmake)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:cmake #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("cmake" ,cmake) + ,@native-inputs)) + (outputs outputs) + (build cmake-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (cmake-build store name inputs + #:key (guile #f) + (outputs '("out")) (configure-flags ''()) + (search-paths '()) + (make-flags ''()) + (out-of-source? #t) + (build-type "RelWithDebInfo") + (tests? #t) + (test-target "test") + (parallel-build? #t) (parallel-tests? #f) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (guix build cmake-build-system) + %standard-phases)) + (system (%current-system)) + (imported-modules '((guix build cmake-build-system) + (guix build gnu-build-system) + (guix build utils))) + (modules '((guix build cmake-build-system) + (guix build utils)))) "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." (define builder `(begin (use-modules ,@modules) - (cmake-build #:source ,(if (derivation? source) - (derivation->output-path source) - source) + (cmake-build #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) #:system ,system #:outputs %outputs #:inputs %build-inputs #:search-paths ',(map search-path-specification->sexp - (append search-paths - (standard-search-paths))) + search-paths) #:phases ,phases #:configure-flags ,configure-flags #:make-flags ,make-flags @@ -103,27 +130,17 @@ provides a 'CMakeLists.txt' file as its build system." (guile (module-ref distro 'guile-final))) (package-derivation store guile system))))) - (let ((cmake (package-derivation store cmake system))) - (build-expression->derivation store name builder - #:system system - #:inputs - `(,@(if source - `(("source" ,source)) - '()) - ("cmake" ,cmake) - ,@inputs - - ;; Keep the standard inputs of - ;; `gnu-build-system'. - ,@(standard-inputs system)) - - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build))) + (build-expression->derivation store name builder + #:system system + #:inputs inputs + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) (define cmake-build-system - (build-system (name 'cmake) - (description "The standard CMake build system") - (build cmake-build))) + (build-system + (name 'cmake) + (description "The standard CMake build system") + (lower lower))) ;;; cmake.scm ends here diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 372ad14b71..c58dac10bb 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -23,12 +23,10 @@ #:use-module (guix build-system) #:use-module (guix packages) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-39) #:use-module (ice-9 match) #:export (gnu-build gnu-build-system - standard-search-paths - standard-inputs + standard-packages package-with-explicit-inputs package-with-extra-configure-variable static-libgcc-package @@ -201,10 +199,6 @@ listed in REFS." p)) -(define %store - ;; Store passed to STANDARD-INPUTS. - (make-parameter #f)) - (define (standard-packages) "Return the list of (NAME PACKAGE OUTPUT) or (NAME PACKAGE) tuples of standard packages used as implicit inputs of the GNU build system." @@ -213,53 +207,47 @@ standard packages used as implicit inputs of the GNU build system." (let ((distro (resolve-module '(gnu packages commencement)))) (module-ref distro '%final-inputs))) -(define* (inputs-search-paths inputs - #:optional (package->search-paths - package-native-search-paths)) - "Return the <search-path-specification> objects for INPUTS, using -PACKAGE->SEARCH-PATHS to extract the search path specifications of a package." - (append-map (match-lambda - ((_ (? package? p) _ ...) - (package->search-paths p)) - (_ - '())) - inputs)) - -(define (standard-search-paths) - "Return the list of <search-path-specification> for the standard (implicit) -inputs when doing a native build." - (inputs-search-paths (standard-packages))) - -(define (expand-inputs inputs system) - "Expand INPUTS, which contains <package> objects, so that it contains only -derivations for SYSTEM. Include propagated inputs in the result." - (define input-package->derivation - (match-lambda - ((name pkg sub-drv ...) - (cons* name (package-derivation (%store) pkg system) sub-drv)) - ((name (? derivation-path? path) sub-drv ...) - (cons* name path sub-drv)) - (z - (error "invalid standard input" z)))) - - (map input-package->derivation - (append inputs - (append-map (match-lambda - ((name package _ ...) - (package-transitive-propagated-inputs package))) - inputs)))) - -(define standard-inputs - ;; FIXME: Memoization should be associated with the open store (as for - ;; 'add-text-to-store'), otherwise we get .drv that may not be valid when - ;; switching to another store. - (memoize - (lambda (system) - "Return the list of implicit standard inputs used with the GNU Build -System: GCC, GNU Make, Bash, Coreutils, etc." - (expand-inputs (standard-packages) system)))) - -(define* (gnu-build store name source inputs +(define* (lower name + #:key source inputs native-inputs outputs target + (implicit-inputs? #t) (implicit-cross-inputs? #t) + (strip-binaries? #t) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME from the given arguments." + (define private-keywords + `(#:source #:inputs #:native-inputs #:outputs + #:implicit-inputs? #:implicit-cross-inputs? + ,@(if target '() '(#:target)))) + + (bag + (name name) + (build-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@native-inputs + ,@(if (and target implicit-cross-inputs?) + (standard-cross-packages target 'host) + '()) + ,@(if implicit-inputs? + (standard-packages) + '()))) + (host-inputs inputs) + + ;; The cross-libc is really a target package, but for bootstrapping + ;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a + ;; native package, so it would end up using a "native" variant of + ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages + ;; would use a target variant (built with 'gnu-cross-build'.) + (target-inputs (if (and target implicit-cross-inputs?) + (standard-cross-packages target 'target) + '())) + (outputs (if strip-binaries? + outputs + (delete "debug" outputs))) + (build (if target gnu-cross-build gnu-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) + +(define* (gnu-build store name input-drvs #:key (guile #f) (outputs '("out")) (search-paths '()) @@ -277,7 +265,6 @@ System: GCC, GNU Make, Bash, Coreutils, etc." "bin" "sbin")) (phases '%standard-phases) (system (%current-system)) - (implicit-inputs? #t) ; useful when bootstrapping (imported-modules %default-modules) (modules %default-modules) allowed-references) @@ -295,16 +282,6 @@ which could lead to gratuitous input divergence. ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs are allowed to refer to." - (define implicit-inputs - (and implicit-inputs? - (parameterize ((%store store)) - (standard-inputs system)))) - - (define implicit-search-paths - (if implicit-inputs? - (standard-search-paths) - '())) - (define canonicalize-reference (match-lambda ((? package? p) @@ -318,15 +295,18 @@ are allowed to refer to." (define builder `(begin (use-modules ,@modules) - (gnu-build #:source ,(if (derivation? source) - (derivation->output-path source) - source) + (gnu-build #:source ,(match (assoc-ref input-drvs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) #:system ,system #:outputs %outputs #:inputs %build-inputs #:search-paths ',(map search-path-specification->sexp - (append implicit-search-paths - search-paths)) + search-paths) #:phases ,phases #:configure-flags ,configure-flags #:make-flags ,make-flags @@ -351,17 +331,8 @@ are allowed to refer to." (build-expression->derivation store name builder #:system system - #:inputs - `(,@(if source - `(("source" ,source)) - '()) - ,@inputs - ,@(if implicit-inputs? - implicit-inputs - '())) - #:outputs (if strip-binaries? - outputs - (delete "debug" outputs)) + #:inputs input-drvs + #:outputs outputs #:modules imported-modules #:allowed-references (and allowed-references @@ -388,30 +359,15 @@ is one of `host' or `target'." `(("cross-gcc" ,(gcc target (binutils target) (libc target))) - ("cross-binutils" ,(binutils target)) - ,@(standard-packages))) + ("cross-binutils" ,(binutils target)))) ((target) `(("cross-libc" ,(libc target))))))))) -(define standard-cross-inputs - (memoize - (lambda (system target kind) - "Return the list of implicit standard inputs used with the GNU Build -System when cross-compiling for TARGET: GCC, GNU Make, Bash, Coreutils, etc." - (expand-inputs (standard-cross-packages target kind) system)))) - -(define (standard-cross-search-paths target kind) - "Return the list of <search-path-specification> for the standard (implicit) -inputs." - (inputs-search-paths (append (standard-cross-packages target 'target) - (standard-cross-packages target 'host)) - (case kind - ((host) package-native-search-paths) - ((target) package-search-paths)))) - -(define* (gnu-cross-build store name target source inputs native-inputs +(define* (gnu-cross-build store name #:key + target native-drvs target-drvs (guile #f) + source (outputs '("out")) (search-paths '()) (native-search-paths '()) @@ -429,7 +385,6 @@ inputs." "bin" "sbin")) (phases '%standard-phases) (system (%current-system)) - (implicit-inputs? #t) (imported-modules '((guix build gnu-build-system) (guix build utils))) (modules '((guix build gnu-build-system) @@ -438,27 +393,6 @@ inputs." "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are cross-built inputs, and NATIVE-INPUTS are inputs that run on the build platform." - - (define implicit-host-inputs - (and implicit-inputs? - (parameterize ((%store store)) - (standard-cross-inputs system target 'host)))) - - (define implicit-target-inputs - (and implicit-inputs? - (parameterize ((%store store)) - (standard-cross-inputs system target 'target)))) - - (define implicit-host-search-paths - (if implicit-inputs? - (standard-cross-search-paths target 'host) - '())) - - (define implicit-target-search-paths - (if implicit-inputs? - (standard-cross-search-paths target 'target) - '())) - (define canonicalize-reference (match-lambda ((? package? p) @@ -478,39 +412,39 @@ platform." ',(map (match-lambda ((name (? derivation? drv) sub ...) `(,name . ,(apply derivation->output-path drv sub))) - ((name (? derivation-path? drv-path) sub ...) - `(,name . ,(apply derivation-path->output-path - drv-path sub))) ((name path) `(,name . ,path))) - (append (or implicit-host-inputs '()) native-inputs))) + native-drvs)) (define %build-target-inputs ',(map (match-lambda ((name (? derivation? drv) sub ...) `(,name . ,(apply derivation->output-path drv sub))) - ((name (? derivation-path? drv-path) sub ...) - `(,name . ,(apply derivation-path->output-path - drv-path sub))) + ((name (? package? pkg) sub ...) + (let ((drv (package-cross-derivation store pkg + target system))) + `(,name . ,(apply derivation->output-path drv sub)))) ((name path) `(,name . ,path))) - (append (or implicit-target-inputs '()) inputs))) - - (gnu-build #:source ,(if (derivation? source) - (derivation->output-path source) - source) + target-drvs)) + + (gnu-build #:source ,(match (assoc-ref native-drvs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) #:system ,system #:target ,target #:outputs %outputs #:inputs %build-target-inputs #:native-inputs %build-host-inputs #:search-paths ',(map search-path-specification->sexp - (append implicit-target-search-paths - search-paths)) + search-paths) #:native-search-paths ',(map search-path-specification->sexp - (append implicit-host-search-paths - native-search-paths)) + native-search-paths) #:phases ,phases #:configure-flags ,configure-flags #:make-flags ,make-flags @@ -535,21 +469,8 @@ platform." (build-expression->derivation store name builder #:system system - #:inputs - `(,@(if source - `(("source" ,source)) - '()) - ,@inputs - ,@(if implicit-inputs? - implicit-target-inputs - '()) - ,@native-inputs - ,@(if implicit-inputs? - implicit-host-inputs - '())) - #:outputs (if strip-binaries? - outputs - (delete "debug" outputs)) + #:inputs (append native-drvs target-drvs) + #:outputs outputs #:modules imported-modules #:allowed-references (and allowed-references @@ -558,8 +479,8 @@ platform." #:guile-for-build guile-for-build)) (define gnu-build-system - (build-system (name 'gnu) - (description - "The GNU Build System—i.e., ./configure && make && make install") - (build gnu-build) - (cross-build gnu-cross-build))) + (build-system + (name 'gnu) + (description + "The GNU Build System—i.e., ./configure && make && make install") + (lower lower))) diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 600e597ce8..6cf8cbe13a 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -42,9 +42,33 @@ (let ((module (resolve-interface '(gnu packages perl)))) (module-ref module 'perl))) -(define* (perl-build store name source inputs +(define* (lower name + #:key source inputs native-inputs outputs target + (perl (default-perl)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:perl #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("perl" ,perl) + ,@native-inputs)) + (outputs outputs) + (build perl-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (perl-build store name inputs #:key - (perl (default-perl)) (search-paths '()) (tests? #t) (parallel-build? #t) @@ -62,20 +86,19 @@ (guix build utils)))) "Build SOURCE using PERL, and with INPUTS. This assumes that SOURCE provides a `Makefile.PL' file as its build system." - (define perl-search-paths - (append (package-native-search-paths perl) - (standard-search-paths))) - (define builder `(begin (use-modules ,@modules) (perl-build #:name ,name - #:source ,(if (derivation? source) - (derivation->output-path source) - source) + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) #:search-paths ',(map search-path-specification->sexp - (append perl-search-paths - search-paths)) + search-paths) #:make-maker-flags ,make-maker-flags #:phases ,phases #:system ,system @@ -95,27 +118,17 @@ provides a `Makefile.PL' file as its build system." (guile (module-ref distro 'guile-final))) (package-derivation store guile system))))) - (let ((perl (package-derivation store perl system))) - (build-expression->derivation store name builder - #:system system - #:inputs - `(,@(if source - `(("source" ,source)) - '()) - ("perl" ,perl) - ,@inputs - - ;; Keep the standard inputs of - ;; `gnu-build-system'. - ,@(standard-inputs system)) - - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build))) + (build-expression->derivation store name builder + #:system system + #:inputs inputs + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) (define perl-build-system - (build-system (name 'perl) - (description "The standard Perl build system") - (build perl-build))) + (build-system + (name 'perl) + (description "The standard Perl build system") + (lower lower))) ;;; perl.scm ends here diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index a90e7ff511..e28573bb05 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -92,9 +92,33 @@ prepended to the name." (define package-with-python2 (cut package-with-explicit-python <> (default-python2) "python-" "python2-")) -(define* (python-build store name source inputs +(define* (lower name + #:key source inputs native-inputs outputs target + (python (default-python)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:python #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("python" ,python) + ,@native-inputs)) + (outputs outputs) + (build python-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (python-build store name inputs #:key - (python (default-python)) (tests? #t) (test-target "test") (configure-flags ''()) @@ -111,18 +135,17 @@ prepended to the name." (guix build utils)))) "Build SOURCE using PYTHON, and with INPUTS. This assumes that SOURCE provides a 'setup.py' file as its build system." - - (define python-search-paths - (append (package-native-search-paths python) - (standard-search-paths))) - (define builder `(begin (use-modules ,@modules) (python-build #:name ,name - #:source ,(if (derivation? source) - (derivation->output-path source) - source) + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) #:configure-flags ,configure-flags #:system ,system #:test-target ,test-target @@ -130,8 +153,7 @@ provides a 'setup.py' file as its build system." #:phases ,phases #:outputs %outputs #:search-paths ',(map search-path-specification->sexp - (append python-search-paths - search-paths)) + search-paths) #:inputs %build-inputs))) (define guile-for-build @@ -143,27 +165,17 @@ provides a 'setup.py' file as its build system." (guile (module-ref distro 'guile-final))) (package-derivation store guile system))))) - (let ((python (package-derivation store python system))) - (build-expression->derivation store name builder - #:inputs - `(,@(if source - `(("source" ,source)) - '()) - ("python" ,python) - ,@inputs - - ;; Keep the standard inputs of - ;; 'gnu-build-system'. - ,@(standard-inputs system)) - - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build))) + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) (define python-build-system - (build-system (name 'python) - (description "The standard Python build system") - (build python-build))) + (build-system + (name 'python) + (description "The standard Python build system") + (lower lower))) ;;; python.scm ends here diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 426ca3718c..8312629fd8 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,9 +24,7 @@ #:use-module (guix derivations) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (gnu packages version-control) #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (ruby-build ruby-build-system)) @@ -35,9 +34,33 @@ (let ((ruby (resolve-interface '(gnu packages ruby)))) (module-ref ruby 'ruby))) -(define* (ruby-build store name source inputs +(define* (lower name + #:key source inputs native-inputs outputs target + (ruby (default-ruby)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:ruby #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("ruby" ,ruby) + ,@native-inputs)) + (outputs outputs) + (build ruby-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (ruby-build store name inputs #:key - (ruby (default-ruby)) (test-target "test") (tests? #t) (phases '(@ (guix build ruby-build-system) @@ -52,25 +75,24 @@ (modules '((guix build ruby-build-system) (guix build utils)))) "Build SOURCE using RUBY and INPUTS." - (define ruby-search-paths - (append (package-native-search-paths ruby) - (standard-search-paths))) - (define builder `(begin (use-modules ,@modules) (ruby-build #:name ,name - #:source ,(if (derivation? source) - (derivation->output-path source) - source) + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) #:system ,system #:test-target ,test-target #:tests? ,tests? #:phases ,phases #:outputs %outputs #:search-paths ',(map search-path-specification->sexp - (append ruby-search-paths - search-paths)) + search-paths) #:inputs %build-inputs))) (define guile-for-build @@ -82,25 +104,15 @@ (guile (module-ref distro 'guile-final))) (package-derivation store guile system))))) - (let ((ruby (package-derivation store ruby system)) - (git (package-derivation store git system))) - (build-expression->derivation store name builder - #:inputs - `(,@(if source - `(("source" ,source)) - '()) - ("ruby" ,ruby) - ,@inputs - ;; Keep the standard inputs of - ;; 'gnu-build-system'. - ,@(standard-inputs system)) - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build))) + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) (define ruby-build-system (build-system - (name 'ruby) - (description "The standard Ruby build system") - (build ruby-build))) + (name 'ruby) + (description "The standard Ruby build system") + (lower lower))) diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index 897c5c6152..1b07f14e63 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -34,42 +34,55 @@ (guile (module-ref distro 'guile-final))) (package-derivation store guile system))))) -(define* (trivial-build store name source inputs +(define* (lower name + #:key source inputs native-inputs outputs target + guile builder modules) + "Return a bag for NAME." + (bag + (name name) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs)) + (build-inputs native-inputs) + (outputs outputs) + (build (if target trivial-cross-build trivial-build)) + (arguments `(#:guile ,guile + #:builder ,builder + #:modules ,modules)))) + +(define* (trivial-build store name inputs #:key outputs guile system builder (modules '()) search-paths) "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is ignored." (build-expression->derivation store name builder - #:inputs (if source - `(("source" ,source) ,@inputs) - inputs) + #:inputs inputs #:system system #:outputs outputs #:modules modules #:guile-for-build (guile-for-build store guile system))) -(define* (trivial-cross-build store name target source inputs native-inputs +(define* (trivial-cross-build store name #:key + target native-drvs target-drvs outputs guile system builder (modules '()) search-paths native-search-paths) - "Like `trivial-build', but in a cross-compilation context." + "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is +ignored." (build-expression->derivation store name builder + #:inputs (append native-drvs target-drvs) #:system system - #:inputs - (let ((inputs (append native-inputs inputs))) - (if source - `(("source" ,source) ,@inputs) - inputs)) #:outputs outputs #:modules modules #:guile-for-build (guile-for-build store guile system))) (define trivial-build-system - (build-system (name 'trivial) - (description - "Trivial build system, to run arbitrary Scheme build expressions") - (build trivial-build) - (cross-build trivial-cross-build))) + (build-system + (name 'trivial) + (description + "Trivial build system, to run arbitrary Scheme build expressions") + (lower lower))) diff --git a/guix/git-download.scm b/guix/git-download.scm index a8b7882c9f..b88339bed3 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -21,7 +21,7 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix packages) - #:autoload (guix build-system gnu) (standard-inputs) + #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) #:export (git-reference git-reference? @@ -73,7 +73,7 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if ;; When doing 'git clone --recursive', we need sed, grep, etc. to be ;; available so that 'git submodule' works. (if (git-reference-recursive? ref) - (standard-inputs (%current-system)) + (standard-packages) '())) (define build diff --git a/guix/packages.scm b/guix/packages.scm index 97a2464309..47cd6b95bb 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -92,7 +92,13 @@ package-input-error? package-error-invalid-input &package-cross-build-system-error - package-cross-build-system-error?)) + package-cross-build-system-error? + + package->bag + bag-transitive-inputs + bag-transitive-host-inputs + bag-transitive-build-inputs + bag-transitive-target-inputs)) ;;; Commentary: ;;; @@ -519,6 +525,24 @@ for the host system (\"native inputs\"), and not target inputs." recursively." (transitive-inputs (package-propagated-inputs package))) +(define (bag-transitive-inputs bag) + "Same as 'package-transitive-inputs', but applied to a bag." + (transitive-inputs (append (bag-build-inputs bag) + (bag-host-inputs bag) + (bag-target-inputs bag)))) + +(define (bag-transitive-build-inputs bag) + "Same as 'package-transitive-native-inputs', but applied to a bag." + (transitive-inputs (bag-build-inputs bag))) + +(define (bag-transitive-host-inputs bag) + "Same as 'package-transitive-target-inputs', but applied to a bag." + (transitive-inputs (bag-host-inputs bag))) + +(define (bag-transitive-target-inputs bag) + "Return the \"target inputs\" of BAG, recursively." + (transitive-inputs (bag-target-inputs bag))) + ;;; ;;; Package derivations. @@ -591,6 +615,38 @@ information in exceptions." (package package) (input x))))))) +(define* (package->bag package #:optional + (system (%current-system)) + (target (%current-target-system))) + "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET, +and return it." + ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field + ;; values can refer to it. + (parameterize ((%current-system system) + (%current-target-system target)) + (match package + (($ <package> name version source build-system + args inputs propagated-inputs native-inputs self-native-input? + outputs) + (or (make-bag build-system (package-full-name package) + #:target target + #:source source + #:inputs (append (inputs) + (propagated-inputs)) + #:outputs outputs + #:native-inputs `(,@(if (and target self-native-input?) + `(("self" ,package)) + '()) + ,@(native-inputs)) + #:arguments (args)) + (raise (if target + (condition + (&package-cross-build-system-error + (package package))) + (condition + (&package-error + (package package)))))))))) + (define* (package-derivation store package #:optional (system (%current-system))) "Return the <derivation> object of PACKAGE for SYSTEM." @@ -599,92 +655,69 @@ information in exceptions." ;; because some derivations, such as the implicit inputs of the GNU build ;; system, will be queried many, many times in a row. (cached package system - - ;; Bind %CURRENT-SYSTEM so that thunked field values can refer - ;; to it. - (parameterize ((%current-system system) - (%current-target-system #f)) - (match package - (($ <package> name version source (= build-system-builder builder) - args inputs propagated-inputs native-inputs self-native-input? - outputs) - (let* ((inputs (package-transitive-inputs package)) - (input-drvs (map (cut expand-input - store package <> system) - inputs)) - (paths (delete-duplicates - (append-map (match-lambda - ((_ (? package? p) _ ...) - (package-native-search-paths - p)) - (_ '())) - inputs)))) - - (apply builder - store (package-full-name package) - (and source - (package-source-derivation store source system)) - input-drvs - #:search-paths paths - #:outputs outputs #:system system - (args)))))))) + (let* ((bag (package->bag package system #f)) + (inputs (bag-transitive-inputs bag)) + (input-drvs (map (cut expand-input + store package <> system) + inputs)) + (paths (delete-duplicates + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-native-search-paths + p)) + (_ '())) + inputs)))) + + (apply (bag-build bag) + store (bag-name bag) + input-drvs + #:search-paths paths + #:outputs (bag-outputs bag) #:system system + (bag-arguments bag))))) (define* (package-cross-derivation store package target #:optional (system (%current-system))) "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix system identifying string)." (cached package (cons system target) - - ;; Bind %CURRENT-SYSTEM so that thunked field values can refer - ;; to it. - (parameterize ((%current-system system) - (%current-target-system target)) - (match package - (($ <package> name version source - (= build-system-cross-builder builder) - args inputs propagated-inputs native-inputs self-native-input? - outputs) - (unless builder - (raise (condition - (&package-cross-build-system-error - (package package))))) - - (let* ((inputs (package-transitive-target-inputs package)) - (input-drvs (map (cut expand-input - store package <> - system target) - inputs)) - (host (append (if self-native-input? - `(("self" ,package)) - '()) - (package-transitive-native-inputs package))) - (host-drvs (map (cut expand-input - store package <> system) - host)) - (all (append host inputs)) - (paths (delete-duplicates - (append-map (match-lambda - ((_ (? package? p) _ ...) - (package-search-paths p)) - (_ '())) - all))) - (npaths (delete-duplicates - (append-map (match-lambda - ((_ (? package? p) _ ...) - (package-native-search-paths - p)) - (_ '())) - all)))) - - (apply builder - store (package-full-name package) target - (and source - (package-source-derivation store source system)) - input-drvs host-drvs - #:search-paths paths - #:native-search-paths npaths - #:outputs outputs #:system system - (args)))))))) + (let* ((bag (package->bag package system target)) + (host (bag-transitive-host-inputs bag)) + (host-drvs (map (cut expand-input + store package <> + system target) + host)) + (target* (bag-transitive-target-inputs bag)) + (target-drvs (map (cut expand-input + store package <> system) + target*)) + (build (bag-transitive-build-inputs bag)) + (build-drvs (map (cut expand-input + store package <> system) + build)) + (all (append build target* host)) + (paths (delete-duplicates + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-search-paths p)) + (_ '())) + all))) + (npaths (delete-duplicates + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-native-search-paths + p)) + (_ '())) + all)))) + + (apply (bag-build bag) + store (bag-name bag) + #:native-drvs build-drvs + #:target-drvs (append host-drvs target-drvs) + #:search-paths paths + #:native-search-paths npaths + #:outputs (bag-outputs bag) + #:system system #:target target + (bag-arguments bag))))) (define* (package-output store package #:optional (output "out") (system (%current-system))) diff --git a/tests/builders.scm b/tests/builders.scm index a2f500a94d..579246d04d 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -92,8 +92,7 @@ (valid-path? %store out)))) (test-assert "gnu-build-system" - (and (build-system? gnu-build-system) - (eq? gnu-build (build-system-builder gnu-build-system)))) + (build-system? gnu-build-system)) (unless network-reachable? (test-skip 1)) (test-assert "gnu-build" @@ -102,9 +101,9 @@ "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) (tarball (url-fetch %store url 'sha256 hash #:guile %bootstrap-guile)) - (build (gnu-build %store "hello-2.8" tarball - %bootstrap-inputs - #:implicit-inputs? #f + (build (gnu-build %store "hello-2.8" + `(("source" ,tarball) + ,@%bootstrap-inputs) #:guile %bootstrap-guile #:search-paths %bootstrap-search-paths)) (out (derivation->output-path build))) diff --git a/tests/packages.scm b/tests/packages.scm index 16e65619bc..6deb21c331 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -279,11 +279,16 @@ (test-assert "search paths" (let* ((p (make-prompt-tag "return-search-paths")) (s (build-system - (name "raw") + (name 'raw) (description "Raw build system with direct store access") - (build (lambda* (store name source inputs - #:key outputs system search-paths) - search-paths)))) + (lower (lambda* (name #:key source inputs #:allow-other-keys) + (bag + (name name) + (build-inputs inputs) + (build + (lambda* (store name inputs + #:key outputs system search-paths) + search-paths))))))) (x (list (search-path-specification (variable "GUILE_LOAD_PATH") (directories '("share/guile/site/2.0"))) @@ -326,7 +331,7 @@ (test-assert "package-cross-derivation, no cross builder" (let* ((b (build-system (inherit trivial-build-system) - (cross-build #f))) + (lower (const #f)))) (p (package (inherit (dummy-package "p")) (build-system b)))) (guard (c ((package-cross-build-system-error? c) |