diff options
Diffstat (limited to 'guix')
61 files changed, 2846 insertions, 2981 deletions
diff --git a/guix/build-system/android-ndk.scm b/guix/build-system/android-ndk.scm index dbfa626a19..211fd11311 100644 --- a/guix/build-system/android-ndk.scm +++ b/guix/build-system/android-ndk.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.org> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix search-paths) #: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 (guix build-system gnu) @@ -34,62 +36,51 @@ (guix build syscalls) ,@%gnu-build-system-modules)) -(define* (android-ndk-build store name inputs - #:key - (tests? #t) - (test-target #f) - (phases '(@ (guix build android-ndk-build-system) - %standard-phases)) - (outputs '("out")) - (make-flags ''()) - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %android-ndk-build-system-modules) - (modules '((guix build android-ndk-build-system) - (guix build utils)))) +(define* (android-ndk-build name inputs + #:key + source + (tests? #t) + (test-target #f) + (phases '%standard-phases) + (outputs '("out")) + (make-flags #~'()) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %android-ndk-build-system-modules) + (modules '((guix build android-ndk-build-system) + (guix build utils)))) "Build SOURCE using Android NDK, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (android-ndk-build #:name ,name - #: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 - #:make-flags (cons* "-f" - ,(string-append - (derivation->output-path - (car (assoc-ref inputs "android-build"))) - "/share/android/build/core/main.mk") - ,make-flags) - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp 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))))) + (android-ndk-build #:name #$name + #:source #+source + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:phases #$phases + #:bootstrap-scripts '() ;no autotools machinery + #:make-flags + (cons* "-f" + #$(file-append (gexp-input-thing + (car (assoc-ref inputs + "android-build"))) + "/share/android/build/core/main.mk") + #$make-flags) + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp 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 builder + #:system system + #:guile-for-build guile))) (define* (lower name #:key source inputs native-inputs outputs system target @@ -98,7 +89,7 @@ "Return a bag for NAME." (define private-keywords - '(#:source #:target #:inputs #:native-inputs #:outputs)) + '(#:target #:inputs #:native-inputs #:outputs)) (and (not target) ;; TODO: support cross-compilation (bag diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index 1809d1f3d2..08a4c996f9 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -73,7 +75,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:jdk #:ant #:zip #:inputs #:native-inputs)) + '(#:target #:jdk #:ant #:zip #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -94,8 +96,9 @@ (build ant-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (ant-build store name inputs +(define* (ant-build name inputs #:key + source (tests? #t) (test-target "check") (configure-flags ''()) @@ -107,8 +110,7 @@ (test-exclude (list "**/Abstract*.java")) (source-dir "src") (test-dir "src/test") - (phases '(@ (guix build ant-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -119,49 +121,35 @@ (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (ant-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:make-flags ,make-flags - #:configure-flags ,configure-flags - #:system ,system - #:tests? ,tests? - #:test-target ,test-target - #:build-target ,build-target - #:jar-name ,jar-name - #:main-class ,main-class - #:test-include (list ,@test-include) - #:test-exclude (list ,@test-exclude) - #:source-dir ,source-dir - #:test-dir ,test-dir - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (ant-build #:name #$name + #:source #+source + #:make-flags #$make-flags + #:configure-flags #$configure-flags + #:system #$system + #:tests? #$tests? + #:test-target #$test-target + #:build-target #$build-target + #:jar-name #$jar-name + #:main-class #$main-class + #:test-include (list #$@test-include) + #:test-exclude (list #$@test-exclude) + #:source-dir #$source-dir + #:test-dir #$test-dir + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp 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)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define ant-build-system (build-system diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index b4e40ee8c2..79de2ee5ba 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> ;;; Copyright © 2019, 2020, 2021 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +23,8 @@ #:use-module (guix utils) #:use-module (guix memoization) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module ((guix build utils) #:select ((package-name->name+version @@ -92,46 +94,33 @@ (build asdf-build/source) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (asdf-build/source store name inputs +(define* (asdf-build/source name inputs #:key source outputs - (phases '(@ (guix build asdf-build-system) - %standard-phases/source)) + (phases '%standard-phases/source) (search-paths '()) (system (%current-system)) (guile #f) (imported-modules %asdf-build-system-modules) (modules %asdf-build-modules)) (define builder - `(begin - (use-modules ,@modules) - (asdf-build/source #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) source) - (source source)) - #:system ,system - #: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 - (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)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (asdf-build/source #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define* (package-with-build-system from-build-system to-build-system from-prefix to-prefix @@ -277,19 +266,18 @@ set up using CL source package conventions." (arguments (strip-keyword-arguments private-keywords arguments)))))) (define (asdf-build lisp-type) - (lambda* (store name inputs - #:key source outputs - (tests? #t) - (asd-files ''()) - (asd-systems ''()) - (test-asd-file #f) - (phases '(@ (guix build asdf-build-system) - %standard-phases)) - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %asdf-build-system-modules) - (modules %asdf-build-modules)) + (lambda* (name inputs + #:key source outputs + (tests? #t) + (asd-files ''()) + (asd-systems ''()) + (test-asd-file #f) + (phases '%standard-phases) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %asdf-build-system-modules) + (modules %asdf-build-modules)) (define systems (if (null? (cadr asd-systems)) @@ -304,44 +292,32 @@ set up using CL source package conventions." asd-systems)) (define builder - `(begin - (use-modules ,@modules) - (parameterize ((%lisp (string-append - (assoc-ref %build-inputs ,lisp-type) - "/bin/" ,lisp-type)) - (%lisp-type ,lisp-type)) - (asdf-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) source) - (source source)) - #:asd-files ,asd-files - #:asd-systems ,systems - #:test-asd-file ,test-asd-file - #:system ,system - #: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 - (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))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (parameterize ((%lisp (string-append + (assoc-ref %build-inputs #$lisp-type) + "/bin/" #$lisp-type)) + (%lisp-type #$lisp-type)) + (asdf-build #:name #$name + #:source #+source + #:asd-files #$asd-files + #:asd-systems #$systems + #:test-asd-file #$test-asd-file + #:system #$system + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs)))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile)))) (define asdf-build-system/sbcl (build-system diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index e53d2a7523..60c35eed07 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 David Craven <david@craven.ch> @@ -26,7 +26,8 @@ #:use-module (guix search-paths) #: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 (guix build-system gnu) @@ -71,8 +72,9 @@ to NAME and VERSION." (guix build json) ,@%cargo-utils-modules)) -(define* (cargo-build store name inputs +(define* (cargo-build name inputs #:key + source (tests? #t) (test-target #f) (vendor-dir "guix-vendor") @@ -82,8 +84,7 @@ to NAME and VERSION." (features ''()) (skip-build? #f) (install-source? #t) - (phases '(@ (guix build cargo-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -94,47 +95,35 @@ to NAME and VERSION." "Build SOURCE using CARGO, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (cargo-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:test-target ,test-target - #:vendor-dir ,vendor-dir - #:cargo-build-flags ,cargo-build-flags - #:cargo-test-flags ,cargo-test-flags - #:cargo-package-flags ,cargo-package-flags - #:features ,features - #:skip-build? ,skip-build? - #:install-source? ,install-source? - #:tests? ,(and tests? (not skip-build?)) - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp 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))))) + (cargo-build #:name #$name + #:source #+source + #:system #$system + #:test-target #$test-target + #:vendor-dir #$vendor-dir + #:cargo-build-flags #$(sexp->gexp cargo-build-flags) + #:cargo-test-flags #$(sexp->gexp cargo-test-flags) + #:cargo-package-flags #$(sexp->gexp cargo-package-flags) + #:features #$(sexp->gexp features) + #:skip-build? #$skip-build? + #:install-source? #$install-source? + #:tests? #$(and tests? (not skip-build?)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile)) (define (package-cargo-inputs p) (apply @@ -222,7 +211,7 @@ any dependent crates. This can be a benefits: - It avoids waiting for quadratic builds from source: cargo always builds dependencies within the current workspace. This is largely due to Rust not having a stable ABI and other resolutions that cargo applies. This means that - if we have a depencency chain of X -> Y -> Z and we build each definition + if we have a dependency chain of X -> Y -> Z and we build each definition independently the following will happen: * Cargo will build and test crate Z * Cargo will build crate Z in Y's workspace, then build and test Y @@ -253,7 +242,7 @@ any dependent crates. This can be a benefits: "Return a bag for NAME." (define private-keywords - '(#:source #:target #:rust #:inputs #:native-inputs #:outputs + '(#:target #:rust #:inputs #:native-inputs #:outputs #:cargo-inputs #:cargo-development-inputs)) (and (not target) ;; TODO: support cross-compilation diff --git a/guix/build-system/chicken.scm b/guix/build-system/chicken.scm index 9abae0431a..c6978266fc 100644 --- a/guix/build-system/chicken.scm +++ b/guix/build-system/chicken.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 raingloom <raingloom@riseup.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,7 +19,9 @@ (define-module (guix build-system chicken) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -47,7 +50,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:chicken #:inputs #:native-inputs)) + '(#:target #:chicken #:inputs #:native-inputs)) ;; TODO: cross-compilation support (and (not target) @@ -69,60 +72,45 @@ (build chicken-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (chicken-build store name inputs - #:key - (phases '(@ (guix build chicken-build-system) - %standard-phases)) - (outputs '("out")) - (search-paths '()) - (egg-name "") - (unpack-path "") - (build-flags ''()) - (tests? #t) - (system (%current-system)) - (guile #f) - (imported-modules %chicken-build-system-modules) - (modules '((guix build chicken-build-system) - (guix build union) - (guix build utils)))) +(define* (chicken-build name inputs + #:key + source + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (egg-name "") + (unpack-path "") + (build-flags ''()) + (tests? #t) + (system (%current-system)) + (guile #f) + (imported-modules %chicken-build-system-modules) + (modules '((guix build chicken-build-system) + (guix build union) + (guix build utils)))) (define builder - `(begin - (use-modules ,@modules) - (chicken-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:egg-name ,egg-name - #:unpack-path ,unpack-path - #:build-flags ,build-flags - #:tests? ,tests? - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (chicken-build #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:egg-name #$egg-name + #:unpack-path #$unpack-path + #:build-flags #$build-flags + #:tests? #$tests? + #:inputs #$(input-tuples->gexp 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)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define chicken-build-system (build-system diff --git a/guix/build-system/clojure.scm b/guix/build-system/clojure.scm index 607f67aaec..39b7f44e89 100644 --- a/guix/build-system/clojure.scm +++ b/guix/build-system/clojure.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> -;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +25,9 @@ #:select (standard-packages) #:prefix gnu:) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix packages) #:use-module ((guix search-paths) #:select @@ -102,26 +104,9 @@ (arguments (strip-keyword-arguments private-keywords arguments)))))) -(define-with-docs source->output-path - "Convert source input to output path." - (match-lambda - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source))) - -(define-with-docs maybe-guile->guile - "Find the right guile." - (match-lambda - ((and maybe-guile (? package?)) - maybe-guile) - (#f ; default - (@* (gnu packages commencement) guile-final)))) - -(define* (clojure-build store name inputs +(define* (clojure-build name inputs #:key + source (source-dirs `',%source-dirs) (test-dirs `',%test-dirs) (compile-dir %compile-dir) @@ -133,7 +118,7 @@ (aot-include `',%aot-include) (aot-exclude `',%aot-exclude) - doc-dirs ; no sensible default + doc-dirs ; no sensible default (doc-regex %doc-regex) (tests? %tests?) @@ -149,48 +134,45 @@ (imported-modules %clojure-build-system-modules) (modules %default-modules)) "Build SOURCE with INPUTS." - (let ((builder `(begin - (use-modules ,@modules) - (clojure-build #:name ,name - #:source ,(source->output-path - (assoc-ref inputs "source")) - - #:source-dirs ,source-dirs - #:test-dirs ,test-dirs - #:compile-dir ,compile-dir - - #:jar-names ,jar-names - #:main-class ,main-class - #:omit-source? ,omit-source? - - #:aot-include ,aot-include - #:aot-exclude ,aot-exclude - - #:doc-dirs ,doc-dirs - #:doc-regex ,doc-regex - - #:tests? ,tests? - #:test-include ,test-include - #:test-exclude ,test-exclude - - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-spec->sexp - search-paths) - #:system ,system - #:inputs %build-inputs))) - - (guile-for-build (package-derivation store - (maybe-guile->guile 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 builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (clojure-build #:name #$name + #:source #+source + + #:source-dirs #$source-dirs + #:test-dirs #$test-dirs + #:compile-dir #$compile-dir + + #:jar-names #$jar-names + #:main-class #$main-class + #:omit-source? #$omit-source? + + #:aot-include #$aot-include + #:aot-exclude #$aot-exclude + + #:doc-dirs #$doc-dirs + #:doc-regex #$doc-regex + + #:tests? #$tests? + #:test-include #$test-include + #:test-exclude #$test-exclude + + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-spec->sexp + search-paths)) + #:system #$system + #:inputs #$(input-tuples->gexp inputs))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define clojure-build-system (build-system diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index f590b6ea42..2f9689b07c 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> @@ -21,7 +21,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) @@ -61,7 +63,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - `(#:source #:cmake #:inputs #:native-inputs #:outputs + `(#:cmake #:inputs #:native-inputs ,@(if target '() '(#:target)))) (bag @@ -95,8 +97,8 @@ (build (if target cmake-cross-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 ''()) @@ -111,8 +113,7 @@ (strip-flags ''("--strip-debug")) (strip-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build cmake-build-system) - %standard-phases)) + (phases '%standard-phases) (system (%current-system)) (substitutable? #t) (imported-modules %cmake-build-system-modules) @@ -120,62 +121,56 @@ (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 + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp 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 '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:configure-flags #$(if (pair? configure-flags) + (sexp->gexp 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 #$(sexp->gexp strip-flags) + #:strip-directories #$(sexp->gexp strip-directories)))))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:substitutable? substitutable? - #: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 + #:target #f + #:substitutable? substitutable? + #:guile-for-build guile))) ;;; ;;; Cross-compilation. ;;; -(define* (cmake-cross-build store name +(define* (cmake-cross-build name #:key - target native-drvs target-drvs - (guile #f) + target + build-inputs target-inputs host-inputs + source guile (outputs '("out")) (configure-flags ''()) (search-paths '()) @@ -193,8 +188,7 @@ provides a 'CMakeLists.txt' file as its build system." "--enable-deterministic-archives")) (strip-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build cmake-build-system) - %standard-phases)) + (phases '%standard-phases) (substitutable? #t) (system (%current-system)) (build (nix-system->gnu-triplet system)) @@ -205,78 +199,54 @@ provides a 'CMakeLists.txt' file as its build system." with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." (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)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) - (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)) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) - (cmake-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 - search-paths) - #:native-search-paths ',(map - search-path-specification->sexp - native-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 %outputs + #$(outputs->gexp outputs)) - (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))))) + (cmake-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 + search-path-specification->sexp + native-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 (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:substitutable? substitutable? - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:substitutable? substitutable? + #:guile-for-build guile))) (define cmake-build-system (build-system diff --git a/guix/build-system/copy.scm b/guix/build-system/copy.scm index d1bf8fb654..4894ba46fb 100644 --- a/guix/build-system/copy.scm +++ b/guix/build-system/copy.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ (define-module (guix build-system copy) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -59,7 +61,7 @@ #:rest arguments) "Return a bag for NAME from the given arguments." (define private-keywords - '(#:source #:target #:inputs #:native-inputs)) + '(#:target #:inputs #:native-inputs)) (bag (name name) @@ -75,8 +77,9 @@ (build copy-build) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (copy-build store name inputs - #:key (guile #f) +(define* (copy-build name inputs + #:key + guile source (outputs '("out")) (install-plan ''(("." "./"))) (search-paths '()) @@ -90,49 +93,43 @@ (phases '(@ (guix build copy-build-system) %standard-phases)) (system (%current-system)) + (target #f) (imported-modules %copy-build-system-modules) (modules '((guix build copy-build-system) (guix build utils)))) "Build SOURCE using INSTALL-PLAN, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (copy-build #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:outputs %outputs - #:inputs %build-inputs - #:install-plan ,install-plan - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:phases ,phases - #:out-of-source? ,out-of-source? - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (with-imported-modules imported-modules + #~(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 + #~(copy-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:install-plan #$(if (pair? install-plan) + (sexp->gexp install-plan) + install-plan) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:out-of-source? #$out-of-source? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$(sexp->gexp strip-flags) + #:strip-directories #$(sexp->gexp 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 builder + #:system system + #:target #f + #:guile-for-build guile))) (define copy-build-system (build-system diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm index 5a31a2f51a..55ad7decb8 100644 --- a/guix/build-system/dub.scm +++ b/guix/build-system/dub.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 David Craven <david@craven.ch> @@ -24,7 +24,8 @@ #:use-module (guix search-paths) #: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 (guix build-system gnu) @@ -56,57 +57,43 @@ (guix build syscalls) ,@%gnu-build-system-modules)) -(define* (dub-build store name inputs - #:key - (tests? #t) - (test-target #f) - (dub-build-flags ''()) - (phases '(@ (guix build dub-build-system) - %standard-phases)) - (outputs '("out")) - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %dub-build-system-modules) - (modules '((guix build dub-build-system) - (guix build utils)))) +(define* (dub-build name inputs + #:key + source + (tests? #t) + (test-target #f) + (dub-build-flags ''()) + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %dub-build-system-modules) + (modules '((guix build dub-build-system) + (guix build utils)))) "Build SOURCE using DUB, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (dub-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:test-target ,test-target - #:dub-build-flags ,dub-build-flags - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (dub-build #:name #$name + #:source #+source + #:system #$system + #:test-target #$test-target + #:dub-build-flags #$dub-build-flags + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp 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)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define* (lower name #:key source inputs native-inputs outputs system target @@ -118,7 +105,7 @@ "Return a bag for NAME." (define private-keywords - '(#:source #:target #:ldc #:dub #:pkg-config #:inputs #:native-inputs #:outputs)) + '(#:target #:ldc #:dub #:pkg-config #:inputs #:native-inputs #:outputs)) (and (not target) ;; TODO: support cross-compilation (bag diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm index 6a2f3d16de..8c33e096f5 100644 --- a/guix/build-system/dune.scm +++ b/guix/build-system/dune.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,7 @@ (define-module (guix build-system dune) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module ((guix build-system gnu) #:prefix gnu:) @@ -60,7 +61,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:dune #:findlib #:ocaml #:inputs #:native-inputs)) + '(#:target #:dune #:findlib #:ocaml #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (let ((base (ocaml:lower name @@ -80,8 +81,9 @@ (build dune-build) (arguments (strip-keyword-arguments private-keywords arguments)))))) -(define* (dune-build store name inputs - #:key (guile #f) +(define* (dune-build name inputs + #:key + guile source (outputs '("out")) (search-paths '()) (build-flags ''()) @@ -107,50 +109,39 @@ "Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE provides a 'setup.ml' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (dune-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 - #:test-flags ,test-flags - #:build-flags ,build-flags - #:out-of-source? ,out-of-source? - #:jbuild? ,jbuild? - #:package ,package - #:tests? ,tests? - #:test-target ,test-target - #:install-target ,install-target - #:validate-runpath? ,validate-runpath? - #:patch-shebangs? ,patch-shebangs? - #:strip-binaries? ,strip-binaries? - #:strip-flags ,strip-flags - #:strip-directories ,strip-directories))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + (dune-build #:source #$source + #:system #$system + #:outputs (list #$@(map (lambda (name) + #~(cons #$name + (ungexp output name))) + outputs)) + #:inputs (map (lambda (tuple) + (apply cons tuple)) + '#$inputs) + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:phases #$phases + #:test-flags #$test-flags + #:build-flags #$build-flags + #:out-of-source? #$out-of-source? + #:jbuild? #$jbuild? + #:package #$package + #:tests? #$tests? + #:test-target #$test-target + #:install-target #$install-target + #: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 - #:guile-for-build guile-for-build)) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile)) (define dune-build-system (build-system diff --git a/guix/build-system/emacs.scm b/guix/build-system/emacs.scm index ac05ff420e..3df68789ff 100644 --- a/guix/build-system/emacs.scm +++ b/guix/build-system/emacs.scm @@ -23,7 +23,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -81,13 +82,12 @@ (build emacs-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (emacs-build store name inputs +(define* (emacs-build name inputs #:key source (tests? #f) (parallel-tests? #t) (test-command ''("make" "check")) - (phases '(@ (guix build emacs-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (include (quote %default-include)) (exclude (quote %default-exclude)) @@ -100,43 +100,29 @@ (guix build emacs-utils)))) "Build SOURCE using EMACS, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (emacs-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:test-command ,test-command - #:tests? ,tests? - #:parallel-tests? ,parallel-tests? - #:phases ,phases - #:outputs %outputs - #:include ,include - #:exclude ,exclude - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (emacs-build #:name #$name + #:source #+source + #:system #$system + #:test-command #$test-command + #:tests? #$tests? + #:parallel-tests? #$parallel-tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:include #$include + #:exclude #$exclude + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp 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)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define emacs-build-system (build-system diff --git a/guix/build-system/font.scm b/guix/build-system/font.scm index d40a4985f8..74dc80b5db 100644 --- a/guix/build-system/font.scm +++ b/guix/build-system/font.scm @@ -17,6 +17,9 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build-system font) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) @@ -69,13 +72,12 @@ (build font-build) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (font-build store name inputs +(define* (font-build name inputs #:key source (tests? #t) (test-target "test") (configure-flags ''()) - (phases '(@ (guix build font-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -85,41 +87,32 @@ (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (font-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))) + (with-imported-modules imported-modules + #~(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 + #~(font-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (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 builder + #:system system + #:target #f + #:guile-for-build guile))) (define font-build-system (build-system diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index fb1f8fb930..2df49a2495 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch> ;;; @@ -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) @@ -85,7 +87,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:glib #:inputs #:native-inputs + '(#:target #:glib #:inputs #:native-inputs #:outputs #:implicit-inputs?)) (and (not target) ;XXX: no cross-compilation @@ -105,8 +107,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 ''()) @@ -132,70 +134,47 @@ allowed-references disallowed-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 + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp 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 '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp 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 #$(sexp->gexp strip-flags) + #:strip-directories + #$(sexp->gexp 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)) - #:disallowed-references - (and disallowed-references - (map canonicalize-reference - disallowed-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 + #:target #f + #:allowed-references allowed-references + #:disallowed-references disallowed-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 6b481ad45c..c74acb51b0 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix memoization) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -215,7 +217,7 @@ use `--strip-all' as the arguments to `strip'." (arguments (let ((a (default-keyword-arguments (package-arguments p) '(#:configure-flags '() - #:strip-flags '("--strip-debug"))))) + #:strip-flags '("--strip-unneeded"))))) (substitute-keyword-arguments a ((#:configure-flags flags) `(cons* "--disable-shared" "LDFLAGS=-static" ,flags)) @@ -281,7 +283,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)))) @@ -324,10 +326,22 @@ standard packages used as implicit inputs of the GNU build system." ;; Regexp matching license files. "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$") -(define* (gnu-build store name input-drvs - #:key (guile #f) +(define %bootstrap-scripts + ;; Typical names of Autotools "bootstrap" scripts. + #~%bootstrap-scripts) + +(define %strip-flags + #~'("--strip-unneeded" "--enable-deterministic-archives")) + +(define %strip-directories + #~'("lib" "lib64" "libexec" "bin" "sbin")) + +(define* (gnu-build name inputs + #:key + guile source (outputs '("out")) (search-paths '()) + (bootstrap-scripts %bootstrap-scripts) (configure-flags ''()) (make-flags ''()) (out-of-source? #f) @@ -337,11 +351,10 @@ standard packages used as implicit inputs of the GNU build system." (parallel-tests? #t) (patch-shebangs? #t) (strip-binaries? #t) - (strip-flags ''("--strip-debug" - "--enable-deterministic-archives")) - (strip-directories ''("lib" "lib64" "libexec" - "bin" "sbin")) + (strip-flags %strip-flags) + (strip-directories %strip-directories) (validate-runpath? #t) + (make-dynamic-linker-cache? #t) (license-file-regexp %license-file-regexp) (phases '%standard-phases) (locale "en_US.utf8") @@ -368,78 +381,55 @@ SUBSTITUTABLE? determines whether users may be able to use substitutes of the 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. Likewise for DISALLOWED-REFERENCES, which lists -packages that must not be referenced." - (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))) - +are allowed to refer to." (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? - #:license-file-regexp ,license-file-regexp - #: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)) - #:disallowed-references - (and disallowed-references - (map canonicalize-reference - disallowed-references)) - #:guile-for-build guile-for-build)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + #$(with-build-variables inputs outputs + #~(gnu-build #:source #+source + #:system #$system + #:build #$build + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:locale #$locale + #:bootstrap-scripts #$bootstrap-scripts + #:configure-flags #$(if (pair? configure-flags) + (sexp->gexp configure-flags) + configure-flags) + #:make-flags #$(if (pair? make-flags) + (sexp->gexp 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? + #:license-file-regexp #$license-file-regexp + #:strip-binaries? #$strip-binaries? + #:validate-runpath? #$validate-runpath? + #:make-dynamic-linker-cache? #$make-dynamic-linker-cache? + #:license-file-regexp #$license-file-regexp + #: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 #f + #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) ;;; @@ -475,15 +465,16 @@ is one of `host' or `target'." `(("cross-libc:static" ,libc "static")) '())))))))) -(define* (gnu-cross-build store name +(define* (gnu-cross-build name #:key - target native-drvs target-drvs - (guile #f) - source + target + build-inputs target-inputs host-inputs + guile source (outputs '("out")) (search-paths '()) (native-search-paths '()) + (bootstrap-scripts %bootstrap-scripts) (configure-flags ''()) (make-flags ''()) (out-of-source? #f) @@ -492,11 +483,15 @@ is one of `host' or `target'." (parallel-build? #t) (parallel-tests? #t) (patch-shebangs? #t) (strip-binaries? #t) - (strip-flags ''("--strip-debug" - "--enable-deterministic-archives")) - (strip-directories ''("lib" "lib64" "libexec" - "bin" "sbin")) + (strip-flags %strip-flags) + (strip-directories %strip-directories) (validate-runpath? #t) + + ;; We run 'ldconfig' to generate ld.so.cache and it + ;; generally can't do that for cross-built binaries + ;; ("ldconfig: foo.so is for unknown machine 40."). + (make-dynamic-linker-cache? #f) + (license-file-regexp %license-file-regexp) (phases '%standard-phases) (locale "en_US.utf8") @@ -510,102 +505,63 @@ 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 - target system))) - (((? package? p) output) - (derivation->output-path (package-cross-derivation store p - target 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 - search-paths) - #: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? - #:license-file-regexp ,license-file-regexp - #: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)) - #:disallowed-references - (and disallowed-references - (map canonicalize-reference - disallowed-references)) - #:guile-for-build guile-for-build)) + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) + + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + + (define %outputs + #$(outputs->gexp outputs)) + + (gnu-build #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths '#$(sexp->gexp + (map + search-path-specification->sexp + native-search-paths)) + #:phases #$phases + #:locale #$locale + #:bootstrap-scripts #$bootstrap-scripts + #: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? + #:license-file-regexp #$license-file-regexp + #:strip-binaries? #$strip-binaries? + #:validate-runpath? #$validate-runpath? + #:make-dynamic-linker-cache? #$make-dynamic-linker-cache? + #:license-file-regexp #$license-file-regexp + #: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 + #:disallowed-references disallowed-references + #:guile-for-build guile))) (define gnu-build-system (build-system diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 8f55796e86..100d1db4b6 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 Petter <petter@mykolab.ch> ;;; Copyright © 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,9 @@ (define-module (guix build-system go) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -96,7 +99,7 @@ commit hash and its date rather than a proper release tag." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:go #:inputs #:native-inputs)) + '(#:target #:go #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -115,10 +118,10 @@ commit hash and its date rather than a proper release tag." (build go-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (go-build store name inputs +(define* (go-build name inputs #:key - (phases '(@ (guix build go-build-system) - %standard-phases)) + source + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (install-source? #t) @@ -134,45 +137,30 @@ commit hash and its date rather than a proper release tag." (guix build union) (guix build utils)))) (define builder - `(begin - (use-modules ,@modules) - (go-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:install-source? ,install-source? - #:import-path ,import-path - #:unpack-path ,unpack-path - #:build-flags ,build-flags - #:tests? ,tests? - #:allow-go-reference? ,allow-go-reference? - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + (go-build #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:install-source? #$install-source? + #:import-path #$import-path + #:unpack-path #$unpack-path + #:build-flags #$build-flags + #:tests? #$tests? + #:allow-go-reference? #$allow-go-reference? + #:inputs #$(input-tuples->gexp 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)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define go-build-system (build-system diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index 45e735b987..f64f214675 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +20,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -75,7 +76,7 @@ ;; denominator between Guile 2.0 and 2.2. ''("-Wunbound-variable" "-Warity-mismatch" "-Wformat")) -(define* (guile-build store name inputs +(define* (guile-build name inputs #:key source (guile #f) (phases '%standard-phases) @@ -91,47 +92,34 @@ (guix build utils)))) "Build SOURCE using Guile taken from the native inputs, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (guile-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:source-directory ,source-directory - #:scheme-file-regexp ,scheme-file-regexp - #:not-compiled-file-regexp ,not-compiled-file-regexp - #:compile-flags ,compile-flags - #:phases ,phases - #:system ,system - #: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* (guile-cross-build store name + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + + (guile-build #:name #$name + #:source #+source + #:source-directory #$source-directory + #:scheme-file-regexp #$scheme-file-regexp + #:not-compiled-file-regexp #$not-compiled-file-regexp + #:compile-flags #$compile-flags + #:phases #$phases + #:system #$system + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(map search-path-specification->sexp + search-paths))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile))) + +(define* (guile-cross-build name #:key (system (%current-system)) target - native-drvs target-drvs + build-inputs target-inputs host-inputs (guile #f) source (outputs '("out")) @@ -146,68 +134,42 @@ (modules '((guix build guile-build-system) (guix build utils)))) (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)) - - (guile-build #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:target ,target - #:outputs %outputs - #:source-directory ,source-directory - #:not-compiled-file-regexp ,not-compiled-file-regexp - #:compile-flags ,compile-flags - #:inputs %build-target-inputs - #:native-inputs %build-host-inputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:native-search-paths ',(map - search-path-specification->sexp - native-search-paths) - #:phases ,phases)))) - - (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? - #:guile-for-build guile-for-build)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) + + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + + (define %outputs + #$(outputs->gexp outputs)) + + (guile-build #:source #+source + #:system #$system + #:target #$target + #:outputs %outputs + #:source-directory #$source-directory + #:not-compiled-file-regexp #$not-compiled-file-regexp + #:compile-flags #$compile-flags + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:native-search-paths '#$(map + search-path-specification->sexp + native-search-paths) + #:phases #$phases)))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:guile-for-build guile))) (define guile-build-system (build-system diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 18a584f782..67c8593cf6 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +23,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix download) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -116,7 +118,7 @@ version REVISION." (cons name propagated-names)))))) extra-directories)))))))) -(define* (haskell-build store name inputs +(define* (haskell-build name inputs #:key source (haddock? #t) (haddock-flags ''()) @@ -127,8 +129,7 @@ version REVISION." (parallel-build? #f) (configure-flags ''()) (extra-directories ''()) - (phases '(@ (guix build haskell-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out" "static")) (search-paths '()) (system (%current-system)) @@ -139,50 +140,34 @@ version REVISION." "Build SOURCE using HASKELL, and with INPUTS. This assumes that SOURCE provides a 'Setup.hs' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (haskell-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:cabal-revision ,(match (assoc-ref inputs - "cabal-revision") - (((? derivation? revision)) - (derivation->output-path revision)) - (revision revision)) - #:configure-flags ,configure-flags - #:extra-directories ,extra-directories - #:haddock-flags ,haddock-flags - #:system ,system - #:test-target ,test-target - #:tests? ,tests? - #:parallel-build? ,parallel-build? - #:haddock? ,haddock? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp 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))))) + (haskell-build #:name #$name + #:source #+source + #:cabal-revision #$(assoc-ref inputs + "cabal-revision") + #:configure-flags #$configure-flags + #:extra-directories #$extra-directories + #:haddock-flags #$haddock-flags + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:parallel-build? #$parallel-build? + #:haddock? #$haddock? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp 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 builder + #:system system + #:guile-for-build guile))) (define haskell-build-system (build-system diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm index 63cb7cd864..5b824d7f0a 100644 --- a/guix/build-system/julia.scm +++ b/guix/build-system/julia.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -73,11 +75,10 @@ (build julia-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (julia-build store name inputs +(define* (julia-build name inputs #:key source (tests? #t) - (phases '(@ (guix build julia-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -88,40 +89,26 @@ (guix build utils)))) "Build SOURCE using Julia, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (julia-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs - #:julia-package-name ,julia-package-name))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (julia-build #:name #$name + #:source #+source + #:system #$system + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs) + #:julia-package-name #$julia-package-name)))) - (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)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define julia-build-system (build-system diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index fc3d959ce7..84570b923a 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ (define-module (guix build-system linux-module) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -114,7 +116,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - `(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs + `(#:target #:gcc #:kmod #:linux #:inputs #:native-inputs ,@(if target '() '(#:target)))) (bag @@ -148,13 +150,12 @@ (build (if target linux-module-build-cross linux-module-build)) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (linux-module-build store name inputs +(define* (linux-module-build name inputs #:key - target + source target (search-paths '()) (tests? #t) - (phases '(@ (guix build linux-module-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (make-flags ''()) (system (%current-system)) @@ -166,56 +167,42 @@ (guix build utils)))) "Build SOURCE using LINUX, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (linux-module-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) - #:phases ,phases - #:system ,system - #:target ,target - #:arch ,(system->arch (or target system)) - #:tests? ,tests? - #:outputs %outputs - #:make-flags ,make-flags - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (linux-module-build #:name #$name + #:source #+source + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$phases + #:system #$system + #:target #$target + #:arch #$(system->arch (or target system)) + #:tests? #$tests? + #:outputs #$(outputs->gexp outputs) + #:make-flags #$make-flags + #:inputs #$(input-tuples->gexp 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 - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build - #:substitutable? substitutable?)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile + #:substitutable? substitutable?))) (define* (linux-module-build-cross - store name + name #:key - target native-drvs target-drvs + source target + build-inputs target-inputs host-inputs (guile #f) (outputs '("out")) (make-flags ''()) (search-paths '()) (native-search-paths '()) (tests? #f) - (phases '(@ (guix build linux-module-build-system) - %standard-phases)) + (phases '%standard-phases) (system (%current-system)) (substitutable? #t) (imported-modules @@ -223,70 +210,43 @@ (modules '((guix build linux-module-build-system) (guix build utils)))) (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)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) - (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)) + (define %build-host-inputs + '#+(input-tuples->gexp build-inputs)) - (linux-module-build #:name ,name - #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:target ,target - #:arch ,(system->arch (or target system)) - #:outputs %outputs - #:make-flags ,make-flags - #:inputs %build-target-inputs - #:native-inputs %build-host-inputs - #:search-paths - ',(map search-path-specification->sexp - search-paths) - #:native-search-paths - ',(map - search-path-specification->sexp - native-search-paths) - #:phases ,phases - #:tests? ,tests?)))) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-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))))) + (linux-module-build #:name #$name + #:source #+source + #:system #$system + #:target #$target + #:arch #$(system->arch (or target system)) + #:outputs #$(outputs->gexp outputs) + #:make-flags #$make-flags + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths + '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths + '#$(map + search-path-specification->sexp + native-search-paths) + #:phases #$phases + #:tests? #$tests?)))) - (build-expression->derivation store name builder - #:system system - #:inputs (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:guile-for-build guile-for-build - #:substitutable? substitutable?)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile + #:substitutable? substitutable?))) (define linux-module-build-system (build-system diff --git a/guix/build-system/maven.scm b/guix/build-system/maven.scm index 2dceefccc1..0af5922692 100644 --- a/guix/build-system/maven.scm +++ b/guix/build-system/maven.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +20,8 @@ (define-module (guix build-system maven) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -119,7 +121,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:jdk #:maven #:maven-plugins #:inputs #:native-inputs)) + '(#:target #:jdk #:maven #:maven-plugins #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -140,70 +142,56 @@ (build maven-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (maven-build store name inputs - #:key (guile #f) - (outputs '("out")) - (search-paths '()) - (out-of-source? #t) - (validate-runpath? #t) - (patch-shebangs? #t) - (strip-binaries? #t) - (exclude %default-exclude) - (local-packages '()) - (tests? #t) - (strip-flags ''("--strip-debug")) - (strip-directories ''("lib" "lib64" "libexec" - "bin" "sbin")) - (phases '(@ (guix build maven-build-system) - %standard-phases)) - (system (%current-system)) - (imported-modules %maven-build-system-modules) - (modules '((guix build maven-build-system) - (guix build maven pom) - (guix build utils)))) +(define* (maven-build name inputs + #:key + source (guile #f) + (outputs '("out")) + (search-paths '()) + (out-of-source? #t) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (exclude %default-exclude) + (local-packages '()) + (tests? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '%standard-phases) + (system (%current-system)) + (imported-modules %maven-build-system-modules) + (modules '((guix build maven-build-system) + (guix build maven pom) + (guix build utils)))) "Build SOURCE using PATCHELF, and with INPUTS. This assumes that SOURCE provides its own binaries." (define builder - `(begin - (use-modules ,@modules) - (maven-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 - #:exclude (quote ,exclude) - #:local-packages (quote ,local-packages) - #:tests? ,tests? - #:out-of-source? ,out-of-source? - #: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 - #:guile-for-build guile-for-build)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (maven-build #:source #+source + #:system #$system + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$phases + #:exclude '#$exclude + #:local-packages '#$local-packages + #:tests? #$tests? + #:out-of-source? #$out-of-source? + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$(sexp->gexp strip-flags) + #:strip-directories #$(sexp->gexp strip-directories))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define maven-build-system (build-system diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index b68bcb80de..5adc0f92c8 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> ;;; Copyright © 2018, 2019 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,9 +19,10 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build-system meson) - #:use-module (guix store) + #:use-module (guix gexp) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -55,7 +57,7 @@ "Return the default meson package." ;; Lazily resolve the binding to avoid a circular dependency. (let ((module (resolve-interface '(gnu packages build-tools)))) - (module-ref module 'meson-for-build))) + (module-ref module 'meson))) (define* (lower name #:key source inputs native-inputs outputs system target @@ -66,7 +68,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - `(#:source #:meson #:ninja #:inputs #:native-inputs #:outputs #:target)) + `(#:meson #:ninja #:inputs #:native-inputs #:outputs #:target)) (and (not target) ;; TODO: add support for cross-compilation. (bag @@ -85,8 +87,9 @@ (build meson-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (meson-build store name inputs - #:key (guile #f) +(define* (meson-build name inputs + #:key + guile source (outputs '("out")) (configure-flags ''()) (search-paths '()) @@ -104,8 +107,7 @@ "bin" "sbin")) (elf-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build meson-build-system) - %standard-phases)) + (phases '%standard-phases) (system (%current-system)) (imported-modules %meson-build-system-modules) (modules '((guix build meson-build-system) @@ -114,76 +116,50 @@ disallowed-references) "Build SOURCE using MESON, and with INPUTS, assuming that SOURCE has a 'meson.build' file." - - ;; TODO: Copied from build-system/gnu, factorize this! - (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 - `(let ((build-phases (if ,glib-or-gtk? - ,phases - (modify-phases ,phases - (delete 'glib-or-gtk-compile-schemas) - (delete 'glib-or-gtk-wrap))))) - (use-modules ,@modules) - (meson-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 build-phases - #:configure-flags ,configure-flags - #: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 - #:elf-directories ,elf-directories))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define build-phases + #$(let ((phases (if (pair? phases) (sexp->gexp phases) phases))) + (if glib-or-gtk? + phases + #~(modify-phases #$phases + (delete 'glib-or-gtk-compile-schemas) + (delete 'glib-or-gtk-wrap))))) - (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 + #~(meson-build #:source #+source + #:system #$system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases build-phases + #:configure-flags #$(sexp->gexp configure-flags) + #: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 #$(sexp->gexp strip-flags) + #:strip-directories #$(sexp->gexp strip-directories) + #:elf-directories #$(sexp->gexp elf-directories)))))) - (build-expression->derivation store name builder - #:system system - #:inputs inputs - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:disallowed-references - (and disallowed-references - (map canonicalize-reference - disallowed-references)))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target #f + #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references + #:guile-for-build guile))) (define meson-build-system (build-system diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm index 28a6781c06..3256b5d30b 100644 --- a/guix/build-system/minify.scm +++ b/guix/build-system/minify.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -54,7 +56,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:inputs #:native-inputs)) + '(#:target #:inputs #:native-inputs)) (bag (name name) @@ -70,11 +72,11 @@ (build minify-build) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (minify-build store name inputs +(define* (minify-build name inputs #:key + source (javascript-files #f) - (phases '(@ (guix build minify-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (system (%current-system)) search-paths @@ -84,38 +86,24 @@ (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (minify-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:javascript-files ,javascript-files - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (minify-build #:name #$name + #:source #+source + #:javascript-files #$javascript-files + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp 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)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define minify-build-system (build-system diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index 98f63f87ef..ae799d1f4e 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ (define-module (guix build-system node) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -48,7 +50,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:node #:inputs #:native-inputs)) + '(#:target #:node #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -67,12 +69,13 @@ (build node-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (node-build store name inputs +(define* (node-build name inputs #:key + source + (npm-flags ''()) (test-target "test") (tests? #t) - (phases '(@ (guix build node-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -82,38 +85,27 @@ (guix build utils)))) "Build SOURCE using NODE and INPUTS." (define builder - `(begin - (use-modules ,@modules) - (node-build #:name ,name - #: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 - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (node-build #:name #$name + #:source #+source + #:system #$system + #:npm-flags #$npm-flags + #:test-target #$test-target + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) - (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))))) - - (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 builder + #:system system + #:guile-for-build guile))) (define node-build-system (build-system diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index 5513216c25..e7d6d96f0e 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +20,7 @@ (define-module (guix build-system ocaml) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -206,7 +207,7 @@ pre-defined variants." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:ocaml #:findlib #:inputs #:native-inputs)) + '(#:target #:ocaml #:findlib #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -226,8 +227,9 @@ pre-defined variants." (build ocaml-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (ocaml-build store name inputs - #:key (guile #f) +(define* (ocaml-build name inputs + #:key + guile source (outputs '("out")) (configure-flags ''()) (search-paths '()) (make-flags ''()) @@ -253,51 +255,35 @@ pre-defined variants." "Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE provides a 'setup.ml' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (ocaml-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 - #:test-flags ,test-flags - #:make-flags ,make-flags - #:build-flags ,build-flags - #:out-of-source? ,out-of-source? - #:use-make? ,use-make? - #:tests? ,tests? - #:test-target ,test-target - #:install-target ,install-target - #: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 - #:guile-for-build guile-for-build)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@modules) + (ocaml-build #:source #$source + #:system #$system + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(map search-path-specification->sexp + search-paths) + #:phases #$phases + #:configure-flags #$configure-flags + #:test-flags #$test-flags + #:make-flags #$make-flags + #:build-flags #$build-flags + #:out-of-source? #$out-of-source? + #:use-make? #$use-make? + #:tests? #$tests? + #:test-target #$test-target + #:install-target #$install-target + #:validate-runpath? #$validate-runpath? + #:patch-shebangs? #$patch-shebangs? + #:strip-binaries? #$strip-binaries? + #:strip-flags #$strip-flags + #:strip-directories #$strip-directories)))) + + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile)) (define ocaml-build-system (build-system diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 06af1dd20e..db0a916fb2 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -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,37 @@ (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 + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp 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 '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:make-maker? #$make-maker? + #:make-maker-flags #$make-maker-flags + #:module-build-flags #$(sexp->gexp module-build-flags) + #:phases #$(if (pair? phases) + (sexp->gexp 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 + #:target #f + #: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 80895162f8..efade6f74b 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,9 +20,13 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build-system python) + #:use-module ((gnu packages) #:select (search-auxiliary-file)) + #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix memoization) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) @@ -70,6 +75,10 @@ extension, such as '.tar.gz'." (let ((python (resolve-interface '(gnu packages python)))) (module-ref python 'python-2))) +(define sanity-check.py + ;; The script used to validate the installation of a Python package. + (search-auxiliary-file "python/sanity-check.py")) + (define* (package-with-explicit-python python old-prefix new-prefix #:key variant-property) "Return a procedure of one argument, P. The procedure creates a package with @@ -140,7 +149,7 @@ pre-defined variants." #: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 @@ -154,19 +163,19 @@ pre-defined variants." ;; Keep the standard inputs of 'gnu-build-system'. ,@(standard-packages))) (build-inputs `(("python" ,python) + ("sanity-check.py" ,(local-file sanity-check.py)) ,@native-inputs)) (outputs outputs) (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") (use-setuptools? #t) (configure-flags ''()) - (phases '(@ (guix build python-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -176,43 +185,35 @@ pre-defined variants." (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? - #:use-setuptools? ,use-setuptools? - #: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 + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + #$(with-build-variables inputs outputs + #~(python-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:use-setuptools? #$use-setuptools? + #:system #$system + #:test-target #$test-target + #:tests? #$tests? + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (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 + #:target #f + #:guile-for-build guile))) (define python-build-system (build-system diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index 118022ec45..ccee89d5ef 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -22,7 +22,8 @@ (define-module (guix build-system qt) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system cmake) @@ -71,7 +72,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - `(#:source #:cmake #:inputs #:native-inputs #:outputs + `(#:cmake #:inputs #:native-inputs #:outputs ,@(if target '() '(#:target)))) (bag @@ -105,8 +106,9 @@ (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (qt-build store name inputs - #:key (guile #f) +(define* (qt-build name inputs + #:key + source (guile #f) (outputs '("out")) (configure-flags ''()) (search-paths '()) (make-flags ''()) @@ -121,8 +123,7 @@ (strip-flags ''("--strip-debug")) (strip-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build qt-build-system) - %standard-phases)) + (phases '%standard-phases) (qt-wrap-excluded-outputs ''()) (system (%current-system)) (imported-modules %qt-build-system-modules) @@ -131,60 +132,49 @@ "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) - (qt-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 - #:qt-wrap-excluded-outputs ,qt-wrap-excluded-outputs - #: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))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (qt-build #:source #+source + #:system #$system + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp inputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:qt-wrap-excluded-outputs #$qt-wrap-excluded-outputs + #: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 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 - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) ;;; ;;; Cross-compilation. ;;; -(define* (qt-cross-build store name +(define* (qt-cross-build name #:key - target native-drvs target-drvs + source target + build-inputs target-inputs host-inputs (guile #f) (outputs '("out")) (configure-flags ''()) @@ -193,7 +183,7 @@ provides a 'CMakeLists.txt' file as its build system." (make-flags ''()) (out-of-source? #t) (build-type "RelWithDebInfo") - (tests? #f) ; nothing can be done + (tests? #f) ; nothing can be done (test-target "test") (parallel-build? #t) (parallel-tests? #f) (validate-runpath? #t) @@ -203,8 +193,7 @@ provides a 'CMakeLists.txt' file as its build system." "--enable-deterministic-archives")) (strip-directories ''("lib" "lib64" "libexec" "bin" "sbin")) - (phases '(@ (guix build qt-build-system) - %standard-phases)) + (phases '%standard-phases) (system (%current-system)) (build (nix-system->gnu-triplet system)) (imported-modules %qt-build-system-modules) @@ -214,77 +203,53 @@ provides a 'CMakeLists.txt' file as its build system." with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." (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)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) - (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)) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) - (qt-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 - search-paths) - #:native-search-paths ',(map - search-path-specification->sexp - native-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 %outputs + #$(outputs->gexp outputs)) - (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))))) + (qt-build #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths '#$(map + search-path-specification->sexp + native-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 (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:guile-for-build guile-for-build)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define qt-build-system (build-system diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index e2bf41f18d..c4425e0a12 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -82,7 +84,7 @@ release corresponding to NAME and VERSION." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:r #:inputs #:native-inputs)) + '(#:target #:r #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -101,13 +103,13 @@ release corresponding to NAME and VERSION." (build r-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (r-build store name inputs +(define* (r-build name inputs #:key + source (tests? #t) (test-target "tests") (configure-flags ''()) - (phases '(@ (guix build r-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -118,42 +120,28 @@ release corresponding to NAME and VERSION." (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (r-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 - #:tests? ,tests? - #:test-target ,test-target - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (r-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:tests? #$tests? + #:test-target #$test-target + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp 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 - #:substitutable? substitutable?)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile + #:substitutable? substitutable?))) (define r-build-system (build-system diff --git a/guix/build-system/rakudo.scm b/guix/build-system/rakudo.scm index a02e2bad3a..05a4d9c2ad 100644 --- a/guix/build-system/rakudo.scm +++ b/guix/build-system/rakudo.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +20,8 @@ (define-module (guix build-system rakudo) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -71,7 +73,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:rakudo #:prove6 #:zef #:inputs #:native-inputs)) + '(#:target #:rakudo #:prove6 #:zef #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -96,12 +98,12 @@ (build rakudo-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (rakudo-build store name inputs +(define* (rakudo-build name inputs #:key + source (search-paths '()) (tests? #t) - (phases '(@ (guix build rakudo-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (system (%current-system)) (guile #f) @@ -112,39 +114,25 @@ (guix build utils)))) "Build SOURCE using PERL6, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (rakudo-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) - #:phases ,phases - #:system ,system - #:tests? ,tests? - #:outputs %outputs - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (rakudo-build #:name #$name + #:source #+source + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$phases + #:system #$system + #:tests? #$tests? + #:outputs #$(outputs->gexp outputs) + #:inputs #$(input-tuples->gexp 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 - #: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 builder + #:system system + #:guile-for-build guile))) (define rakudo-build-system (build-system diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm index 35edc0056d..0ee73ec969 100644 --- a/guix/build-system/renpy.scm +++ b/guix/build-system/renpy.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,7 +22,8 @@ #:use-module (guix utils) #:use-module (guix memoization) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -53,7 +55,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:renpy #:inputs #:native-inputs)) + '(#:target #:renpy #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -72,57 +74,43 @@ (build renpy-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (renpy-build store name inputs - #:key - (phases '(@ (guix build renpy-build-system) - %standard-phases)) - (configure-flags ''()) - (outputs '("out")) - (output "out") - (game "game") - (search-paths '()) - (system (%current-system)) - (guile #f) - (imported-modules %renpy-build-system-modules) - (modules '((guix build renpy-build-system) - (guix build utils)))) +(define* (renpy-build name inputs + #:key + source + (phases '%standard-phases) + (configure-flags ''()) + (outputs '("out")) + (output "out") + (game "game") + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %renpy-build-system-modules) + (modules '((guix build renpy-build-system) + (guix build utils)))) "Build SOURCE using RENPY, and with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (renpy-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 - #:phases ,phases - #:outputs %outputs - #:output ,output - #:game ,game - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (renpy-build #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:output #$output + #:game #$game + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp 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)) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) (define renpy-build-system (build-system diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 8142e8551a..342daf7978 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -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,13 +75,12 @@ 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) - (phases '(@ (guix build ruby-build-system) - %standard-phases)) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -88,42 +89,33 @@ 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 #$@(sexp->gexp 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 #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (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 + #:target #f + #:modules imported-modules + #:guile-for-build guile))) (define ruby-build-system (build-system diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index aad455c419..74901b3478 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +20,8 @@ (define-module (guix build-system scons) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -53,7 +55,7 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:scons #:inputs #:native-inputs)) + '(#:target #:scons #:inputs #:native-inputs)) (and (not target) ;XXX: no cross-compilation (bag @@ -72,15 +74,15 @@ (build scons-build) (arguments (strip-keyword-arguments private-keywords arguments))))) -(define* (scons-build store name inputs +(define* (scons-build name inputs #:key + (source #f) (tests? #t) (scons-flags ''()) - (build-targets ''()) + (build-targets #~'()) (test-target "test") - (install-targets ''("install")) - (phases '(@ (guix build scons-build-system) - %standard-phases)) + (install-targets #~'("install")) + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) @@ -91,43 +93,33 @@ "Build SOURCE using SCons, and with INPUTS. This assumes that SOURCE provides a 'SConstruct' file as its build system." (define builder - `(begin - (use-modules ,@modules) - (scons-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:scons-flags ,scons-flags - #:system ,system - #:build-targets ,build-targets - #:test-target ,test-target - #:tests? ,tests? - #:install-targets ,install-targets - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp 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 + #~(scons-build #:name #$name + #:source #+source + #:scons-flags #$(sexp->gexp scons-flags) + #:system #$system + #:build-targets #$build-targets + #:test-target #$test-target + #:tests? #$tests? + #:install-targets #$install-targets + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:inputs %build-inputs + #:search-paths + '#$(sexp->gexp + (map search-path-specification->sexp + search-paths))))))) - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:modules imported-modules - #:outputs outputs - #:guile-for-build guile-for-build)) + (gexp->derivation name builder + #:system system + #:target #f + #:guile-for-build guile)) (define scons-build-system (build-system diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index 8bbca0ccb7..c7fa2e3add 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,8 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -59,13 +61,17 @@ name for the checkout directory." (file-name (string-append name "-" version "-checkout")) (sha256 hash))) -(define (texlive-ref component id) +(define* (texlive-ref component #:optional id) "Return a <svn-reference> object for the package ID, which is part of the -given Texlive COMPONENT." +given Texlive COMPONENT. If ID is not provided, COMPONENT is used as the top +level package ID." (svn-reference (url (string-append "svn://www.tug.org/texlive/tags/" %texlive-tag "/Master/texmf-dist/" - "source/" component "/" id)) + "source/" component + (if id + (string-append "/" id) + ""))) (revision %texlive-revision))) (define %texlive-build-system-modules @@ -96,7 +102,7 @@ given Texlive COMPONENT." #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:inputs #:native-inputs + '(#:target #:inputs #:native-inputs #:texlive-latex-base #:texlive-bin)) (bag @@ -116,8 +122,9 @@ given Texlive COMPONENT." (build texlive-build) (arguments (strip-keyword-arguments private-keywords arguments)))) -(define* (texlive-build store name inputs +(define* (texlive-build name inputs #:key + source (tests? #f) tex-directory (build-targets #f) @@ -135,43 +142,31 @@ given Texlive COMPONENT." (guix build utils)))) "Build SOURCE with INPUTS." (define builder - `(begin - (use-modules ,@modules) - (texlive-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:tex-directory ,tex-directory - #:build-targets ,build-targets - #:tex-format ,tex-format - #:system ,system - #: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 - #:substitutable? substitutable?)) + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + #$(with-build-variables inputs outputs + #~(texlive-build #:name #$name + #:source #+source + #:tex-directory #$tex-directory + #:build-targets #$build-targets + #:tex-format #$tex-format + #:system #$system + #:tests? #$tests? + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:inputs %build-inputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths))))))) + + (gexp->derivation name builder + #:system system + #:target #f + #:substitutable? substitutable?)) (define texlive-build-system (build-system diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index b50ef7cd92..73d452aea2 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, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2018, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,24 +19,16 @@ (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 allowed-references) + guile builder (modules '()) allowed-references) "Return a bag for NAME." (bag (name name) @@ -54,65 +46,48 @@ #:modules ,modules #:allowed-references ,allowed-references)))) -(define* (trivial-build store name inputs +(define* (trivial-build name inputs #:key - outputs guile system builder (modules '()) + outputs guile + system builder (modules '()) search-paths allowed-references) "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is ignored." - (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))) - - (build-expression->derivation store name builder - #:inputs inputs - #:system system - #:outputs outputs - #:modules modules - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:guile-for-build - (guile-for-build store guile system))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f)) + (builder -> (if (pair? builder) + (sexp->gexp builder) + builder))) + (gexp->derivation name (with-build-variables inputs outputs builder) + #:system system + #:target #f + #:modules modules + #:allowed-references allowed-references + #:guile-for-build guile))) -(define* (trivial-cross-build store name +(define* (trivial-cross-build name #:key - target native-drvs target-drvs + target + source build-inputs target-inputs host-inputs outputs guile system builder (modules '()) search-paths native-search-paths allowed-references) "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is ignored." - (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))) - - (build-expression->derivation store name builder - #:inputs (append native-drvs target-drvs) - #:system system - #:outputs outputs - #:modules modules - #:allowed-references - (and allowed-references - (map canonicalize-reference - allowed-references)) - #:guile-for-build - (guile-for-build store guile system))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f)) + (builder -> (if (pair? builder) + (sexp->gexp builder) + builder))) + (gexp->derivation name (with-build-variables + (append build-inputs target-inputs) + outputs + builder) + #:system system + #:target target + #:modules modules + #:allowed-references allowed-references + #: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 044d2a0829..e8cd5520b8 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,46 @@ (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 '%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 #$@(sexp->gexp 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 '#$(sexp->gexp + (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 + #:target #f + #:modules imported-modules + #:guile-for-build guile))) (define waf-build-system (build-system diff --git a/guix/build/copy-build-system.scm b/guix/build/copy-build-system.scm index a86f0cde29..fb2d1db056 100644 --- a/guix/build/copy-build-system.scm +++ b/guix/build/copy-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz> +;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -58,7 +59,7 @@ In the above, FILTERS are optional. one of the elements in the list. - With `#:include-regexp`, install subpaths matching the regexps in the list. - The `#:exclude*` FILTERS work similarly. Without `#:include*` flags, - install every subpath but the files matching the `#:exlude*` filters. + install every subpath but the files matching the `#:exclude*` filters. If both `#:include*` and `#:exclude*` are specified, the exclusion is done on the inclusion list. @@ -133,8 +134,8 @@ given, then the predicate always returns DEFAULT-VALUE." file-list)))) (define* (install source target #:key include exclude include-regexp exclude-regexp) - (set! target (string-append (assoc-ref outputs "out") "/" target)) - (let ((filters? (or include exclude include-regexp exclude-regexp))) + (let ((final-target (string-append (assoc-ref outputs "out") "/" target)) + (filters? (or include exclude include-regexp exclude-regexp))) (when (and (not (file-is-directory? source)) filters?) (error "Cannot use filters when SOURCE is a file.")) @@ -143,12 +144,12 @@ given, then the predicate always returns DEFAULT-VALUE." (and (file-is-directory? source) filters?)))) (if multi-files-in-source? - (install-file-list source target + (install-file-list source final-target #:include include #:exclude exclude #:include-regexp include-regexp #:exclude-regexp exclude-regexp) - (install-simple source target))))) + (install-simple source final-target))))) (for-each (lambda (plan) (apply install plan)) install-plan) #t) diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index e41e9a6595..ba2c1b4aad 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -121,24 +121,10 @@ environment variable\n" source-directory)) "Substitute the absolute \"/bin/\" directory with the right location in the store in '.el' files." - (define (file-contains-nul-char? file) - (call-with-input-file file - (lambda (in) - (let loop ((line (read-line in 'concat))) - (cond - ((eof-object? line) #f) - ((string-index line #\nul) #t) - (else (loop (read-line in 'concat)))))) - #:binary #t)) - (let* ((out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) (el-dir (string-append out %install-dir "/" elpa-name-ver)) - ;; (ice-9 regex) uses libc's regexp routines, which cannot deal with - ;; strings containing NULs. Filter out such files. TODO: Remove - ;; this workaround when <https://bugs.gnu.org/30116> is fixed. - (el-files (remove file-contains-nul-char? - (find-files (getcwd) "\\.el$")))) + (el-files (find-files (getcwd) "\\.el$"))) (define (substitute-program-names) (substitute* el-files (("\"/bin/([^.]\\S*)\"" _ cmd-name) diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index ba680fd1a9..ccb3138fe2 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -142,8 +142,9 @@ add a dependency of that output on GLib and GTK+." (unless (member output glib-or-gtk-wrap-excluded-outputs) (let* ((bindir (string-append directory "/bin")) (libexecdir (string-append directory "/libexec")) - (bin-list (append (find-files bindir ".*") - (find-files libexecdir ".*"))) + (bin-list (filter (negate wrapped-program?) + (append (find-files bindir ".*") + (find-files libexecdir ".*")))) (datadirs (data-directories (alist-cons output directory inputs))) (gtk-mod-dirs (gtk-module-directories diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 2e7dff2034..28c719d9ca 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +36,7 @@ #:use-module (rnrs io ports) #:export (%standard-phases %license-file-regexp + %bootstrap-scripts dump-file-contents gnu-build)) @@ -57,23 +59,26 @@ "Set the 'SOURCE_DATE_EPOCH' environment variable. This is used by tools that incorporate timestamps as a way to tell them to use a fixed timestamp. See https://reproducible-builds.org/specs/source-date-epoch/." - (setenv "SOURCE_DATE_EPOCH" "1") - #t) + (setenv "SOURCE_DATE_EPOCH" "1")) (define (first-subdirectory directory) - "Return the file name of the first sub-directory of DIRECTORY." + "Return the file name of the first sub-directory of DIRECTORY or false, when +there are none." (match (scandir directory (lambda (file) (and (not (member file '("." ".."))) (file-is-directory? (string-append directory "/" file))))) - ((first . _) first))) + ((first . _) first) + (_ #f))) (define* (set-paths #:key target inputs native-inputs (search-paths '()) (native-search-paths '()) #:allow-other-keys) (define input-directories - (match inputs + ;; The "source" input can be a directory, but we don't want it for search + ;; paths. See <https://issues.guix.gnu.org/44924>. + (match (alist-delete "source" inputs) (((_ . dir) ...) dir))) @@ -113,9 +118,7 @@ See https://reproducible-builds.org/specs/source-date-epoch/." #:separator separator #:type type #:pattern pattern))) - native-search-paths)) - - #t) + native-search-paths))) (define* (install-locale #:key (locale "en_US.utf8") @@ -134,15 +137,13 @@ chance to be set." (setenv (locale-category->string locale-category) locale) (format (current-error-port) "using '~a' locale for category ~s~%" - locale (locale-category->string locale-category)) - #t) + locale (locale-category->string locale-category))) (lambda args ;; This is known to fail for instance in early bootstrap where locales ;; are not available. (format (current-error-port) "warning: failed to install '~a' locale: ~a~%" - locale (strerror (system-error-errno args))) - #t))) + locale (strerror (system-error-errno args)))))) (define* (unpack #:key source #:allow-other-keys) "Unpack SOURCE in the working directory, and change directory within the @@ -156,13 +157,25 @@ working directory." ;; Preserve timestamps (set to the Epoch) on the copied tree so that ;; things work deterministically. (copy-recursively source "." - #:keep-mtime? #t)) + #:keep-mtime? #t) + ;; Make the source checkout files writable, for convenience. + (for-each (lambda (f) + (false-if-exception (make-file-writable f))) + (find-files "."))) (begin - (if (string-suffix? ".zip" source) - (invoke "unzip" source) - (invoke "tar" "xvf" source)) - (chdir (first-subdirectory ".")))) - #t) + (cond + ((string-suffix? ".zip" source) + (invoke "unzip" source)) + ((tarball? source) + (invoke "tar" "xvf" source)) + (else + (let ((name (strip-store-file-name source)) + (command (compressor source))) + (copy-file source name) + (when command + (invoke command "--decompress" name))))) + ;; Attempt to change into child directory. + (and=> (first-subdirectory ".") chdir)))) (define %bootstrap-scripts ;; Typical names of Autotools "bootstrap" scripts. @@ -205,8 +218,7 @@ working directory." (invoke "autoreconf" "-vif") (format #t "no 'configure.ac' or anything like that, \ doing nothing~%")))) - (format #t "GNU build system bootstrapping not needed~%")) - #t) + (format #t "GNU build system bootstrapping not needed~%"))) ;; See <http://bugs.gnu.org/17840>. (define* (patch-usr-bin-file #:key native-inputs inputs @@ -220,8 +232,7 @@ things like the ABI being used." (for-each (lambda (file) (when (executable-file? file) (patch-/usr/bin/file file))) - (find-files "." "^configure$"))) - #t) + (find-files "." "^configure$")))) (define* (patch-source-shebangs #:key source #:allow-other-keys) "Patch shebangs in all source files; this includes non-executable @@ -233,8 +244,7 @@ $CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's (lambda (file stat) ;; Filter out symlinks. (eq? 'regular (stat:type stat))) - #:stat lstat)) - #t) + #:stat lstat))) (define (patch-generated-file-shebangs . rest) "Patch shebangs in generated files, including `SHELL' variables in @@ -249,9 +259,7 @@ makefiles." #:stat lstat)) ;; Patch `SHELL' in generated makefiles. - (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")) - - #t) + (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))) (define* (configure #:key build target native-inputs inputs outputs (configure-flags '()) out-of-source? @@ -381,8 +389,7 @@ makefiles." `("-j" ,(number->string (parallel-job-count))) '()) ,@make-flags))) - (format #t "test suite not run~%")) - #t) + (format #t "test suite not run~%"))) (define* (install #:key (make-flags '()) #:allow-other-keys) (apply invoke "make" "install" make-flags)) @@ -415,8 +422,7 @@ makefiles." (for-each (lambda (dir) (let ((files (list-of-files dir))) (for-each (cut patch-shebang <> path) files))) - output-bindirs))) - #t) + output-bindirs)))) (define* (strip #:key target outputs (strip-binaries? #t) (strip-command (if target @@ -425,7 +431,7 @@ makefiles." (objcopy-command (if target (string-append target "-objcopy") "objcopy")) - (strip-flags '("--strip-debug" + (strip-flags '("--strip-unneeded" "--enable-deterministic-archives")) (strip-directories '("lib" "lib64" "libexec" "bin" "sbin")) @@ -514,8 +520,7 @@ makefiles." (let ((sub (string-append dir "/" d))) (and (directory-exists? sub) sub))) strip-directories))) - outputs))) - #t) + outputs)))) (define* (validate-runpath #:key (validate-runpath? #t) @@ -560,9 +565,7 @@ phase after stripping." outputs))) (unless (every* validate dirs) (error "RUNPATH validation failed"))) - (format (current-error-port) "skipping RUNPATH validation~%")) - - #t) + (format (current-error-port) "skipping RUNPATH validation~%"))) (define* (validate-documentation-location #:key outputs #:allow-other-keys) @@ -582,8 +585,7 @@ and 'man/'. This phase moves directories to the right place if needed." (match outputs (((names . directories) ...) - (for-each validate-output directories))) - #t) + (for-each validate-output directories)))) (define* (reset-gzip-timestamps #:key outputs #:allow-other-keys) "Reset embedded timestamps in gzip files found in OUTPUTS." @@ -599,8 +601,7 @@ and 'man/'. This phase moves directories to the right place if needed." (match outputs (((names . directories) ...) - (for-each process-directory directories))) - #t) + (for-each process-directory directories)))) (define* (compress-documentation #:key outputs (compress-documentation? #t) @@ -616,7 +617,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS." (let ((target (readlink link))) (delete-file link) (symlink (string-append target compressed-documentation-extension) - link))) + (string-append link compressed-documentation-extension)))) (define (has-links? file) ;; Return #t if FILE has hard links. @@ -679,8 +680,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS." (match outputs (((names . directories) ...) (for-each maybe-compress directories))) - (format #t "not compressing documentation~%")) - #t) + (format #t "not compressing documentation~%"))) (define* (delete-info-dir-file #:key outputs #:allow-other-keys) "Delete any 'share/info/dir' file from OUTPUTS." @@ -689,8 +689,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS." (let ((info-dir-file (string-append directory "/share/info/dir"))) (when (file-exists? info-dir-file) (delete-file info-dir-file))))) - outputs) - #t) + outputs)) (define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys) @@ -730,8 +729,74 @@ which cannot be found~%" (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest) (string-append "TryExec=" (which binary) rest))))))))) - outputs) - #t) + outputs)) + +(define* (make-dynamic-linker-cache #:key outputs + (make-dynamic-linker-cache? #t) + #:allow-other-keys) + "Create a dynamic linker cache under 'etc/ld.so.cache' in each of the +OUTPUTS. This reduces application startup time by avoiding the 'stat' storm +that traversing all the RUNPATH entries entails." + (define (make-cache-for-output directory) + (define bin-directories + (filter-map (lambda (sub-directory) + (let ((directory (string-append directory "/" + sub-directory))) + (and (directory-exists? directory) + directory))) + '("bin" "sbin" "libexec"))) + + (define programs + ;; Programs that can benefit from the ld.so cache. + (append-map (lambda (directory) + (if (directory-exists? directory) + (find-files directory + (lambda (file stat) + (and (executable-file? file) + (elf-file? file)))) + '())) + bin-directories)) + + (define library-path + ;; Directories containing libraries that PROGRAMS depend on, + ;; recursively. + (delete-duplicates + (append-map (lambda (program) + (map dirname (file-needed/recursive program))) + programs))) + + (define cache-file + (string-append directory "/etc/ld.so.cache")) + + (define ld.so.conf + (string-append (or (getenv "TMPDIR") "/tmp") + "/ld.so.conf")) + + (unless (null? library-path) + (mkdir-p (dirname cache-file)) + (guard (c ((invoke-error? c) + ;; Do not treat 'ldconfig' failure as an error. + (format (current-error-port) + "warning: 'ldconfig' failed:~%") + (report-invoke-error c (current-error-port)))) + ;; Create a config file to tell 'ldconfig' where to look for the + ;; libraries that PROGRAMS need. + (call-with-output-file ld.so.conf + (lambda (port) + (for-each (lambda (directory) + (display directory port) + (newline port)) + library-path))) + + (invoke "ldconfig" "-f" ld.so.conf "-C" cache-file) + (format #t "created '~a' from ~a library search path entries~%" + cache-file (length library-path))))) + + (if make-dynamic-linker-cache? + (match outputs + (((_ . directories) ...) + (for-each make-cache-for-output directories))) + (format #t "ld.so cache not built~%"))) (define %license-file-regexp ;; Regexp matching license files. @@ -796,8 +861,7 @@ which cannot be found~%" package)) (map (cut string-append source "/" <>) files))) (format (current-error-port) - "failed to find license files~%")) - #t)) + "failed to find license files~%")))) (define %standard-phases ;; Standard build phases, as a list of symbol/procedure pairs. @@ -813,6 +877,7 @@ which cannot be found~%" validate-documentation-location delete-info-dir-file patch-dot-desktop-files + make-dynamic-linker-cache install-license-files reset-gzip-timestamps compress-documentation))) @@ -840,26 +905,30 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." (exit 1))) ;; The trick is to #:allow-other-keys everywhere, so that each procedure in ;; PHASES can pick the keyword arguments it's interested in. - (every (match-lambda - ((name . proc) - (let ((start (current-time time-monotonic))) - (format #t "starting phase `~a'~%" name) - (let ((result (apply proc args)) - (end (current-time time-monotonic))) - (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" - name result - (elapsed-time end start)) - - ;; Issue a warning unless the result is #t. - (unless (eqv? result #t) - (format (current-error-port) "\ -## WARNING: phase `~a' returned `~s'. Return values other than #t -## are deprecated. Please migrate this package so that its phase -## procedures report errors by raising an exception, and otherwise -## always return #t.~%" - name result)) - - ;; Dump the environment variables as a shell script, for handy debugging. - (system "export > $NIX_BUILD_TOP/environment-variables") - result)))) - phases))) + (for-each (match-lambda + ((name . proc) + (let ((start (current-time time-monotonic))) + (define (end-of-phase success?) + (let ((end (current-time time-monotonic))) + (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" + name success? + (elapsed-time end start)) + + ;; Dump the environment variables as a shell script, + ;; for handy debugging. + (system "export > $NIX_BUILD_TOP/environment-variables"))) + + (format #t "starting phase `~a'~%" name) + (with-throw-handler #t + (lambda () + (apply proc args) + (end-of-phase #t)) + (lambda args + ;; This handler executes before the stack is unwound. + ;; The exception is automatically re-thrown from here, + ;; and we should get a proper backtrace. + (format (current-error-port) + "error: in phase '~a': uncaught exception: +~{~s ~}~%" name args) + (end-of-phase #f)))))) + phases))) diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm index e8ea66dfb3..2a74d51dd9 100644 --- a/guix/build/gremlin.scm +++ b/guix/build/gremlin.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,6 +41,17 @@ elf-dynamic-info-runpath expand-origin + file-dynamic-info + file-runpath + file-needed + file-needed/recursive + + missing-runpath-error? + missing-runpath-error-file + runpath-too-long-error? + runpath-too-long-error-file + set-file-runpath + validate-needed-in-runpath strip-runpath)) @@ -215,7 +226,9 @@ string table if the type is a string." (#f #f) ((? elf-segment? dynamic) (let ((entries (dynamic-entries elf dynamic))) - (%elf-dynamic-info (find (matching-entry DT_SONAME) entries) + (%elf-dynamic-info (and=> (find (matching-entry DT_SONAME) + entries) + dynamic-entry-value) (filter-map (lambda (entry) (and (= (dynamic-entry-type entry) DT_NEEDED) @@ -232,6 +245,63 @@ string table if the type is a string." dynamic-entry-value)) '())))))) +(define (file-dynamic-info file) + "Return the <elf-dynamic-info> record of FILE, or #f if FILE lacks dynamic +info." + (call-with-input-file file + (lambda (port) + (elf-dynamic-info (parse-elf (get-bytevector-all port)))))) + +(define (file-runpath file) + "Return the DT_RUNPATH dynamic entry of FILE as a list of strings, or #f if +FILE lacks dynamic info." + (and=> (file-dynamic-info file) elf-dynamic-info-runpath)) + +(define (file-needed file) + "Return the list of DT_NEEDED dynamic entries of FILE, or #f if FILE lacks +dynamic info." + (and=> (file-dynamic-info file) elf-dynamic-info-needed)) + +(define (file-needed/recursive file) + "Return two values: the list of absolute .so file names FILE depends on, +recursively, and the list of .so file names that could not be found. File +names are resolved by searching the RUNPATH of the file that NEEDs them. + +This is similar to the info returned by the 'ldd' command." + (let loop ((files (list file)) + (result '()) + (not-found '())) + (match files + (() + (values (reverse result) + (reverse (delete-duplicates not-found)))) + ((file . rest) + (match (file-dynamic-info file) + (#f + (loop rest result not-found)) + (info + (let ((runpath (elf-dynamic-info-runpath info)) + (needed (elf-dynamic-info-needed info))) + (if (and runpath needed) + (let* ((runpath (map (cute expand-origin <> (dirname file)) + runpath)) + (resolved (map (cut search-path runpath <>) + needed)) + (failed (filter-map (lambda (needed resolved) + (and (not resolved) + (not (libc-library? needed)) + needed)) + needed resolved)) + (needed (remove (lambda (value) + (or (not value) + ;; XXX: quadratic + (member value result))) + resolved))) + (loop (append rest needed) + (append needed result) + (append failed not-found))) + (loop rest result not-found))))))))) + (define %libc-libraries ;; List of libraries as of glibc 2.21 (there are more but those are ;; typically mean to be LD_PRELOADed and thus do not appear as NEEDED.) @@ -364,4 +434,49 @@ according to DT_NEEDED." (false-if-exception (close-port port)) (apply throw key args)))) -;;; gremlin.scm ends here + +(define-condition-type &missing-runpath-error &elf-error + missing-runpath-error? + (file missing-runpath-error-file)) + +(define-condition-type &runpath-too-long-error &elf-error + runpath-too-long-error? + (file runpath-too-long-error-file)) + +(define (set-file-runpath file path) + "Set the value of the DT_RUNPATH dynamic entry of FILE, which must name an +ELF file, to PATH, a list of strings. Raise a &missing-runpath-error or +&runpath-too-long-error when appropriate." + (define (call-with-input+output-file file proc) + (let ((port (open-file file "r+b"))) + (guard (c (#t (close-port port) (raise c))) + (proc port) + (close-port port)))) + + (call-with-input+output-file file + (lambda (port) + (let* ((elf (parse-elf (get-bytevector-all port))) + (entries (dynamic-entries elf (dynamic-link-segment elf))) + (runpath (find (lambda (entry) + (= DT_RUNPATH (dynamic-entry-type entry))) + entries)) + (path (string->utf8 (string-join path ":")))) + (unless runpath + (raise (condition (&missing-runpath-error (elf elf) + (file file))))) + + ;; There might be padding left beyond RUNPATH in the string table, but + ;; we don't know, so assume there's no padding. + (unless (<= (bytevector-length path) + (bytevector-length + (string->utf8 (dynamic-entry-value runpath)))) + (raise (condition (&runpath-too-long-error (elf #f #;elf) + (file file))))) + + (seek port (dynamic-entry-offset runpath) SEEK_SET) + (put-bytevector port path) + (put-u8 port 0))))) + +;;; Local Variables: +;;; eval: (put 'call-with-input+output-file 'scheme-indent-function 1) +;;; End: diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 8a02cb68dd..17d2637f87 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -281,7 +281,7 @@ DEPENDENCY-PREFIXES to ensure references to those libraries are retained." type compress? #:allow-other-keys) - "Generate an executable by using asdf operation TYPE, containing whithin the + "Generate an executable by using asdf operation TYPE, containing within the image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an executable. Link in any asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are retained." diff --git a/guix/build/maven/pom.scm b/guix/build/maven/pom.scm index c92d409d2b..dd61f659c2 100644 --- a/guix/build/maven/pom.scm +++ b/guix/build/maven/pom.scm @@ -243,7 +243,7 @@ to re-declare the namespaces in the top-level element." (define* (fix-pom-dependencies pom-file inputs #:key with-plugins? with-build-dependencies? (excludes '()) (local-packages '())) - "Open @var{pom-file}, and override its content, rewritting its dependencies + "Open @var{pom-file}, and override its content, rewriting its dependencies to set their version to the latest version available in the @var{inputs}. @var{#:with-plugins?} controls whether plugins are also overridden. diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm index 8043a84abb..cc2ba83889 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -100,7 +100,7 @@ for example libraries only needed for the tests." (find-files dir elf-pred)) existing-elf-dirs)))) (for-each strip-runpath elf-list))))) - (for-each handle-output outputs) + (for-each handle-output (alist-delete "debug" outputs)) #t) (define %standard-phases diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm index 92158a033f..f7f51af301 100644 --- a/guix/build/minify-build-system.scm +++ b/guix/build/minify-build-system.scm @@ -23,6 +23,7 @@ #:use-module (guix build utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:use-module (ice-9 popen) #:export (%standard-phases minify-build @@ -42,14 +43,17 @@ (minified (open-pipe* OPEN_READ "uglify-js" file))) (call-with-output-file installed (cut dump-port minified <>)) - #t)) + (match (close-pipe minified) + (0 #t) + (status + (error "uglify-js failed" status))))) (define* (build #:key javascript-files #:allow-other-keys) (let ((files (or javascript-files (find-files "src" "\\.js$")))) (mkdir-p "guix/build") - (every (cut minify <> #:directory "guix/build/") files))) + (for-each (cut minify <> #:directory "guix/build/") files))) (define* (install #:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -60,8 +64,7 @@ (if (not (zero? (stat:size (stat file)))) (install-file file js) (error "File is empty: " file))) - (find-files "guix/build" "\\.min\\.js$"))) - #t) + (find-files "guix/build" "\\.min\\.js$")))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 09bd8465c8..5b1339d14c 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -6,6 +6,10 @@ ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2019, 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +31,7 @@ #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (ice-9 ftw) + #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -128,6 +133,15 @@ (apply invoke "python" "./setup.py" command params))) (error "no setup.py found"))) +(define* (sanity-check #:key tests? inputs outputs #:allow-other-keys) + "Ensure packages depending on this package via setuptools work properly, +their advertised endpoints work and their top level modules are importable +without errors." + (let ((sanity-check.py (assoc-ref inputs "sanity-check.py"))) + ;; Make sure the working directory is empty (i.e. no Python modules in it) + (with-directory-excursion "/tmp" + (invoke "python" sanity-check.py (site-packages inputs outputs))))) + (define* (build #:key use-setuptools? #:allow-other-keys) "Build a given Python package." (call-setuppy "build" '() use-setuptools?) @@ -154,65 +168,80 @@ (major+minor (take components 2))) (string-join major+minor "."))) +(define (python-output outputs) + "Return the path of the python output, if there is one, or fall-back to out." + (or (assoc-ref outputs "python") + (assoc-ref outputs "out"))) + (define (site-packages inputs outputs) "Return the path of the current output's Python site-package." - (let* ((out (assoc-ref outputs "out")) + (let* ((out (python-output outputs)) (python (assoc-ref inputs "python"))) - (string-append out "/lib/python" - (python-version python) - "/site-packages/"))) + (string-append out "/lib/python" (python-version python) "/site-packages"))) (define (add-installed-pythonpath inputs outputs) - "Prepend the Python site-package of OUTPUT to PYTHONPATH. This is useful -when running checks after installing the package." - (let ((old-path (getenv "PYTHONPATH")) - (add-path (site-packages inputs outputs))) - (setenv "PYTHONPATH" - (string-append add-path - (if old-path (string-append ":" old-path) ""))) - #t)) + "Prepend the site-package of OUTPUT to GUIX_PYTHONPATH. This is useful when +running checks after installing the package." + (setenv "GUIX_PYTHONPATH" (string-append (site-packages inputs outputs) ":" + (getenv "GUIX_PYTHONPATH")))) + +(define* (add-install-to-pythonpath #:key inputs outputs #:allow-other-keys) + "A phase that just wraps the 'add-installed-pythonpath' procedure." + (add-installed-pythonpath inputs outputs)) -(define* (install #:key outputs (configure-flags '()) use-setuptools? +(define* (add-install-to-path #:key outputs #:allow-other-keys) + "Adding Python scripts to PATH is also often useful in tests." + (setenv "PATH" (string-append (assoc-ref outputs "out") + "/bin:" + (getenv "PATH")))) + +(define* (install #:key inputs outputs (configure-flags '()) use-setuptools? #:allow-other-keys) "Install a given Python package." - (let* ((out (assoc-ref outputs "out")) - (params (append (list (string-append "--prefix=" out)) + (let* ((out (python-output outputs)) + (python (assoc-ref inputs "python")) + (major-minor (map string->number + (take (string-split (python-version python) #\.) 2))) + (<3.7? (match major-minor + ((major minor) + (or (< major 3) (and (= major 3) (< minor 7)))))) + (params (append (list (string-append "--prefix=" out) + "--no-compile") (if use-setuptools? ;; distutils does not accept these flags (list "--single-version-externally-managed" - "--root=/") + "--root=/") '()) configure-flags))) (call-setuppy "install" params use-setuptools?) - #t)) + ;; Rather than produce potentially non-reproducible .pyc files on Pythons + ;; older than 3.7, whose 'compileall' module lacks the + ;; '--invalidation-mode' option, do not generate any. + (unless <3.7? + (invoke "python" "-m" "compileall" "--invalidation-mode=unchecked-hash" + out)))) (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) (find-files dir (lambda (file stat) (and (eq? 'regular (stat:type stat)) - (not (wrapper? file)))))) + (not (wrapped-program? file)))))) (define bindirs (append-map (match-lambda - ((_ . dir) - (list (string-append dir "/bin") - (string-append dir "/sbin")))) + ((_ . dir) + (list (string-append dir "/bin") + (string-append dir "/sbin")))) outputs)) - (let* ((out (assoc-ref outputs "out")) - (python (assoc-ref inputs "python")) - (var `("PYTHONPATH" prefix - ,(cons (string-append out "/lib/python" - (python-version python) - "/site-packages") - (search-path-as-string->list - (or (getenv "PYTHONPATH") "")))))) + (let* ((var `("GUIX_PYTHONPATH" prefix + ,(search-path-as-string->list + (or (getenv "GUIX_PYTHONPATH") ""))))) (for-each (lambda (dir) (let ((files (list-of-files dir))) (for-each (cut wrap-program <> var) files))) - bindirs) - #t)) + bindirs))) (define* (rename-pth-file #:key name inputs outputs #:allow-other-keys) "Rename easy-install.pth to NAME.pth to avoid conflicts between packages @@ -220,16 +249,11 @@ installed with setuptools." ;; Even if the "easy-install.pth" is not longer created, we kept this phase. ;; There still may be packages creating an "easy-install.pth" manually for ;; some good reason. - (let* ((out (assoc-ref outputs "out")) - (python (assoc-ref inputs "python")) - (site-packages (string-append out "/lib/python" - (python-version python) - "/site-packages")) + (let* ((site-packages (site-packages inputs outputs)) (easy-install-pth (string-append site-packages "/easy-install.pth")) (new-pth (string-append site-packages "/" name ".pth"))) (when (file-exists? easy-install-pth) - (rename-file easy-install-pth new-pth)) - #t)) + (rename-file easy-install-pth new-pth)))) (define* (ensure-no-mtimes-pre-1980 #:rest _) "Ensure that there are no mtimes before 1980-01-02 in the source tree." @@ -241,32 +265,49 @@ installed with setuptools." (ftw "." (lambda (file stat flag) (unless (<= early-1980 (stat:mtime stat)) (utime file early-1980 early-1980)) - #t)) - #t)) + #t)))) (define* (enable-bytecode-determinism #:rest _) "Improve determinism of pyc files." ;; Use deterministic hashes for strings, bytes, and datetime objects. (setenv "PYTHONHASHSEED" "0") - #t) + ;; Prevent Python from creating .pyc files when loading modules (such as + ;; when running a test suite). + (setenv "PYTHONDONTWRITEBYTECODE" "1")) + +(define* (ensure-no-cythonized-files #:rest _) + "Check the source code for @code{.c} files which may have been pre-generated +by Cython." + (for-each + (lambda (file) + (let ((generated-file + (string-append (string-drop-right file 3) "c"))) + (when (file-exists? generated-file) + (format #t "Possible Cythonized file found: ~a~%" generated-file)))) + (find-files "." "\\.pyx$"))) (define %standard-phases ;; The build phase only builds C extensions and copies the Python sources, - ;; while the install phase byte-compiles and copies them to the prefix - ;; directory. The tests are run after the install phase because otherwise - ;; the cached .pyc generated during the tests execution seem to interfere - ;; with the byte compilation of the install phase. + ;; while the install phase copies then byte-compiles the sources to the + ;; prefix directory. The check phase is moved after the installation phase + ;; to ease testing the built package. (modify-phases gnu:%standard-phases (add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980) (add-after 'ensure-no-mtimes-pre-1980 'enable-bytecode-determinism enable-bytecode-determinism) + (add-after 'enable-bytecode-determinism 'ensure-no-cythonized-files + ensure-no-cythonized-files) (delete 'bootstrap) (delete 'configure) ;not needed (replace 'build build) (delete 'check) ;moved after the install phase (replace 'install install) - (add-after 'install 'check check) - (add-after 'install 'wrap wrap) + (add-after 'install 'add-install-to-pythonpath add-install-to-pythonpath) + (add-after 'add-install-to-pythonpath 'add-install-to-path + add-install-to-path) + (add-after 'add-install-to-path 'wrap wrap) + (add-after 'wrap 'check check) + (add-after 'check 'sanity-check sanity-check) (add-before 'strip 'rename-pth-file rename-pth-file))) (define* (python-build #:key inputs (phases %standard-phases) diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index f59b0c420f..762fd8a2ee 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -111,7 +111,10 @@ add a dependency of that output on Qt." (define (find-files-to-wrap directory) (append-map (lambda (dir) - (if (directory-exists? dir) (find-files dir ".*") (list))) + (if (directory-exists? dir) + (find-files dir (lambda (file stat) + (not (wrapped-program? file)))) + '())) (list (string-append directory "/bin") (string-append directory "/sbin") (string-append directory "/libexec") diff --git a/guix/build/rakudo-build-system.scm b/guix/build/rakudo-build-system.scm index dbdeb1ccd2..b2c090f946 100644 --- a/guix/build/rakudo-build-system.scm +++ b/guix/build/rakudo-build-system.scm @@ -97,7 +97,8 @@ (map (cut string-append dir "/" <>) (or (scandir dir (lambda (f) (let ((s (stat (string-append dir "/" f)))) - (eq? 'regular (stat:type s))))) + (and (eq? 'regular (stat:type s)) + (not (wrapped-program? f)))))) '()))) (define bindirs diff --git a/guix/build/rpath.scm b/guix/build/rpath.scm deleted file mode 100644 index 75a1fef5ef..0000000000 --- a/guix/build/rpath.scm +++ /dev/null @@ -1,59 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -(define-module (guix build rpath) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) - #:export (%patchelf - file-rpath - augment-rpath)) - -;;; Commentary: -;;; -;;; Tools to manipulate the RPATH and RUNPATH of ELF binaries. Currently they -;;; rely on PatchELF. -;;; -;;; Code: - -(define %patchelf - ;; The `patchelf' command. - (make-parameter "patchelf")) - -(define %not-colon - (char-set-complement (char-set #\:))) - -(define (file-rpath file) - "Return the RPATH (or RUNPATH) of FILE as a list of directory names, or #f -on failure." - (let* ((p (open-pipe* OPEN_READ (%patchelf) "--print-rpath" file)) - (l (read-line p))) - (and (zero? (close-pipe p)) - (string-tokenize l %not-colon)))) - -(define (augment-rpath file dir) - "Add DIR to the front of the RPATH and RUNPATH of FILE. Return the new -RPATH as a list, or #f on failure." - (let* ((rpath (or (file-rpath file) '())) - (rpath* (cons dir rpath))) - (format #t "~a: changing RPATH from ~s to ~s~%" - file rpath rpath*) - (and (zero? (system* (%patchelf) "--set-rpath" - (string-join rpath* ":") file)) - rpath*))) - -;;; rpath.scm ends here diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index c957a61115..9aceb187a4 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Pjotr Prins <pjotr.public01@thebird.nl> ;;; Copyright © 2015, 2016 Ben Woodcroft <donttrustben@gmail.com> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -73,13 +74,19 @@ directory." (define* (replace-git-ls-files #:key source #:allow-other-keys) "Many gemspec files downloaded from outside rubygems.org use `git ls-files` -to list of the files to be included in the built gem. However, since this +to list the files to be included in the built gem. However, since this operation is not deterministic, we replace it with `find`." - (when (not (gem-archive? source)) + (unless (gem-archive? source) (let ((gemspec (first-gemspec))) + ;; Do not include the freshly built .gem itself as it causes problems. + ;; Strip the first 2 characters ("./") to more exactly match the output + ;; given by 'git ls-files'. This is useful to prevent breaking regexps + ;; that could be used to filter the list of files. (substitute* gemspec - (("`git ls-files`") "`find . -type f |sort`") - (("`git ls-files -z`") "`find . -type f -print0 |sort -z`")))) + (("`git ls-files`") + "`find . -type f -not -regex '.*\\.gem$' | sort | cut -c3-`") + (("`git ls-files -z`") + "`find . -type f -not -regex '.*\\.gem$' -print0 | sort -z | cut -zc3-`")))) #t) (define* (extract-gemspec #:key source #:allow-other-keys) @@ -129,11 +136,7 @@ is #f." #:allow-other-keys) "Install the gem archive SOURCE to the output store item. Additional GEM-FLAGS are passed to the 'gem' invocation, if present." - (let* ((ruby-version - (match:substring (string-match "ruby-(.*)\\.[0-9]$" - (assoc-ref inputs "ruby")) - 1)) - (out (assoc-ref outputs "out")) + (let* ((out (assoc-ref outputs "out")) (vendor-dir (string-append out "/lib/ruby/vendor_ruby")) (gem-file (first-matching-file "\\.gem$")) (gem-file-basename (basename gem-file)) @@ -144,8 +147,8 @@ GEM-FLAGS are passed to the 'gem' invocation, if present." (setenv "GEM_VENDOR" vendor-dir) (or (zero? - ;; 'zero? system*' allows the custom error handling to function as - ;; expected, while 'invoke' raises its own exception. + ;; 'zero? system*' allows the custom error handling to function as + ;; expected, while 'invoke' raises its own exception. (apply system* "gem" "install" gem-file "--verbose" "--local" "--ignore-dependencies" "--vendor" diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index 841c631dae..4c255700bb 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,39 +41,11 @@ (string-append "&" format) file)) -(define* (configure #:key inputs #:allow-other-keys) - (let* ((out (string-append (getcwd) "/.texlive-union")) - (texmf.cnf (string-append out "/share/texmf-dist/web2c/texmf.cnf"))) - ;; Build a modifiable union of all inputs (but exclude bash) - (match inputs - (((names . directories) ...) - (union-build out (filter directory-exists? directories) - #:create-all-directories? #t - #:log-port (%make-void-port "w")))) - - ;; The configuration file "texmf.cnf" is provided by the - ;; "texlive-bin" package. We take it and override only the - ;; setting for TEXMFROOT and TEXMF. This file won't be consulted - ;; by default, though, so we still need to set TEXMFCNF. - (substitute* texmf.cnf - (("^TEXMFROOT = .*") - (string-append "TEXMFROOT = " out "/share\n")) - (("^TEXMF = .*") - "TEXMF = $TEXMFROOT/share/texmf-dist\n")) - (setenv "TEXMFCNF" (dirname texmf.cnf)) - (setenv "TEXMF" (string-append out "/share/texmf-dist")) - - ;; Don't truncate lines. - (setenv "error_line" "254") ; must be less than 255 - (setenv "half_error_line" "238") ; must be less than error_line - 15 - (setenv "max_print_line" "1000")) - (mkdir "build") - #t) - (define* (build #:key inputs build-targets tex-format #:allow-other-keys) - (every (cut compile-with-latex tex-format <>) - (if build-targets build-targets - (scandir "." (cut string-suffix? ".ins" <>))))) + (mkdir "build") + (for-each (cut compile-with-latex tex-format <>) + (if build-targets build-targets + (scandir "." (cut string-suffix? ".ins" <>))))) (define* (install #:key outputs tex-directory #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -81,13 +54,12 @@ (mkdir-p target) (for-each delete-file (find-files "." "\\.(log|aux)$")) (for-each (cut install-file <> target) - (find-files "build" ".*")) - #t)) + (find-files "build" ".*")))) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'bootstrap) - (replace 'configure configure) + (delete 'configure) (replace 'build build) (delete 'check) (replace 'install install))) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 419c10195b..dbfc0a9142 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,10 +1,12 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015, 2018, 2021 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,9 +51,14 @@ package-name->name+version parallel-job-count + compressor + tarball? + %xz-parallel-args + directory-exists? executable-file? symbolic-link? + call-with-temporary-output-file call-with-ascii-input-file elf-file? ar-file? @@ -89,7 +96,7 @@ patch-/usr/bin/file fold-port-matches remove-store-references - wrapper? + wrapped-program? wrap-program wrap-script @@ -134,12 +141,39 @@ ;;; +;;; Compression helpers. +;;; + +(define (compressor file-name) + "Return the name of the compressor package/binary used to compress or +decompress FILE-NAME, based on its file extension, else false." + (cond ((string-suffix? "gz" file-name) "gzip") + ((string-suffix? "Z" file-name) "gzip") + ((string-suffix? "bz2" file-name) "bzip2") + ((string-suffix? "lz" file-name) "lzip") + ((string-suffix? "zip" file-name) "unzip") + ((string-suffix? "xz" file-name) "xz") + (else #f))) ;no compression used/unknown file extension + +(define (tarball? file-name) + "True when FILE-NAME has a tar file extension." + (string-match "\\.(tar(\\..*)?|tgz|tbz)$" file-name)) + +(define (%xz-parallel-args) + "The xz arguments required to enable bit-reproducible, multi-threaded +compression." + (list "--memlimit=50%" + (format #f "--threads=~a" (max 2 (parallel-job-count))))) + + +;;; ;;; Directories. ;;; (define (%store-directory) "Return the directory name of the store." - (or (getenv "NIX_STORE") + (or (getenv "NIX_STORE_DIR") ;outside of builder + (getenv "NIX_STORE") ;inside builder, set by the daemon "/gnu/store")) (define (store-file-name? file) @@ -197,6 +231,22 @@ introduce the version part." "Return #t if FILE is a symbolic link (aka. \"symlink\".)" (eq? (stat:type (lstat file)) 'symlink)) +(define (call-with-temporary-output-file proc) + "Call PROC with a name of a temporary file and open output port to that +file; close the file and delete it when leaving the dynamic extent of this +call." + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/guix-file.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (close out)) + (false-if-exception (delete-file template)))))) + (define (call-with-ascii-input-file file proc) "Open FILE as an ASCII or binary file, and pass the resulting port to PROC. FILE is closed when PROC's dynamic extent is left. Return the @@ -322,11 +372,13 @@ name." #:key (log (current-output-port)) (follow-symlinks? #f) - keep-mtime?) + (copy-file copy-file) + keep-mtime? keep-permissions?) "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS? -is true; otherwise, just preserve them. When KEEP-MTIME? is true, keep the -modification time of the files in SOURCE on those of DESTINATION. Write -verbose output to the LOG port." +is true; otherwise, just preserve them. Call COPY-FILE to copy regular files. +When KEEP-MTIME? is true, keep the modification time of the files in SOURCE on +those of DESTINATION. When KEEP-PERMISSIONS? is true, preserve file +permissions. Write verbose output to the LOG port." (define strip-source (let ((len (string-length source))) (lambda (file) @@ -343,16 +395,21 @@ verbose output to the LOG port." (symlink target dest))) (else (copy-file file dest) - (when keep-mtime? - (set-file-time dest stat)))))) + (when keep-permissions? + (chmod dest (stat:perms stat))))) + (when keep-mtime? + (set-file-time dest stat)))) (lambda (dir stat result) ; down (let ((target (string-append destination (strip-source dir)))) - (mkdir-p target) - (when keep-mtime? - (set-file-time target stat)))) + (mkdir-p target))) (lambda (dir stat result) ; up - result) + (let ((target (string-append destination + (strip-source dir)))) + (when keep-mtime? + (set-file-time target stat)) + (when keep-permissions? + (chmod target (stat:perms stat))))) (const #t) ; skip (lambda (file stat errno result) (format (current-error-port) "i/o error: ~a: ~a~%" @@ -365,6 +422,16 @@ verbose output to the LOG port." stat lstat))) +(define-syntax-rule (warn-on-error expr file) + (catch 'system-error + (lambda () + expr) + (lambda args + (format (current-error-port) + "warning: failed to delete ~a: ~a~%" + file (strerror + (system-error-errno args)))))) + (define* (delete-file-recursively dir #:key follow-mounts?) "Delete DIR recursively, like `rm -rf', without following symlinks. Don't @@ -375,10 +442,10 @@ errors." (or follow-mounts? (= dev (stat:dev stat)))) (lambda (file stat result) ; leaf - (delete-file file)) + (warn-on-error (delete-file file) file)) (const #t) ; down (lambda (dir stat result) ; up - (rmdir dir)) + (warn-on-error (rmdir dir) dir)) (const #t) ; skip (lambda (file stat errno result) (format (current-error-port) @@ -746,6 +813,31 @@ PROC's result is returned." (lambda (key . args) (false-if-exception (delete-file template)))))) +(define (unused-private-use-code-point s) + "Find a code point within a Unicode Private Use Area that is not +present in S, and return the corresponding character object. If one +cannot be found, return false." + (define (scan lo hi) + (and (<= lo hi) + (let ((c (integer->char lo))) + (if (string-index s c) + (scan (+ lo 1) hi) + c)))) + (or (scan #xE000 #xF8FF) + (scan #xF0000 #xFFFFD) + (scan #x100000 #x10FFFD))) + +(define (replace-char c1 c2 s) + "Return a string which is equal to S except with all instances of C1 +replaced by C2. If C1 and C2 are equal, return S." + (if (char=? c1 c2) + s + (string-map (lambda (c) + (if (char=? c c1) + c2 + c)) + s))) + (define (substitute file pattern+procs) "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each line of FILE, and for each PATTERN that it matches, call the corresponding @@ -764,16 +856,26 @@ end of a line; by itself it won't match the terminating newline of a line." (let loop ((line (read-line in 'concat))) (if (eof-object? line) #t - (let ((line (fold (lambda (r+p line) - (match r+p - ((regexp . proc) - (match (list-matches regexp line) - ((and m+ (_ _ ...)) - (proc line m+)) - (_ line))))) - line - rx+proc))) - (display line out) + ;; Work around the fact that Guile's regexp-exec does not handle + ;; NUL characters (a limitation of the underlying GNU libc's + ;; regexec) by temporarily replacing them by an unused private + ;; Unicode code point. + ;; TODO: Use SRFI-115 instead, once available in Guile. + (let* ((nul* (or (and (string-index line #\nul) + (unused-private-use-code-point line)) + #\nul)) + (line* (replace-char #\nul nul* line)) + (line1* (fold (lambda (r+p line) + (match r+p + ((regexp . proc) + (match (list-matches regexp line) + ((and m+ (_ _ ...)) + (proc line m+)) + (_ line))))) + line* + rx+proc)) + (line1 (replace-char nul* #\nul line1*))) + (display line1 out) (loop (read-line in 'concat))))))))) @@ -800,7 +902,7 @@ sub-expression. For example: ((\"hello\") \"good morning\\n\") ((\"foo([a-z]+)bar(.*)$\" all letters end) - (string-append \"baz\" letter end))) + (string-append \"baz\" letters end))) Here, anytime a line of FILE contains \"hello\", it is replaced by \"good morning\". Anytime a line of FILE matches the second regexp, ALL is bound to @@ -853,29 +955,45 @@ match the terminating newline of a line." ;;; (define* (dump-port in out + #:optional len #:key (buffer-size 16384) (progress (lambda (t k) (k)))) - "Read as much data as possible from IN and write it to OUT, using chunks of -BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful -transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes -transferred and the continuation of the transfer as a thunk." + "Read LEN bytes from IN or as much data as possible if LEN is #f, and write +it to OUT, using chunks of BUFFER-SIZE bytes. Call PROGRESS at the beginning +and after each successful transfer of BUFFER-SIZE bytes or less, passing it +the total number of bytes transferred and the continuation of the transfer as +a thunk." (define buffer (make-bytevector buffer-size)) (define (loop total bytes) (or (eof-object? bytes) + (and len (= total len)) (let ((total (+ total bytes))) (put-bytevector out buffer 0 bytes) (progress total (lambda () (loop total - (get-bytevector-n! in buffer 0 buffer-size))))))) + (get-bytevector-n! in buffer 0 + (if len + (min (- len total) buffer-size) + buffer-size)))))))) ;; Make sure PROGRESS is called when we start so that it can measure ;; throughput. (progress 0 (lambda () - (loop 0 (get-bytevector-n! in buffer 0 buffer-size))))) + (loop 0 (get-bytevector-n! in buffer 0 + (if len + (min len buffer-size) + buffer-size)))))) + +(define AT_SYMLINK_NOFOLLOW + ;; Guile 2.0 did not define this constant, hence this hack. + (let ((variable (module-variable the-root-module 'AT_SYMLINK_NOFOLLOW))) + (if variable + (variable-ref variable) + 256))) ;for GNU/Linux (define (set-file-time file stat) "Set the atime/mtime of FILE to that specified by STAT." @@ -883,7 +1001,8 @@ transferred and the continuation of the transfer as a thunk." (stat:atime stat) (stat:mtime stat) (stat:atimensec stat) - (stat:mtimensec stat))) + (stat:mtimensec stat) + AT_SYMLINK_NOFOLLOW)) (define (get-char* p) ;; We call it `get-char', but that's really a binary version @@ -1108,8 +1227,8 @@ known as `nuke-refs' in Nixpkgs." (program wrap-error-program) (type wrap-error-type)) -(define (wrapper? prog) - "Return #t if PROG is a wrapper as produced by 'wrap-program'." +(define (wrapped-program? prog) + "Return #t if PROG is a program that was moved and wrapped by 'wrap-program'." (and (file-exists? prog) (let ((base (basename prog))) (and (string-prefix? "." base) @@ -1184,6 +1303,9 @@ with definitions for VARS." (format #f "export ~a=\"$~a${~a:+:}~a\"" var var var (string-join rest ":"))))) + (when (wrapped-program? prog) + (error (string-append prog " is a wrapper. Refusing to wrap."))) + (if already-wrapped? ;; PROG is already a wrapper: add the new "export VAR=VALUE" lines just @@ -1307,7 +1429,7 @@ not supported." (lambda () (call-with-ascii-input-file prog (lambda (p) - (format out header) + (display header out) (dump-port p out) (close out) (chmod template mode) diff --git a/guix/gexp.scm b/guix/gexp.scm index afb935761e..3d8c2b9341 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -39,6 +39,7 @@ #:use-module (ice-9 match) #:export (gexp gexp? + sexp->gexp with-imported-modules with-extensions let-system @@ -104,6 +105,10 @@ lowered-gexp-load-path lowered-gexp-load-compiled-path + with-build-variables + input-tuples->gexp + outputs->gexp + gexp->derivation gexp->file gexp->script @@ -111,6 +116,7 @@ mixed-text-file file-union directory-union + imported-files imported-modules compiled-modules @@ -178,6 +184,18 @@ (set-record-type-printer! <gexp> write-gexp) +(define (gexp-with-hidden-inputs gexp inputs) + "Add INPUTS, a list of <gexp-input>, to the references of GEXP. These are +\"hidden inputs\" because they do not actually appear in the expansion of GEXP +returned by 'gexp->sexp'." + (make-gexp (append inputs (gexp-references gexp)) + (gexp-self-modules gexp) + (gexp-self-extensions gexp) + (let ((extra (length inputs))) + (lambda args + (apply (gexp-proc gexp) (drop args extra)))) + (gexp-location gexp))) + ;;; ;;; Methods. @@ -252,14 +270,17 @@ OBJ must be an object that has an associated gexp compiler, such as a (#f (raise (condition (&gexp-input-error (input obj))))) (lower - ;; Cache in STORE the result of lowering OBJ. - (mcached (mlet %store-monad ((lowered (lower obj system target))) - (if (and (struct? lowered) - (not (derivation? lowered))) - (loop lowered) - (return lowered))) - obj - system target graft?)))))) + ;; Cache in STORE the result of lowering OBJ. If OBJ is a + ;; derivation, bypass the cache. + (if (derivation? obj) + (return obj) + (mcached (mlet %store-monad ((lowered (lower obj system target))) + (if (and (struct? lowered) + (not (derivation? lowered))) + (loop lowered) + (return lowered))) + obj + system target graft?))))))) (define* (lower+expand-object obj #:optional (system (%current-system)) @@ -274,9 +295,11 @@ expand to file names, but it's possible to expand to a plain data type." (raise (condition (&gexp-input-error (input obj))))) (lower (mlet* %store-monad ((graft? (grafting?)) - (lowered (mcached (lower obj system target) - obj - system target graft?))) + (lowered (if (derivation? obj) + (return obj) + (mcached (lower obj system target) + obj + system target graft?)))) ;; LOWER might return something that needs to be further ;; lowered. (if (struct? lowered) @@ -881,8 +904,9 @@ corresponding <derivation-input> or store item." (match graphs (((file-names . inputs) ...) - (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs) - system target))) + (mlet %store-monad ((inputs (without-grafting + (lower-inputs (map tuple->gexp-input inputs) + system target)))) (return (map cons file-names inputs)))))) (define* (lower-references lst #:key system target) @@ -895,13 +919,15 @@ names and file names suitable for the #:allowed-references argument to ((? string? output) (return output)) (($ <gexp-input> thing output native?) - (mlet %store-monad ((drv (lower-object thing system - #:target (if native? - #f target)))) + (mlet %store-monad ((drv (without-grafting + (lower-object thing system + #:target (if native? + #f target))))) (return (derivation->output-path drv output)))) (thing - (mlet %store-monad ((drv (lower-object thing system - #:target target))) + (mlet %store-monad ((drv (without-grafting + (lower-object thing system + #:target target)))) (return (derivation->output-path drv)))))) (mapm/accumulate-builds lower lst))) @@ -1588,7 +1614,8 @@ last one is created from the given <scheme-file> object." (guile (%guile-for-build)) (module-path %load-path) (extensions '()) - (deprecation-warnings #f)) + (deprecation-warnings #f) + (optimization-level 1)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other. When TARGET is true, cross-compile MODULES for @@ -1599,127 +1626,178 @@ TARGET, a GNU triplet." #:system system #:guile guile #:module-path - module-path))) + module-path)) + (extensions (mapm %store-monad + (lambda (extension) + (lower-object extension system + #:target #f)) + extensions))) (define build - (gexp - (begin - (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' - - (use-modules (ice-9 ftw) - (ice-9 format) - (srfi srfi-1) - (srfi srfi-26) - (system base target) - (system base compile)) - - (define (regular? file) - (not (member file '("." "..")))) - - (define (process-entry entry output processed) - (if (file-is-directory? entry) - (let ((output (string-append output "/" (basename entry)))) - (mkdir-p output) - (process-directory entry output processed)) - (let* ((base (basename entry ".scm")) - (output (string-append output "/" base ".go"))) - (format #t "[~2@a/~2@a] Compiling '~a'...~%" - (+ 1 processed (ungexp total)) - (ungexp (* total 2)) - entry) - - (ungexp-splicing - (if target - (gexp ((with-target (ungexp target) + (gexp-with-hidden-inputs + (gexp + (begin + (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' + + (use-modules (ice-9 ftw) + (ice-9 format) + (srfi srfi-1) + (srfi srfi-26) + (system base target) + (system base compile)) + + (define modules + (getenv "modules")) + + (define total + (string->number (getenv "module count"))) + + (define extensions + (string-split (getenv "extensions") #\space)) + + (define target + (getenv "target")) + + (define optimization-level + (string->number (getenv "optimization level"))) + + (define optimizations-for-level + (or (and=> (false-if-exception + (resolve-interface '(system base optimize))) + (lambda (iface) + (module-ref iface 'optimizations-for-level))) ;Guile 3.0 + (const '()))) + + (define (regular? file) + (not (member file '("." "..")))) + + (define (process-entry entry output processed) + (if (file-is-directory? entry) + (let ((output (string-append output "/" (basename entry)))) + (mkdir-p output) + (process-directory entry output processed)) + (let* ((base (basename entry ".scm")) + (output (string-append output "/" base ".go"))) + (format #t "[~2@a/~2@a] Compiling '~a'...~%" + (+ 1 processed total) + (* total 2) + entry) + + (with-target (or target %host-type) (lambda () (compile-file entry #:output-file output #:opts - %auto-compilation-options))))) - (gexp ((compile-file entry - #:output-file output - #:opts %auto-compilation-options))))) - - (+ 1 processed)))) - - (define (process-directory directory output processed) - (let ((entries (map (cut string-append directory "/" <>) - (scandir directory regular?)))) - (fold (cut process-entry <> output <>) - processed - entries))) - - (define* (load-from-directory directory - #:optional (loaded 0)) - "Load all the source files found in DIRECTORY." - ;; XXX: This works around <https://bugs.gnu.org/15602>. - (let ((entries (map (cut string-append directory "/" <>) - (scandir directory regular?)))) - (fold (lambda (file loaded) - (if (file-is-directory? file) - (load-from-directory file loaded) - (begin - (format #t "[~2@a/~2@a] Loading '~a'...~%" - (+ 1 loaded) (ungexp (* 2 total)) - file) - (save-module-excursion - (lambda () - (primitive-load file))) - (+ 1 loaded)))) - loaded - entries))) - - (setvbuf (current-output-port) - (cond-expand (guile-2.2 'line) (else _IOLBF))) - - (define mkdir-p - ;; Capture 'mkdir-p'. - (@ (guix build utils) mkdir-p)) - - ;; Add EXTENSIONS to the search path. - (set! %load-path - (append (map (lambda (extension) - (string-append extension - "/share/guile/site/" - (effective-version))) - '((ungexp-native-splicing extensions))) - %load-path)) - (set! %load-compiled-path - (append (map (lambda (extension) - (string-append extension "/lib/guile/" - (effective-version) - "/site-ccache")) - '((ungexp-native-splicing extensions))) - %load-compiled-path)) - - (set! %load-path (cons (ungexp modules) %load-path)) - - ;; Above we loaded our own (guix build utils) but now we may need to - ;; load a compile a different one. Thus, force a reload. - (let ((utils (string-append (ungexp modules) - "/guix/build/utils.scm"))) - (when (file-exists? utils) - (load utils))) - - (mkdir (ungexp output)) - (chdir (ungexp modules)) - - (load-from-directory ".") - (process-directory "." (ungexp output) 0)))) - - ;; TODO: Pass MODULES as an environment variable. + `(,@%auto-compilation-options + ,@(optimizations-for-level + optimization-level))))) + + (+ 1 processed)))) + + (define (process-directory directory output processed) + (let ((entries (map (cut string-append directory "/" <>) + (scandir directory regular?)))) + (fold (cut process-entry <> output <>) + processed + entries))) + + (define* (load-from-directory directory + #:optional (loaded 0)) + "Load all the source files found in DIRECTORY." + ;; XXX: This works around <https://bugs.gnu.org/15602>. + (let ((entries (map (cut string-append directory "/" <>) + (scandir directory regular?)))) + (fold (lambda (file loaded) + (if (file-is-directory? file) + (load-from-directory file loaded) + (begin + (format #t "[~2@a/~2@a] Loading '~a'...~%" + (+ 1 loaded) (* 2 total) + file) + (save-module-excursion + (lambda () + (primitive-load file))) + (+ 1 loaded)))) + loaded + entries))) + + (setvbuf (current-output-port) + (cond-expand (guile-2.2 'line) (else _IOLBF))) + + (define mkdir-p + ;; Capture 'mkdir-p'. + (@ (guix build utils) mkdir-p)) + + ;; Remove environment variables for internal consumption. + (unsetenv "modules") + (unsetenv "module count") + (unsetenv "extensions") + (unsetenv "target") + (unsetenv "optimization level") + + ;; Add EXTENSIONS to the search path. + (set! %load-path + (append (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + extensions) + %load-path)) + (set! %load-compiled-path + (append (map (lambda (extension) + (string-append extension "/lib/guile/" + (effective-version) + "/site-ccache")) + extensions) + %load-compiled-path)) + + (set! %load-path (cons modules %load-path)) + + ;; Above we loaded our own (guix build utils) but now we may need to + ;; load a compile a different one. Thus, force a reload. + (let ((utils (string-append modules + "/guix/build/utils.scm"))) + (when (file-exists? utils) + (load utils))) + + (mkdir (ungexp output)) + (chdir modules) + + (load-from-directory ".") + (process-directory "." (ungexp output) 0))) + (append (map gexp-input extensions) + (list (gexp-input modules))))) + (gexp->derivation name build + #:script-name "compile-modules" #:system system #:target target #:guile-for-build guile #:local-build? #t #:env-vars - (case deprecation-warnings - ((#f) - '(("GUILE_WARN_DEPRECATED" . "no"))) - ((detailed) - '(("GUILE_WARN_DEPRECATED" . "detailed"))) - (else - '()))))) + `(("modules" + . ,(if (derivation? modules) + (derivation->output-path modules) + modules)) + ("module count" . ,(number->string total)) + ("extensions" + . ,(string-join + (map (match-lambda + ((? derivation? drv) + (derivation->output-path drv)) + ((? string? str) str)) + extensions))) + ("optimization level" + . ,(number->string optimization-level)) + ,@(if target + `(("target" . ,target)) + '()) + ,@(case deprecation-warnings + ((#f) + '(("GUILE_WARN_DEPRECATED" . "no"))) + ((detailed) + '(("GUILE_WARN_DEPRECATED" . "detailed"))) + (else + '())))))) ;;; @@ -1787,6 +1865,72 @@ Assume MODULES are compiled with GUILE." extensions)) %load-compiled-path))))))))) +(define* (input-tuples->gexp inputs #:key native?) + "Given INPUTS, a list of label/gexp-input tuples, return a gexp that expands +to an input alist." + (define references + (map (match-lambda + ((label input) input)) + inputs)) + + (define labels + (match inputs + (((labels . _) ...) + labels))) + + (define (proc . args) + (cons 'quote (list (map cons labels args)))) + + ;; This gexp is more efficient than an equivalent hand-written gexp: fewer + ;; allocations, no need to scan long list-valued <gexp-input> records in + ;; search of file-like objects, etc. + (make-gexp references '() '() proc + (source-properties inputs))) + +(define (outputs->gexp outputs) + "Given OUTPUTS, a list of output names, return a gexp that expands to an +output alist." + (define references + (map gexp-output outputs)) + + (define (proc . args) + `(list ,@(map (lambda (name) + `(cons ,name ((@ (guile) getenv) ,name))) + outputs))) + + ;; This gexp is more efficient than an equivalent hand-written gexp. + (make-gexp references '() '() proc + (source-properties outputs))) + +(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 + (ungexp (input-tuples->gexp inputs))) + (define %outputs + (ungexp (outputs->gexp outputs))) + (define %output + (assoc-ref %outputs "out")) + + (ungexp body)))) + +(define (sexp->gexp sexp) + "Turn SEXP into a gexp without any references. + +Using this is a way for the caller to tell that SEXP doesn't need to be +scanned for file-like objects, thereby reducing processing costs. This is +particularly useful if SEXP is a long list or a deep tree." + (make-gexp '() '() '() + (lambda () sexp) + (source-properties sexp))) + (define* (gexp->script name exp #:key (guile (default-guile)) (module-path %load-path) diff --git a/guix/grafts.scm b/guix/grafts.scm index fd8a108092..7f5b97c39d 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -42,6 +42,7 @@ graft-derivation/shallow %graft? + without-grafting set-grafting grafting?)) @@ -323,6 +324,17 @@ DRV, and graft DRV itself to refer to those grafted dependencies." ;; Whether to honor package grafts by default. (make-parameter #t)) +(define (call-without-grafting thunk) + (lambda (store) + (values (parameterize ((%graft? #f)) + (run-with-store store (thunk))) + store))) + +(define-syntax-rule (without-grafting mexp ...) + "Bind monadic expressions MEXP in a dynamic extent where '%graft?' is +false." + (call-without-grafting (lambda () (mbegin %store-monad mexp ...)))) + (define-inlinable (set-grafting enable?) ;; This monadic procedure enables grafting when ENABLE? is true, and ;; disables it otherwise. It returns the previous setting. diff --git a/guix/packages.scm b/guix/packages.scm index c825f427d8..ba19174646 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -23,6 +24,8 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix packages) + #:use-module ((guix build utils) #:select (compressor tarball? + strip-store-file-name)) #:use-module (guix utils) #:use-module (guix records) #:use-module (guix store) @@ -273,8 +276,8 @@ as base32. Otherwise, it must be a bytevector." (default '()) (delayed)) (snippet origin-snippet (default #f)) ; sexp or #f - (patch-flags origin-patch-flags ; list of strings - (default '("-p1"))) + (patch-flags origin-patch-flags ; string-list gexp + (default %default-patch-flags)) ;; Patching requires Guile, GNU Patch, and a few more. These two fields are ;; used to specify these dependencies when needed. @@ -322,6 +325,9 @@ specifications to 'hash'." (set-record-type-printer! <origin> print-origin) +(define %default-patch-flags + #~("-p1")) + (define (origin-actual-file-name origin) "Return the file name of ORIGIN, either its 'file-name' field or the file name of its URI." @@ -557,8 +563,12 @@ identifiers. The result is inferred from the file names of patches." (let* ((canonical (module-ref (resolve-interface '(gnu packages base)) 'canonical-package)) (ref (lambda (module var) - (canonical - (module-ref (resolve-interface module) var))))) + ;; Make sure 'canonical-package' is not influenced by + ;; '%current-target-system' since we're going to use the + ;; native package anyway. + (parameterize ((%current-target-system #f)) + (canonical + (module-ref (resolve-interface module) var)))))) `(("tar" ,(ref '(gnu packages base) 'tar)) ("xz" ,(ref '(gnu packages compression) 'xz)) ("bzip2" ,(ref '(gnu packages compression) 'bzip2)) @@ -591,7 +601,7 @@ the build code of derivation." #:key inputs (snippet #f) - (flags '("-p1")) + (flags %default-patch-flags) (modules '()) (guile-for-build (%guile-for-build)) (system (%current-system))) @@ -615,20 +625,7 @@ specifies modules in scope when evaluating SNIPPET." ((package) package) (#f #f))))) - (define decompression-type - (cond ((string-suffix? "gz" source-file-name) "gzip") - ((string-suffix? "Z" source-file-name) "gzip") - ((string-suffix? "bz2" source-file-name) "bzip2") - ((string-suffix? "lz" source-file-name) "lzip") - ((string-suffix? "zip" source-file-name) "unzip") - (else "xz"))) - - (define original-file-name - ;; Remove the store prefix plus the slash, hash, and hyphen. - (let* ((sans (string-drop source-file-name - (+ (string-length (%store-prefix)) 1))) - (dash (string-index sans #\-))) - (string-drop sans (+ 1 dash)))) + (define original-file-name (strip-store-file-name source-file-name)) (define (numeric-extension? file-name) ;; Return true if FILE-NAME ends with digits. @@ -641,11 +638,9 @@ specifies modules in scope when evaluating SNIPPET." (define (tarxz-name file-name) ;; Return a '.tar.xz' file name based on FILE-NAME. - (let ((base (cond ((numeric-extension? file-name) - original-file-name) - ((checkout? file-name) - (string-drop-right file-name 9)) - (else (file-sans-extension file-name))))) + (let ((base (if (numeric-extension? file-name) + original-file-name + (file-sans-extension file-name)))) (string-append base (if (equal? (file-extension base) "tar") ".xz" @@ -654,22 +649,27 @@ specifies modules in scope when evaluating SNIPPET." (define instantiate-patch (match-lambda ((? string? patch) ;deprecated - (interned-file patch #:recursive? #t)) + (local-file patch #:recursive? #t)) ((? struct? patch) ;origin, local-file, etc. - (lower-object patch system)))) - - (mlet %store-monad ((tar -> (lookup-input "tar")) - (xz -> (lookup-input "xz")) - (patch -> (lookup-input "patch")) - (locales -> (lookup-input "locales")) - (decomp -> (lookup-input decompression-type)) - (patches (sequence %store-monad - (map instantiate-patch patches)))) + patch))) + + (let ((tar (lookup-input "tar")) + (gzip (lookup-input "gzip")) + (bzip2 (lookup-input "bzip2")) + (lzip (lookup-input "lzip")) + (xz (lookup-input "xz")) + (patch (lookup-input "patch")) + (locales (lookup-input "locales")) + (comp (and=> (compressor source-file-name) lookup-input)) + (patches (map instantiate-patch patches))) (define build (with-imported-modules '((guix build utils)) #~(begin (use-modules (ice-9 ftw) + (ice-9 match) + (ice-9 regex) (srfi srfi-1) + (srfi srfi-26) (guix build utils)) ;; The --sort option was added to GNU tar in version 1.28, released @@ -695,66 +695,8 @@ specifies modules in scope when evaluating SNIPPET." (lambda (name) (not (member name '("." ".."))))))) - ;; Encoding/decoding errors shouldn't be silent. - (fluid-set! %default-port-conversion-strategy 'error) - - (when #+locales - ;; First of all, install a UTF-8 locale so that UTF-8 file names - ;; are correctly interpreted. During bootstrap, LOCALES is #f. - (setenv "LOCPATH" - (string-append #+locales "/lib/locale/" - #+(and locales - (version-major+minor - (package-version locales))))) - (setlocale LC_ALL "en_US.utf8")) - - (setenv "PATH" (string-append #+xz "/bin" ":" - #+decomp "/bin")) - - ;; SOURCE may be either a directory or a tarball. - (if (file-is-directory? #+source) - (let* ((store (%store-directory)) - (len (+ 1 (string-length store))) - (base (string-drop #+source len)) - (dash (string-index base #\-)) - (directory (string-drop base (+ 1 dash)))) - (mkdir directory) - (copy-recursively #+source directory)) - #+(if (string=? decompression-type "unzip") - #~(invoke "unzip" #+source) - #~(invoke (string-append #+tar "/bin/tar") - "xvf" #+source))) - - (let ((directory (first-file "."))) - (format (current-error-port) - "source is under '~a'~%" directory) - (chdir directory) - - (for-each apply-patch '#+patches) - - (let ((result #+(if snippet - #~(let ((module (make-fresh-user-module))) - (module-use-interfaces! - module - (map resolve-interface '#+modules)) - ((@ (system base compile) compile) - '#+snippet - #:to 'value - #:opts %auto-compilation-options - #:env module)) - #~#t))) - ;; Issue a warning unless the result is #t. - (unless (eqv? result #t) - (format (current-error-port) "\ -## WARNING: the snippet returned `~s'. Return values other than #t -## are deprecated. Please migrate this package so that its snippet -## reports errors by raising an exception, and otherwise returns #t.~%" - result)) - (unless result - (error "snippet returned false"))) - - (chdir "..") - + (define (repack directory output) + ;; Write to OUTPUT a compressed tarball containing DIRECTORY. (unless tar-supports-sort? (call-with-output-file ".file_list" (lambda (port) @@ -763,22 +705,97 @@ specifies modules in scope when evaluating SNIPPET." (find-files directory #:directories? #t #:fail-on-error? #t))))) - (apply invoke - (string-append #+tar "/bin/tar") - "cvfa" #$output + + (apply invoke #+(file-append tar "/bin/tar") + "cvfa" output ;; Avoid non-determinism in the archive. Set the mtime ;; to 1 as is the case in the store (software like gzip ;; behaves differently when it stumbles upon mtime = 0). "--mtime=@1" - "--owner=root:0" - "--group=root:0" + "--owner=root:0" "--group=root:0" (if tar-supports-sort? - `("--sort=name" - ,directory) + `("--sort=name" ,directory) '("--no-recursion" - "--files-from=.file_list"))))))) + "--files-from=.file_list")))) + + ;; Encoding/decoding errors shouldn't be silent. + (fluid-set! %default-port-conversion-strategy 'error) + + (when #+locales + ;; First of all, install a UTF-8 locale so that UTF-8 file names + ;; are correctly interpreted. During bootstrap, LOCALES is #f. + (setenv "LOCPATH" + (string-append #+locales "/lib/locale/" + #+(and locales + (version-major+minor + (package-version locales))))) + (setlocale LC_ALL "en_US.utf8")) - (let ((name (tarxz-name original-file-name))) + (setenv "PATH" + (string-append #+xz "/bin" + (if #+comp + (string-append ":" #+comp "/bin") + ""))) + + (setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args))) + + ;; SOURCE may be either a directory, a tarball or a simple file. + (let ((name (strip-store-file-name #+source)) + (command (and=> #+comp (cut string-append <> "/bin/" + (compressor #+source))))) + (if (file-is-directory? #+source) + (copy-recursively #+source name) + (cond + ((tarball? #+source) + (invoke (string-append #+tar "/bin/tar") "xvf" #+source)) + ((and=> (compressor #+source) (cut string= "unzip" <>)) + ;; Note: Referring to the store unzip here (#+unzip) + ;; would introduce a cycle. + (invoke "unzip" #+source)) + (else + (copy-file #+source name) + (when command + (invoke command "--decompress" name)))))) + + (let* ((file (first-file ".")) + (directory (if (file-is-directory? file) + file + "."))) + (format (current-error-port) "source is at '~a'~%" file) + + (with-directory-excursion directory + + (for-each apply-patch '#+patches) + + #+(if snippet + #~(let ((module (make-fresh-user-module))) + (module-use-interfaces! + module + (map resolve-interface '#+modules)) + ((@ (system base compile) compile) + '#+(if (pair? snippet) + (sexp->gexp snippet) + snippet) + #:to 'value + #:opts %auto-compilation-options + #:env module)) + #~#t)) + + ;; If SOURCE is a directory (such as a checkout), return a + ;; directory. Otherwise create a tarball. + (cond + ((file-is-directory? #+source) + (copy-recursively directory #$output + #:log (%make-void-port "w"))) + ((not #+comp) + (copy-file file #$output)) + (else + (repack directory #$output))))))) + + (let ((name (if (or (checkout? original-file-name) + (not (compressor original-file-name))) + original-file-name + (tarxz-name original-file-name)))) (gexp->derivation name build #:graft? #f #:system system @@ -1165,10 +1182,6 @@ matching package and returns a replacement for that package." ;;; Package derivations. ;;; -(define %derivation-cache - ;; Package to derivation-path mapping. - (make-weak-key-hash-table 100)) - (define (cache! cache package system thunk) "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on SYSTEM." @@ -1196,56 +1209,47 @@ Return the cached result when available." (#f (cache! cache package key thunk)) (value value))) (#f - (cache! cache package key thunk))))) - ((_ package system body ...) - (cached (=> %derivation-cache) package system body ...)))) - -(define* (expand-input store package input system #:optional cross-system) - "Expand INPUT, an input tuple, such that it contains only references to -derivation paths or store paths. PACKAGE is only used to provide contextual -information in exceptions." - (define (intern file) - ;; Add FILE to the store. Set the `recursive?' bit to #t, so that - ;; file permissions are preserved. - (add-to-store store (basename file) #t "sha256" file)) - - (define derivation - (if cross-system - (cut package-cross-derivation store <> cross-system system - #:graft? #f) - (cut package-derivation store <> system #:graft? #f))) - - (match input - (((? string? name) (? package? package)) - (list name (derivation package))) - (((? string? name) (? package? package) - (? string? sub-drv)) - (list name (derivation package) - sub-drv)) - (((? string? name) - (and (? string?) (? derivation-path?) drv)) - (list name drv)) - (((? string? name) - (and (? string?) (? file-exists? file))) - ;; Add FILE to the store. When FILE is in the sub-directory of a - ;; store path, it needs to be added anyway, so it can be used as a - ;; source. - (list name (intern file))) - (((? string? name) (? struct? source)) - ;; 'package-source-derivation' calls 'lower-object', which can throw - ;; '&gexp-input-error'. However '&gexp-input-error' lacks source - ;; location info, so we catch and rethrow here (XXX: not optimal - ;; performance-wise). - (guard (c ((gexp-input-error? c) - (raise (condition - (&package-input-error - (package package) - (input (gexp-error-invalid-input c))))))) - (list name (package-source-derivation store source system)))) - (x - (raise (condition (&package-input-error - (package package) - (input x))))))) + (cache! cache package key thunk))))))) + +(define* (expand-input package input #:key target) + "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is +only used to provide contextual information in exceptions." + (with-monad %store-monad + (match input + ;; INPUT doesn't need to be lowered here because it'll be lowered down + ;; the road in the gexp that refers to it. However, packages need to be + ;; special-cased to pass #:graft? #f (only the "tip" of the package + ;; graph needs to have #:graft? #t). Lowering them here also allows + ;; 'bag->derivation' to delete non-eq? packages that lead to the same + ;; derivation. + (((? string? name) (? package? package)) + (mlet %store-monad ((drv (if target + (package->cross-derivation package target + #:graft? #f) + (package->derivation package #:graft? #f)))) + (return (list name (gexp-input drv #:native? (not target)))))) + (((? string? name) (? package? package) (? string? output)) + (mlet %store-monad ((drv (if target + (package->cross-derivation package target + #:graft? #f) + (package->derivation package #:graft? #f)))) + (return (list name (gexp-input drv output #:native? (not target)))))) + + (((? string? name) (? file-like? thing)) + (return (list name (gexp-input thing #:native? (not target))))) + (((? string? name) (? file-like? thing) (? string? output)) + (return (list name (gexp-input thing output #:native? (not target))))) + (((? 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. + (return (list name (gexp-input (local-file file #:recursive? #t) + #:native? (not target))))) + (x + (raise (condition (&package-input-error + (package package) + (input x)))))))) (define %bag-cache ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags. @@ -1293,45 +1297,51 @@ and return it." (&package-error (package package)))))))))))) -(define %graft-cache - ;; 'eq?' cache mapping package objects to a graft corresponding to their - ;; replacement package. - (make-weak-key-hash-table 200)) +(define (input-graft system) + "Return a monadic procedure that, given a package with a graft, returns a +graft, and #f otherwise." + (with-monad %store-monad + (match-lambda* + (((? package? package) output) + (let ((replacement (package-replacement package))) + (if replacement + ;; XXX: We should use a separate cache instead of abusing the + ;; object cache. + (mcached (mlet %store-monad ((orig (package->derivation package system + #:graft? #f)) + (new (package->derivation replacement system + #:graft? #t))) + (return (graft + (origin orig) + (origin-output output) + (replacement new) + (replacement-output output)))) + package 'graft output system) + (return #f)))) + (_ + (return #f))))) -(define (input-graft store system) - "Return a procedure that, given a package with a replacement and an output name, -returns a graft, and #f otherwise." - (match-lambda* - (((? package? package) output) - (let ((replacement (package-replacement package))) - (and replacement - (cached (=> %graft-cache) package (cons output system) - (let ((orig (package-derivation store package system - #:graft? #f)) - (new (package-derivation store replacement system - #:graft? #t))) - (graft - (origin orig) - (origin-output output) - (replacement new) - (replacement-output output))))))))) - -(define (input-cross-graft store target system) +(define (input-cross-graft target system) "Same as 'input-graft', but for cross-compilation inputs." - (match-lambda* - (((? package? package) output) - (let ((replacement (package-replacement package))) - (and replacement - (let ((orig (package-cross-derivation store package target system - #:graft? #f)) - (new (package-cross-derivation store replacement - target system - #:graft? #t))) - (graft - (origin orig) - (origin-output output) - (replacement new) - (replacement-output output)))))))) + (with-monad %store-monad + (match-lambda* + (((? package? package) output) + (let ((replacement (package-replacement package))) + (if replacement + (mlet %store-monad ((orig (package->cross-derivation package + target system + #:graft? #f)) + (new (package->cross-derivation replacement + target system + #:graft? #t))) + (return (graft + (origin orig) + (origin-output output) + (replacement new) + (replacement-output output)))) + (return #f)))) + (_ + (return #f))))) (define* (fold-bag-dependencies proc seed bag #:key (native? #t)) @@ -1366,7 +1376,7 @@ dependencies; otherwise, restrict to target dependencies." ((head . tail) (loop tail result visited))))) -(define* (bag-grafts store bag) +(define* (bag-grafts bag) "Return the list of grafts potentially applicable to BAG. Potentially applicable grafts are collected by looking at direct or indirect dependencies of BAG that have a 'replacement'. Whether a graft is actually applicable @@ -1375,158 +1385,199 @@ to (see 'graft-derivation'.)" (define system (bag-system bag)) (define target (bag-target bag)) - (define native-grafts - (let ((->graft (input-graft store system))) - (parameterize ((%current-system system) - (%current-target-system #f)) - (fold-bag-dependencies (lambda (package output grafts) - (match (->graft package output) - (#f grafts) - (graft (cons graft grafts)))) - '() - bag)))) - - (define target-grafts - (if target - (let ((->graft (input-cross-graft store target system))) + (mlet %store-monad + ((native-grafts + (let ((->graft (input-graft system))) (parameterize ((%current-system system) - (%current-target-system target)) + (%current-target-system #f)) (fold-bag-dependencies (lambda (package output grafts) - (match (->graft package output) - (#f grafts) - (graft (cons graft grafts)))) - '() - bag - #:native? #f))) - '())) - - ;; We can end up with several identical grafts if we stumble upon packages - ;; that are not 'eq?' but map to the same derivation (this can happen when - ;; using things like 'package-with-explicit-inputs'.) Hence the - ;; 'delete-duplicates' call. - (delete-duplicates - (append native-grafts target-grafts))) - -(define* (package-grafts store package - #:optional (system (%current-system)) - #:key target) + (mlet %store-monad ((grafts grafts)) + (>>= (->graft package output) + (match-lambda + (#f (return grafts)) + (graft (return (cons graft grafts))))))) + (return '()) + bag)))) + + (target-grafts + (if target + (let ((->graft (input-cross-graft target system))) + (parameterize ((%current-system system) + (%current-target-system target)) + (fold-bag-dependencies + (lambda (package output grafts) + (mlet %store-monad ((grafts grafts)) + (>>= (->graft package output) + (match-lambda + (#f (return grafts)) + (graft (return (cons graft grafts))))))) + (return '()) + bag + #:native? #f))) + (return '())))) + + ;; We can end up with several identical grafts if we stumble upon packages + ;; that are not 'eq?' but map to the same derivation (this can happen when + ;; using things like 'package-with-explicit-inputs'.) Hence the + ;; 'delete-duplicates' call. + (return (delete-duplicates + (append native-grafts target-grafts))))) + +(define* (package-grafts* package + #:optional (system (%current-system)) + #:key target) "Return the list of grafts applicable to PACKAGE as built for SYSTEM and TARGET." (let* ((package (or (package-replacement package) package)) (bag (package->bag package system target))) - (bag-grafts store bag))) - -(define* (bag->derivation store bag - #:optional context) + (bag-grafts bag))) + +(define package-grafts + (store-lower package-grafts*)) + +(define-inlinable (derivation=? drv1 drv2) + "Return true if DRV1 and DRV2 are equal." + (or (eq? drv1 drv2) + (string=? (derivation-file-name drv1) + (derivation-file-name drv2)))) + +(define (input=? input1 input2) + "Return true if INPUT1 and INPUT2 are equivalent." + (match input1 + ((label1 obj1 . outputs1) + (match input2 + ((label2 obj2 . outputs2) + (and (string=? label1 label2) + (equal? outputs1 outputs2) + (or (and (derivation? obj1) (derivation? obj2) + (derivation=? obj1 obj2)) + (equal? obj1 obj2)))))))) + +(define* (bag->derivation bag #:optional context) "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be a package object describing the context in which the call occurs, for improved error reporting." (if (bag-target bag) - (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)))) - - (apply (bag-build bag) - store (bag-name bag) input-drvs + (bag->cross-derivation bag) + (mlet* %store-monad ((system -> (bag-system bag)) + (inputs -> (bag-transitive-inputs bag)) + (input-drvs (mapm %store-monad + (cut expand-input context <>) + inputs)) + (paths -> (delete-duplicates + (append-map (match-lambda + ((_ (? package? p) _ ...) + (package-native-search-paths + p)) + (_ '())) + inputs)))) + ;; It's possible that INPUTS contains packages that are not 'eq?' but + ;; that lead to the same derivation. Delete those duplicates to avoid + ;; issues down the road, such as duplicate entries in '%build-inputs'. + (apply (bag-build bag) (bag-name bag) + (delete-duplicates input-drvs input=?) #:search-paths paths #:outputs (bag-outputs bag) #:system system (bag-arguments bag))))) -(define* (bag->cross-derivation store bag - #:optional context) +(define* (bag->cross-derivation bag #:optional context) "Return the derivation to build BAG, which is actually a cross build. Optionally, CONTEXT can be a package object denoting the context of the call. 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)) - (target* (bag-transitive-target-inputs bag)) - (target-drvs (map (cut expand-input store context <> system) - target*)) - (build (bag-transitive-build-inputs bag)) - (build-drvs (map (cut expand-input store context <> 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) + (mlet* %store-monad ((system -> (bag-system bag)) + (target -> (bag-target bag)) + (host -> (bag-transitive-host-inputs bag)) + (host-drvs (mapm %store-monad + (cut expand-input context <> + #:target target) + host)) + (target* -> (bag-transitive-target-inputs bag)) + (target-drvs (mapm %store-monad + (cut expand-input context <>) + target*)) + (build -> (bag-transitive-build-inputs bag)) + (build-drvs (mapm %store-monad + (cut expand-input context <>) + 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) (bag-name bag) + #:build-inputs (delete-duplicates build-drvs input=?) + #:host-inputs (delete-duplicates host-drvs input=?) + #:target-inputs (delete-duplicates target-drvs input=?) #:search-paths paths #:native-search-paths npaths #:outputs (bag-outputs bag) #:system system #:target target (bag-arguments bag)))) -(define* (package-derivation store package - #:optional (system (%current-system)) - #:key (graft? (%graft?))) +(define bag->derivation* + (store-lower bag->derivation)) + +(define graft-derivation* + (store-lift graft-derivation)) + +(define* (package->derivation package + #:optional (system (%current-system)) + #:key (graft? (%graft?))) "Return the <derivation> object of PACKAGE for SYSTEM." ;; Compute the derivation and cache the result. Caching is important ;; because some derivations, such as the implicit inputs of the GNU build ;; system, will be queried many, many times in a row. - (cached package (cons system graft?) - (let* ((bag (package->bag package system #f #:graft? graft?)) - (drv (bag->derivation store bag package))) - (if graft? - (match (bag-grafts store bag) - (() - drv) - (grafts - (let ((guile (package-derivation store (guile-for-grafts) - system #:graft? #f))) - ;; TODO: As an optimization, we can simply graft the tip - ;; of the derivation graph since 'graft-derivation' - ;; recurses anyway. - (graft-derivation store drv grafts - #:system system - #:guile guile)))) - drv)))) - -(define* (package-cross-derivation store package target - #:optional (system (%current-system)) - #:key (graft? (%graft?))) + (mcached (mlet* %store-monad ((bag -> (package->bag package system #f + #:graft? graft?)) + (drv (bag->derivation bag package))) + (if graft? + (>>= (bag-grafts bag) + (match-lambda + (() + (return drv)) + (grafts + (mlet %store-monad ((guile (package->derivation + (default-guile) + system #:graft? #f))) + (graft-derivation* drv grafts + #:system system + #:guile guile))))) + (return drv))) + package system #f graft?)) + +(define* (package->cross-derivation package target + #:optional (system (%current-system)) + #:key (graft? (%graft?))) "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix system identifying string)." - (cached package (list system target graft?) - (let* ((bag (package->bag package system target #:graft? graft?)) - (drv (bag->derivation store bag package))) - (if graft? - (match (bag-grafts store bag) - (() - drv) - (grafts - (graft-derivation store drv grafts - #:system system - #:guile - (package-derivation store (guile-for-grafts) - system #:graft? #f)))) - drv)))) + (mcached (mlet* %store-monad ((bag -> (package->bag package system target + #:graft? graft?)) + (drv (bag->derivation bag package))) + (if graft? + (>>= (bag-grafts bag) + (match-lambda + (() + (return drv)) + (grafts + (mlet %store-monad ((guile (package->derivation + (default-guile) + system #:graft? #f))) + (graft-derivation* drv grafts + #:system system + #:guile guile))))) + (return drv))) + package system target graft?)) (define* (package-output store package #:optional (output "out") (system (%current-system))) @@ -1574,11 +1625,11 @@ unless you know what you are doing." out) store)))) -(define package->derivation - (store-lift package-derivation)) +(define package-derivation + (store-lower package->derivation)) -(define package->cross-derivation - (store-lift package-cross-derivation)) +(define package-cross-derivation + (store-lower package->cross-derivation)) (define-gexp-compiler (package-compiler (package <package>) system target) ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for @@ -1598,7 +1649,7 @@ unless you know what you are doing." (content-hash-value hash) name #:system system)) (($ <origin> uri method hash name (= force (patches ...)) snippet - (flags ...) inputs (modules ...) guile-for-build) + flags inputs (modules ...) guile-for-build) ;; Patches and/or a snippet. (mlet %store-monad ((source (method uri (content-hash-algorithm hash) diff --git a/guix/profiles.scm b/guix/profiles.scm index 0044851dc2..2ec78b080a 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1657,105 +1657,6 @@ the entries in MANIFEST." `((type . profile-hook) (hook . manual-database)))) -(define (texlive-configuration manifest) - "Return a derivation that builds a TeXlive configuration for the entries in -MANIFEST." - (define entry->texlive-input - (match-lambda - (($ <manifest-entry> name version output thing deps) - (if (string-prefix? "texlive-" name) - (cons (gexp-input thing output) - (append-map entry->texlive-input deps)) - '())))) - (define texlive-bin - (module-ref (resolve-interface '(gnu packages tex)) 'texlive-bin)) - (define coreutils - (module-ref (resolve-interface '(gnu packages base)) 'coreutils)) - (define sed - (module-ref (resolve-interface '(gnu packages base)) 'sed)) - (define updmap.cfg - (module-ref (resolve-interface '(gnu packages tex)) - 'texlive-default-updmap.cfg)) - (define build - (with-imported-modules '((guix build utils) - (guix build union)) - #~(begin - (use-modules (guix build utils) - (guix build union) - (ice-9 popen)) - - ;; Build a modifiable union of all texlive inputs. We do this so - ;; that TeX live can resolve the parent and grandparent directories - ;; correctly. There might be a more elegant way to accomplish this. - (union-build #$output - '#$(append-map entry->texlive-input - (manifest-entries manifest)) - #:create-all-directories? #t - #:log-port (%make-void-port "w")) - (let ((texmf.cnf (string-append - #$output - "/share/texmf-dist/web2c/texmf.cnf"))) - (when (file-exists? texmf.cnf) - (substitute* texmf.cnf - (("^TEXMFROOT = .*") - (string-append "TEXMFROOT = " #$output "/share\n")) - (("^TEXMF = .*") - "TEXMF = $TEXMFROOT/share/texmf-dist\n")) - - ;; XXX: This is annoying, but it's necessary because texlive-bin - ;; does not provide wrapped executables. - (setenv "PATH" - (string-append #$(file-append coreutils "/bin") - ":" - #$(file-append sed "/bin"))) - (setenv "PERL5LIB" #$(file-append texlive-bin "/share/tlpkg")) - (setenv "TEXMF" (string-append #$output "/share/texmf-dist")) - - ;; Remove invalid maps from config file. - (let* ((web2c (string-append #$output "/share/texmf-config/web2c/")) - (maproot (string-append #$output "/share/texmf-dist/fonts/map/")) - (updmap.cfg (string-append web2c "updmap.cfg"))) - (mkdir-p web2c) - - ;; Some profiles may already have this file, which prevents us - ;; from copying it. Since we need to generate it from scratch - ;; anyway, we delete it here. - (when (file-exists? updmap.cfg) - (delete-file updmap.cfg)) - (copy-file #$updmap.cfg updmap.cfg) - (make-file-writable updmap.cfg) - (let* ((port (open-pipe* OPEN_WRITE - #$(file-append texlive-bin "/bin/updmap-sys") - "--syncwithtrees" - "--nohash" - "--force" - (string-append "--cnffile=" web2c "updmap.cfg")))) - (display "Y\n" port) - (when (not (zero? (status:exit-val (close-pipe port)))) - (error "failed to filter updmap.cfg"))) - - ;; Generate font maps. - (invoke #$(file-append texlive-bin "/bin/updmap-sys") - (string-append "--cnffile=" web2c "updmap.cfg") - (string-append "--dvipdfmxoutputdir=" - maproot "updmap/dvipdfmx/") - (string-append "--dvipsoutputdir=" - maproot "updmap/dvips/") - (string-append "--pdftexoutputdir=" - maproot "updmap/pdftex/"))))) - #t))) - - (with-monad %store-monad - (if (any (cut string-prefix? "texlive-" <>) - (map manifest-entry-name (manifest-entries manifest))) - (gexp->derivation "texlive-configuration" build - #:substitutable? #f - #:local-build? #t - #:properties - `((type . profile-hook) - (hook . texlive-configuration))) - (return #f)))) - (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. @@ -1768,7 +1669,6 @@ MANIFEST." glib-schemas gtk-icon-themes gtk-im-modules - texlive-configuration xdg-desktop-database xdg-mime-database)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index b653138f2c..d12fbaff6a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; ;;; This file is part of GNU Guix. @@ -26,6 +27,7 @@ #:use-module (guix scripts) #:use-module (guix ui) #:use-module (guix gexp) + #:use-module ((guix build utils) #:select (%xz-parallel-args)) #:use-module (guix utils) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) @@ -77,29 +79,34 @@ compressor? (name compressor-name) ;string (e.g., "gzip") (extension compressor-extension) ;string (e.g., ".lz") - (command compressor-command)) ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n")) + (command compressor-command)) ;gexp (e.g., #~(list "/gnu/store/…/gzip" + ; "-9n" )) (define %compressors ;; Available compression tools. (list (compressor "gzip" ".gz" - #~(#+(file-append gzip "/bin/gzip") "-9n")) + #~(list #+(file-append gzip "/bin/gzip") "-9n")) (compressor "lzip" ".lz" - #~(#+(file-append lzip "/bin/lzip") "-9")) + #~(list #+(file-append lzip "/bin/lzip") "-9")) (compressor "xz" ".xz" - #~(#+(file-append xz "/bin/xz") "-e")) + #~(append (list #+(file-append xz "/bin/xz") + "-e") + (%xz-parallel-args))) (compressor "bzip2" ".bz2" - #~(#+(file-append bzip2 "/bin/bzip2") "-9")) + #~(list #+(file-append bzip2 "/bin/bzip2") "-9")) (compressor "zstd" ".zst" ;; The default level 3 compresses better than gzip in a ;; fraction of the time, while the highest level 19 ;; (de)compresses more slowly and worse than xz. - #~(#+(file-append zstd "/bin/zstd") "-3")) + #~(list #+(file-append zstd "/bin/zstd") "-3")) (compressor "none" "" #f))) ;; This one is only for use in this module, so don't put it in %compressors. (define bootstrap-xz (compressor "bootstrap-xz" ".xz" - #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e"))) + #~(append (list #+(file-append %bootstrap-coreutils&co "/bin/xz") + "-e") + (%xz-parallel-args)))) (define (lookup-compressor name) "Return the compressor object called NAME. Error out if it could not be @@ -283,7 +290,7 @@ added to the pack." #+@(if (compressor-command compressor) #~("-I" (string-join - '#+(compressor-command compressor))) + #+(compressor-command compressor))) #~()) "--format=gnu" @@ -556,11 +563,13 @@ the image." ,@(source-module-closure `((guix docker) (guix build store-copy) + (guix build utils) ;for %xz-parallel-args (guix profiles) (guix search-paths)) #:select? not-config?)) #~(begin (use-modules (guix docker) (guix build store-copy) + (guix build utils) (guix profiles) (guix search-paths) (srfi srfi-1) (srfi srfi-19) (ice-9 match)) @@ -617,7 +626,7 @@ the image." #~(list (string-append #$profile "/" #$entry-point))) #:extra-files directives - #:compressor '#+(compressor-command compressor) + #:compressor #+(compressor-command compressor) #:creation-time (make-time time-utc 0 1)))))) (gexp->derivation (string-append name ".tar" diff --git a/guix/self.scm b/guix/self.scm index 7181205610..cdbb606a0b 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -50,7 +50,7 @@ (let ((ref (lambda (module variable) (module-ref (resolve-interface module) variable)))) (match-lambda - ("guile" (ref '(gnu packages guile) 'guile-3.0/libgc-7)) + ("guile" (ref '(gnu packages guile) 'guile-3.0-latest)) ("guile-avahi" (ref '(gnu packages guile-xyz) 'guile-avahi)) ("guile-json" (ref '(gnu packages guile) 'guile-json-4)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) diff --git a/guix/store/roots.scm b/guix/store/roots.scm index 58653507f8..222f69c5c0 100644 --- a/guix/store/roots.scm +++ b/guix/store/roots.scm @@ -50,7 +50,7 @@ (define (gc-roots) "Return the list of garbage collector roots (\"GC roots\"). This includes -\"regular\" roots fount in %GC-ROOTS-DIRECTORY as well as indirect roots that +\"regular\" roots found in %GC-ROOTS-DIRECTORY as well as indirect roots that are user-controlled symlinks stored anywhere on the file system." (define (regular? file) (match file diff --git a/guix/svn-download.scm b/guix/svn-download.scm index b96151234c..28ad49977b 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> ;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; @@ -134,7 +134,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #$(svn-multi-reference-recursive? ref) #:user-name #$(svn-multi-reference-user-name ref) #:password #$(svn-multi-reference-password ref))) - '#$(svn-multi-reference-locations ref))))) + '#$(sexp->gexp (svn-multi-reference-locations ref)))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "svn-checkout") build diff --git a/guix/tests.scm b/guix/tests.scm index fc3d521163..da75835099 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -20,12 +20,13 @@ #:use-module ((guix config) #:select (%storedir %localstatedir)) #:use-module (guix store) #:use-module (guix derivations) + #:use-module (guix gexp) #:use-module (guix packages) #:use-module (guix base32) #:use-module (guix serialization) #:use-module (guix monads) #:use-module ((guix utils) #:select (substitute-keyword-arguments)) - #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build utils) #:select (mkdir-p compressor)) #:use-module ((gcrypt hash) #:hide (sha256)) #:use-module (guix build-system gnu) #:use-module (gnu packages base) @@ -60,7 +61,9 @@ dummy-package dummy-origin - gnu-make-for-tests)) + gnu-make-for-tests + + test-file)) ;;; Commentary: ;;; @@ -435,6 +438,42 @@ default values, and with EXTRA-FIELDS set as specified." (native-inputs '()) ;no need for 'pkg-config' (inputs %bootstrap-inputs-for-tests)))) + +;;; +;;; Test utility procedures. + +(define (test-file store name content) + "Create a simple file in STORE with CONTENT (a string), compressed according +to its file name extension. Return both its file name and its hash." + (let* ((ext (string-index-right name #\.)) + (name-sans-ext (if ext + (string-take name (string-index-right name #\.)) + name)) + (comp (compressor name)) + (command #~(if #+comp + (string-append #+%bootstrap-coreutils&co + "/bin/" #+comp) + #f)) + (f (with-imported-modules '((guix build utils)) + (computed-file name + #~(begin + (use-modules (guix build utils) + (rnrs io simple)) + (with-output-to-file #+name-sans-ext + (lambda _ + (format #t #+content))) + (when #+command + (invoke #+command #+name-sans-ext)) + (copy-file #+name #$output))))) + (file-drv (run-with-store store (lower-object f))) + (file (derivation->output-path file-drv)) + (file-drv-outputs (derivation-outputs file-drv)) + (_ (build-derivations store (list file-drv))) + (file-hash (derivation-output-hash + (assoc-ref file-drv-outputs "out")))) + (values file file-hash))) + +;;; ;; Local Variables: ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1) ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2) diff --git a/guix/utils.scm b/guix/utils.scm index 05af86fc37..19990ceb8a 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org> ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> ;;; @@ -37,7 +38,9 @@ #:use-module (rnrs io ports) ;need 'port-position' etc. #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix memoization) - #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively)) + #:use-module ((guix build utils) + #:select (dump-port mkdir-p delete-file-recursively + call-with-temporary-output-file %xz-parallel-args)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module ((guix combinators) #:select (fold2)) #:use-module (guix diagnostics) ;<location>, &error-location, etc. @@ -63,7 +66,9 @@ &fix-hint fix-hint? - condition-fix-hint) + condition-fix-hint + + call-with-temporary-output-file) #:export (strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments @@ -102,7 +107,6 @@ tarball-sans-extension compressed-file? switch-symlinks - call-with-temporary-output-file call-with-temporary-directory with-atomic-file-output @@ -242,6 +246,18 @@ a symbol such as 'xz." '())) (_ (error "unsupported compression scheme" compression)))) +(define (compressed-port compression input) + "Return an input port where INPUT is compressed according to COMPRESSION, +a symbol such as 'xz." + (match compression + ((or #f 'none) (values input '())) + ('bzip2 (filtered-port `(,%bzip2 "-c") input)) + ('xz (filtered-port `(,%xz "-c" ,@(%xz-parallel-args)) input)) + ('gzip (filtered-port `(,%gzip "-c") input)) + ('lzip (values (lzip-port 'make-lzip-input-port/compressed input) + '())) + (_ (error "unsupported compression scheme" compression)))) + (define (call-with-decompressed-port compression port proc) "Call PROC with a wrapper around PORT, a file port, that decompresses data read from PORT according to COMPRESSION, a symbol such as 'xz." @@ -734,22 +750,6 @@ REPLACEMENT." (substring str start index) pieces)))))))) -(define (call-with-temporary-output-file proc) - "Call PROC with a name of a temporary file and open output port to that -file; close the file and delete it when leaving the dynamic extent of this -call." - (let* ((directory (or (getenv "TMPDIR") "/tmp")) - (template (string-append directory "/guix-file.XXXXXX")) - (out (mkstemp! template))) - (dynamic-wind - (lambda () - #t) - (lambda () - (proc template out)) - (lambda () - (false-if-exception (close out)) - (false-if-exception (delete-file template)))))) - (define (call-with-temporary-directory proc) "Call PROC with a name of a temporary directory; close the directory and delete it when leaving the dynamic extent of this call." |