civodul pushed a commit to branch wip-build-systems-gexp in repository guix.
commit 526ea39e8bb848a1c7cf6949b4768b1a6cf2c10d Author: Ludovic Courtès <[email protected]> Date: Sat Mar 28 19:26:39 2015 +0100 build-system: Rewrite using gexps. * guix/packages.scm (expand-input): Remove 'store', 'system', and 'cross-system' parameters; add #:native?. Rewrite to return name/gexp-input tuples. (bag->derivation): Adjust accordingly. Lower (bag-build bag). (bag->cross-derivation): Ditto. * guix/gexp.scm (with-build-variables): New procedure. * gnu/packages/bootstrap.scm (raw-derivation): New procedure. (raw-build): Turn into a monadic procedure. * gnu/packages/commencement.scm (glibc-final)[arguments]: Use 'gexp-input' for the #:allowed-references argument. * guix/build-system/cmake.scm (cmake-build): Remove 'store' parameter. Switch to the use of gexps and 'gexp->derivation'. (lower): Remove #:source from 'private-keywords'. * guix/build-system/glib-or-gtk.scm (glib-or-gtk-build, lower): Likewise. * guix/build-system/gnu.scm (gnu-build, gnu-cross-build): Likewise, and remove 'canonicalize-reference'. (lower): Likewise. * guix/build-system/perl.scm (perl-build, lower): Likewise. * guix/build-system/python.scm (python-build, lower): Likewise. * guix/build-system/ruby.scm (ruby-build, lower): Likewise. * guix/build-system/waf.scm (waf-build, lower): Likewise. * guix/build-system/trivial.scm (guile-for-build): Remove. (trivial-build): Remove 'store' parameter, change to gexps. (trivial-cross-build): Ditto. * tests/builders.scm ("gnu-build"): Call 'store-lower' on 'gnu-build'. Pass #:source parameter. * tests/packages.scm ("search paths"): Use 'abort-to-prompt' instead of a normal return from the 'build' method. --- .dir-locals.el | 1 + gnu/packages/bootstrap.scm | 110 +++++++++-------- gnu/packages/commencement.scm | 3 +- guix/build-system/cmake.scm | 81 +++++------- guix/build-system/glib-or-gtk.scm | 97 ++++++--------- guix/build-system/gnu.scm | 247 ++++++++++++++----------------------- guix/build-system/perl.scm | 71 +++++------ guix/build-system/python.scm | 68 +++++------ guix/build-system/ruby.scm | 63 ++++------ guix/build-system/trivial.scm | 52 ++++---- guix/build-system/waf.scm | 87 ++++++-------- guix/gexp.scm | 26 ++++ guix/packages.scm | 57 ++++----- tests/builders.scm | 10 +- tests/packages.scm | 6 +- 15 files changed, 428 insertions(+), 551 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index 54d5bda..fa6defb 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -58,6 +58,7 @@ (eval . (put 'run-with-store 'scheme-indent-function 1)) (eval . (put 'run-with-state 'scheme-indent-function 1)) (eval . (put 'wrap-program 'scheme-indent-function 1)) + (eval . (put 'with-build-variables 'scheme-indent-function 2)) (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index 028bc2a..ec4f91c 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -25,8 +25,10 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix build-system trivial) - #:use-module ((guix store) #:select (add-to-store add-text-to-store)) + #:use-module ((guix store) + #:select (%store-monad interned-file text-file store-lift)) #:use-module ((guix derivations) #:select (derivation)) + #:use-module (guix monads) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -179,56 +181,60 @@ successful, or false to signal an error." ;;; Bootstrap packages. ;;; -(define* (raw-build store name inputs +(define raw-derivation ;TODO: factorize + (store-lift derivation)) + +(define* (raw-build 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 (match system - ("armhf-linux" - "guile-2.0.11.tar.xz") - (_ - "guile-2.0.9.tar.xz")))) - ;; The following code, run by the bootstrap guile after it is - ;; unpacked, creates a wrapper for itself to set its load path. - ;; This replaces the previous non-portable method based on - ;; reading the /proc/self/exe symlink. - (make-guile-wrapper - '(begin - (use-modules (ice-9 match)) - (match (command-line) - ((_ out bash) - (let ((bin-dir (string-append out "/bin")) - (guile (string-append out "/bin/guile")) - (guile-real (string-append out "/bin/.guile-real")) - ;; We must avoid using a bare dollar sign in this code, - ;; because it would be interpreted by the shell. - (dollar (string (integer->char 36)))) - (chmod bin-dir #o755) - (rename-file guile guile-real) - (call-with-output-file guile - (lambda (p) - (format p "\ + (interned-file (or (search-bootstrap-binary file system) + (error "bootstrap binary not found" + file system)) + file + #:recursive? #t)) + + (define (make-guile-wrapper bash guile-real) + ;; The following code, run by the bootstrap guile after it is unpacked, + ;; creates a wrapper for itself to set its load path. This replaces the + ;; previous non-portable method based on reading the /proc/self/exe + ;; symlink. + '(begin + (use-modules (ice-9 match)) + (match (command-line) + ((_ out bash) + (let ((bin-dir (string-append out "/bin")) + (guile (string-append out "/bin/guile")) + (guile-real (string-append out "/bin/.guile-real")) + ;; We must avoid using a bare dollar sign in this code, + ;; because it would be interpreted by the shell. + (dollar (string (integer->char 36)))) + (chmod bin-dir #o755) + (rename-file guile guile-real) + (call-with-output-file guile + (lambda (p) + (format p "\ #!~a export GUILE_SYSTEM_PATH=~a/share/guile/2.0 export GUILE_SYSTEM_COMPILED_PATH=~a/lib/guile/2.0/ccache exec -a \"~a0\" ~a \"~a@\"\n" - bash out out dollar guile-real dollar))) - (chmod guile #o555) - (chmod bin-dir #o555)))))) - (builder - (add-text-to-store store - "build-bootstrap-guile.sh" - (format #f " + bash out out dollar guile-real dollar))) + (chmod guile #o555) + (chmod bin-dir #o555)))))) + + (mlet* %store-monad ((tar (->store "tar")) + (xz (->store "xz")) + (mkdir (->store "mkdir")) + (bash (->store "bash")) + (guile (->store (match system + ("armhf-linux" + "guile-2.0.11.tar.xz") + (_ + "guile-2.0.9.tar.xz")))) + (wrapper -> (make-guile-wrapper bash guile)) + (builder + (text-file "build-bootstrap-guile.sh" + (format #f " echo \"unpacking bootstrap Guile to '$out'...\" ~a $out cd $out @@ -241,14 +247,14 @@ $out/bin/guile -c ~s $out ~a # Sanity check. $out/bin/guile --version~%" - mkdir xz guile tar - (format #f "~s" make-guile-wrapper) - bash) - (list mkdir xz guile tar bash)))) - (derivation store name - bash `(,builder) - #:system system - #:inputs `((,bash) (,builder))))) + mkdir xz guile tar + (object->string wrapper) + bash) + (list mkdir xz guile tar)))) + (raw-derivation name + bash `(,builder) + #:system system + #:inputs `((,bash) (,builder))))) (define* (make-raw-bag name #:key source inputs native-inputs outputs diff --git a/gnu/packages/commencement.scm b/gnu/packages/commencement.scm index caadc94..6683ac3 100644 --- a/gnu/packages/commencement.scm +++ b/gnu/packages/commencement.scm @@ -38,6 +38,7 @@ #:use-module (gnu packages linux) #:use-module (gnu packages texinfo) #:use-module (gnu packages pkg-config) + #:use-module (guix gexp) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix build-system gnu) @@ -488,7 +489,7 @@ exec ~a/bin/~a-~a -B~a/lib -Wl,-dynamic-linker -Wl,~a/~a \"$@\"~%" ;; if 'allowed-references' were per-output. (arguments `(#:allowed-references - ,(cons* `(,gcc-boot0 "lib") (linux-libre-headers-boot0) + ,(cons* (gexp-input gcc-boot0 "lib") (linux-libre-headers-boot0) static-bash-for-glibc (package-outputs glibc-final-with-bootstrap-bash)) diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 25ac262..dd3b12e 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -19,7 +19,9 @@ (define-module (guix build-system cmake) #:use-module (guix store) + #:use-module (guix gexp) #:use-module (guix utils) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -56,7 +58,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:cmake #:inputs #:native-inputs)) + '(#:target #:cmake #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -75,8 +77,8 @@ (build cmake-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (cmake-build store name inputs - #:key (guile #f) +(define* (cmake-build name inputs + #:key guile source (outputs '("out")) (configure-flags ''()) (search-paths '()) (make-flags ''()) @@ -99,51 +101,38 @@ (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 ,(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 - search-paths) - #:phases ,phases - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:build-type ,build-type - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (define build + #~(begin + (use-modules ,@modules) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(cmake-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:phases #$phases + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:build-type #$build-type + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories)))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:modules imported-modules + #:guile-for-build guile))) (define cmake-build-system (build-system diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index a1f0a9b..7828a21 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -21,6 +21,8 @@ (define-module (guix build-system glib-or-gtk) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -96,7 +98,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:glib #:gtk+ #:inputs #:native-inputs + '(#:target #:glib #:gtk+ #:inputs #:native-inputs #:outputs #:implicit-inputs?)) (and (not target) ;XXX: no cross-compilation @@ -117,8 +119,8 @@ (build glib-or-gtk-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (glib-or-gtk-build store name inputs - #:key (guile #f) +(define* (glib-or-gtk-build name inputs + #:key guile source (outputs '("out")) (search-paths '()) (configure-flags ''()) @@ -142,66 +144,41 @@ (modules %default-modules) allowed-references) "Build SOURCE with INPUTS. See GNU-BUILD for more details." - (define canonicalize-reference - (match-lambda - ((? package? p) - (derivation->output-path (package-derivation store p system))) - (((? package? p) output) - (derivation->output-path (package-derivation store p system) - output)) - ((? string? output) - output))) + (define build + #~(begin + (use-modules #$modules) - (define builder - `(begin - (use-modules ,@modules) - (glib-or-gtk-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 - search-paths) - #:phases ,phases - #:glib-or-gtk-wrap-excluded-outputs - ,glib-or-gtk-wrap-excluded-outputs - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + #$(with-build-variables inputs outputs + #~(glib-or-gtk-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:phases #$phases + #:glib-or-gtk-wrap-excluded-outputs + #$glib-or-gtk-wrap-excluded-outputs + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories)))) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:modules imported-modules + #:allowed-references allowed-references + #:guile-for-build guile))) (define glib-or-gtk-build-system (build-system diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 1f30244..8ba3598 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -19,6 +19,8 @@ (define-module (guix build-system gnu) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -236,7 +238,7 @@ standard packages used as implicit inputs of the GNU build system." #:rest arguments) "Return a bag for NAME from the given arguments." (define private-keywords - `(#:source #:inputs #:native-inputs #:outputs + `(#:inputs #:native-inputs #:outputs #:implicit-inputs? #:implicit-cross-inputs? ,@(if target '() '(#:target)))) @@ -269,8 +271,8 @@ standard packages used as implicit inputs of the GNU build system." (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) +(define* (gnu-build name inputs + #:key guile source (outputs '("out")) (search-paths '()) (configure-flags ''()) @@ -311,71 +313,40 @@ returned derivations, or whether they should always build it locally. ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs are allowed to refer to." - (define canonicalize-reference - (match-lambda - ((? package? p) - (derivation->output-path (package-derivation store p system - #:graft? #f))) - (((? package? p) output) - (derivation->output-path (package-derivation store p system - #:graft? #f) - output)) - ((? string? output) - output))) - (define builder - `(begin - (use-modules ,@modules) - (gnu-build #:source ,(match (assoc-ref input-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:build ,build - #:outputs %outputs - #:inputs %build-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:locale ,locale - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:validate-runpath? ,validate-runpath? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) - - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system - #:graft? #f))))) - - (build-expression->derivation store name builder - #:system system - #:inputs input-drvs - #:outputs outputs - #:modules imported-modules - #:substitutable? substitutable? - - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:guile-for-build guile-for-build)) + #~(begin + (use-modules #$@modules) + + #$(with-build-variables inputs outputs + #~(gnu-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:phases #$phases + #:locale #$locale + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:patch-shebangs? #$patch-shebangs? + #:validate-runpath? #$validate-runpath? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories)))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:modules imported-modules + #:substitutable? substitutable? + #:allowed-references allowed-references + #:guile-for-build guile))) ;;; @@ -400,11 +371,10 @@ is one of `host' or `target'." ((target) `(("cross-libc" ,(libc target))))))))) -(define* (gnu-cross-build store name +(define* (gnu-cross-build name #:key target native-drvs target-drvs - (guile #f) - source + guile source (outputs '("out")) (search-paths '()) (native-search-paths '()) @@ -432,95 +402,62 @@ is one of `host' or `target'." "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 canonicalize-reference - (match-lambda - ((? package? p) - (derivation->output-path (package-cross-derivation store p system))) - (((? package? p) output) - (derivation->output-path (package-cross-derivation store p system) - output)) - ((? string? output) - output))) - (define builder - `(begin - (use-modules ,@modules) - - (let () - (define %build-host-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv sub))) - ((name path) - `(,name . ,path))) - native-drvs)) - - (define %build-target-inputs - ',(map (match-lambda - ((name (? derivation? drv) sub ...) - `(,name . ,(apply derivation->output-path drv 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))) - target-drvs)) - - (gnu-build #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:build ,build - #:target ,target - #:outputs %outputs - #:inputs %build-target-inputs - #:native-inputs %build-host-inputs - #:search-paths ',(map search-path-specification->sexp + #~(begin + (use-modules #$@modules) + + (define %build-host-inputs + (map (lambda (tuple) + (apply cons tuple)) + '#+native-drvs)) + + (define %build-target-inputs + (map (lambda (tuple) + (apply cons tuple)) + '#$target-drvs)) + + (define %outputs + (list #$@(map (lambda (name) + #~(cons #$name + (ungexp output name))) + outputs))) + + (gnu-build #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(map search-path-specification->sexp search-paths) - #:native-search-paths ',(map + #:native-search-paths '#$(map search-path-specification->sexp native-search-paths) - #:phases ,phases - #:locale ,locale - #:configure-flags ,configure-flags - #:make-flags ,make-flags - #:out-of-source? ,out-of-source? - #:tests? ,tests? - #:test-target ,test-target - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:validate-runpath? ,validate-runpath? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories)))) - - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:system system - #:inputs (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:substitutable? substitutable? - - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:guile-for-build guile-for-build)) + #:phases #$phases + #:locale #$locale + #:configure-flags #$configure-flags + #:make-flags #$make-flags + #:out-of-source? #$out-of-source? + #:tests? #$tests? + #:test-target #$test-target + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:patch-shebangs? #$patch-shebangs? + #:validate-runpath? #$validate-runpath? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:modules imported-modules + #:substitutable? substitutable? + #:allowed-references allowed-references + #:guile-for-build guile))) (define gnu-build-system (build-system diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 06af1dd..be0b54d 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -19,6 +19,8 @@ (define-module (guix build-system perl) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -57,7 +59,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:perl #:inputs #:native-inputs)) + '(#:target #:perl #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -76,8 +78,8 @@ (build perl-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (perl-build store name inputs - #:key +(define* (perl-build name inputs + #:key source (search-paths '()) (tests? #t) (parallel-build? #t) @@ -95,46 +97,33 @@ (guix build utils)))) "Build SOURCE using PERL, and with INPUTS. This assumes that SOURCE provides a `Makefile.PL' file as its build system." - (define builder - `(begin - (use-modules ,@modules) - (perl-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:make-maker? ,make-maker? - #:make-maker-flags ,make-maker-flags - #:module-build-flags ,module-build-flags - #:phases ,phases - #:system ,system - #:test-target "test" - #:tests? ,tests? - #:parallel-build? ,parallel-build? - #:parallel-tests? ,parallel-tests? - #:outputs %outputs - #:inputs %build-inputs))) + (define build + #~(begin + (use-modules #$@modules) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(perl-build #:name #$name + #:source #+source + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:make-maker? #$make-maker? + #:make-maker-flags #$make-maker-flags + #:module-build-flags #$module-build-flags + #:phases #$phases + #:system #$system + #:test-target "test" + #:tests? #$tests? + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:outputs %outputs + #:inputs %build-inputs)))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:modules imported-modules + #:guile-for-build guile))) (define perl-build-system (build-system diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index e9fffcc..ec2daec 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -21,6 +21,8 @@ (define-module (guix build-system python) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) @@ -109,7 +111,7 @@ prepended to the name." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:python #:inputs #:native-inputs)) + '(#:target #:python #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -128,8 +130,8 @@ prepended to the name." (build python-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (python-build store name inputs - #:key +(define* (python-build name inputs + #:key source (tests? #t) (test-target "test") (configure-flags ''()) @@ -144,42 +146,30 @@ 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 builder - `(begin - (use-modules ,@modules) - (python-build #:name ,name - #: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 - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) - - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (define build + #~(begin + (use-modules #$@modules) + + #$(with-build-variables inputs outputs + #~(python-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:phases #$phases + #:outputs %outputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs)))) + + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:modules imported-modules + #:guile-for-build guile))) (define python-build-system (build-system diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 8142e85..a0e7a59 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -20,6 +20,8 @@ (define-module (guix build-system ruby) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) @@ -54,7 +56,7 @@ NAME and VERSION." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:ruby #:inputs #:native-inputs)) + '(#:target #:ruby #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -73,8 +75,8 @@ NAME and VERSION." (build ruby-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (ruby-build store name inputs - #:key +(define* (ruby-build name inputs + #:key source (gem-flags ''()) (test-target "test") (tests? #t) @@ -88,42 +90,29 @@ NAME and VERSION." (modules '((guix build ruby-build-system) (guix build utils)))) "Build SOURCE using RUBY and INPUTS." - (define builder - `(begin - (use-modules ,@modules) - (ruby-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:gem-flags ,gem-flags - #:test-target ,test-target - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (define build + #~(begin + (use-modules #$@modules) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(ruby-build #:name #$name + #:source #+source + #:system #$system + #:gem-flags #$gem-flags + #:test-target #$test-target + #:tests? #$tests? + #:phases #$phases + #:outputs %outputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs)))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:modules imported-modules + #:guile-for-build guile))) (define ruby-build-system (build-system diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index 350b1df..ff2fd7b 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <[email protected]> +;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,21 +19,13 @@ (define-module (guix build-system trivial) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix build-system) #:use-module (ice-9 match) #:export (trivial-build-system)) -(define (guile-for-build store guile system) - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) - (define* (lower name #:key source inputs native-inputs outputs system target guile builder modules) @@ -53,34 +45,38 @@ #:builder ,builder #:modules ,modules)))) -(define* (trivial-build store name inputs +(define* (trivial-build name inputs #:key - outputs guile system builder (modules '()) + 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 inputs - #:system system - #:outputs outputs - #:modules modules - #:guile-for-build - (guile-for-build store guile system))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name (with-build-variables inputs outputs builder) + #:system system + #:target #f + #:modules modules + #:guile-for-build guile))) -(define* (trivial-cross-build store name +(define* (trivial-cross-build name #:key target native-drvs target-drvs outputs guile system builder (modules '()) search-paths native-search-paths) "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 - #:outputs outputs - #:modules modules - #:guile-for-build - (guile-for-build store guile system))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name (with-build-variables + (append native-drvs target-drvs) + outputs + builder) + #:system system + #:target target + #:modules modules + #:guile-for-build guile))) (define trivial-build-system (build-system diff --git a/guix/build-system/waf.scm b/guix/build-system/waf.scm index 044d2a0..62cbc4c 100644 --- a/guix/build-system/waf.scm +++ b/guix/build-system/waf.scm @@ -19,6 +19,8 @@ (define-module (guix build-system waf) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) @@ -52,7 +54,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:python #:inputs #:native-inputs)) + '(#:target #:python #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -71,58 +73,45 @@ (build waf-build) ; only change compared to 'lower' in python.scm (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (waf-build store name inputs - #:key - (tests? #t) - (test-target "check") - (configure-flags ''()) - (phases '(@ (guix build waf-build-system) - %standard-phases)) - (outputs '("out")) - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %waf-build-system-modules) - (modules '((guix build waf-build-system) - (guix build utils)))) +(define* (waf-build name inputs + #:key source + (tests? #t) + (test-target "check") + (configure-flags ''()) + (phases '(@ (guix build waf-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %waf-build-system-modules) + (modules '((guix build waf-build-system) + (guix build utils)))) "Build SOURCE with INPUTS. This assumes that SOURCE provides a 'waf' file as its build system." - (define builder - `(begin - (use-modules ,@modules) - (waf-build #:name ,name - #: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 - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (define build + #~(begin + (use-modules #$@modules) - (define guile-for-build - (match guile - ((? package?) - (package-derivation store guile system #:graft? #f)) - (#f ; the default - (let* ((distro (resolve-interface '(gnu packages commencement))) - (guile (module-ref distro 'guile-final))) - (package-derivation store guile system #:graft? #f))))) + #$(with-build-variables inputs outputs + #~(waf-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:phases #$phases + #:outputs %outputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs)))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:modules imported-modules + #:guile-for-build guile))) (define waf-build-system (build-system diff --git a/guix/gexp.scm b/guix/gexp.scm index de49fef..418a9ff 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -47,6 +47,8 @@ gexp->file gexp->script text-file* + with-build-variables + imported-files imported-modules compiled-modules @@ -851,6 +853,30 @@ they can refer to each other." (module-ref (resolve-interface '(gnu packages commencement)) 'guile-final)) +(define (with-build-variables inputs outputs body) + "Return a gexp that surrounds BODY with a definition of the legacy +'%build-inputs', '%outputs', and '%output' variables based on INPUTS, a list +of name/gexp-input tuples, and OUTPUTS, a list of strings." + + ;; These two variables are defined for backward compatibility. They are + ;; used by package expressions. These must be top-level defines so that + ;; 'use-modules' form in BODY that are required for macro expansion work as + ;; expected. + (gexp (begin + (define %build-inputs + (map (lambda (tuple) + (apply cons tuple)) + '(ungexp inputs))) + (define %outputs + (list (ungexp-splicing + (map (lambda (name) + (gexp (cons (ungexp name) + (ungexp output name)))) + outputs)))) + (define %output + (assoc-ref %outputs "out")) + (ungexp body)))) + (define* (gexp->script name exp #:key (modules '()) (guile (default-guile))) "Return an executable script NAME that runs EXP using GUILE with MODULES in diff --git a/guix/packages.scm b/guix/packages.scm index 3983d14..bd675c5 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -678,39 +678,24 @@ Return the cached result when available." (#f (cache package key thunk))))) -(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))) - (((? string? name) (? origin? source)) - (list name (package-source-derivation store source system))) + (list name (gexp-input (local-file file #:recursive? #t) + #:native? native?))) (x (raise (condition (&package-input-error (package package) @@ -832,18 +817,19 @@ 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) - inputs)) (paths (delete-duplicates (append-map (match-lambda ((_ (? package? p) _ ...) (package-native-search-paths p)) (_ '())) - inputs)))) + inputs))) + (inputs (map (cut expand-input context <>) + inputs))) - (apply (bag-build bag) - store (bag-name bag) input-drvs + ;; TODO: Change to monadic style. + (apply (store-lower (bag-build bag)) + store (bag-name bag) inputs #:search-paths paths #:outputs (bag-outputs bag) #:system system (bag-arguments bag))))) @@ -856,13 +842,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 @@ -879,7 +865,8 @@ 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 build-drvs #:target-drvs (append host-drvs target-drvs) diff --git a/tests/builders.scm b/tests/builders.scm index a7c3e42..155cafd 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -102,11 +102,11 @@ "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) (tarball (url-fetch* %store url 'sha256 hash #:guile %bootstrap-guile)) - (build (gnu-build %store "hello-2.8" - `(("source" ,tarball) - ,@%bootstrap-inputs) - #:guile %bootstrap-guile - #:search-paths %bootstrap-search-paths)) + (build ((store-lower gnu-build) %store "hello-2.8" + %bootstrap-inputs + #:source tarball + #:guile %bootstrap-guile + #:search-paths %bootstrap-search-paths)) (out (derivation->output-path build))) (and (build-derivations %store (list (pk 'hello-drv build))) (valid-path? %store out) diff --git a/tests/packages.scm b/tests/packages.scm index 3cb532d..6a5682a 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -442,9 +442,9 @@ (system system) (target target) (build-inputs inputs) (build - (lambda* (store name inputs - #:key outputs system search-paths) - search-paths))))))) + (lambda* (name inputs + #:key outputs system search-paths) + (abort-to-prompt p search-paths)))))))) (x (list (search-path-specification (variable "GUILE_LOAD_PATH") (files '("share/guile/site/2.0")))
