diff options
author | Ludovic Courtès <ludo@gnu.org> | 2015-03-28 19:26:39 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2021-03-30 22:48:43 +0200 |
commit | 7d873f194ca69d6096d28d7a224ab78e83e34fe1 (patch) | |
tree | a89f505ab352b729908c8ca1691ac57fc61a5ba3 /guix/packages.scm | |
parent | a76b6f8120d54516e784da265884245cd6a3cc7d (diff) | |
download | guix-patches-7d873f194ca69d6096d28d7a224ab78e83e34fe1.tar guix-patches-7d873f194ca69d6096d28d7a224ab78e83e34fe1.tar.gz |
build-system: Rewrite using gexps.
* guix/packages.scm (expand-input): Remove 'store', 'system', and
'cross-system' parameters; add #:native?. Rewrite to return
name/gexp-input tuples.
(bag->derivation): Adjust accordingly. Lower (bag-build bag).
(bag->cross-derivation): Ditto. Instead of #:native-drvs and
#:target-drvs, pass #:build-inputs, #:host-inputs, and #:target-inputs.
(%derivation-cache): Remove.
* gnu/packages/bootstrap.scm (raw-build): Turn into a monadic procedure.
* gnu/packages/commencement.scm (glibc-final)[arguments]: Use
'gexp-input' for the #:allowed-references argument.
* guix/build-system/cmake.scm (cmake-build): Remove 'store' parameter.
Switch to the use of gexps and 'gexp->derivation'.
(lower): Remove #:source from 'private-keywords'.
* guix/build-system/glib-or-gtk.scm (glib-or-gtk-build, lower):
Likewise.
* guix/build-system/font.scm (font-build): Likewise.
* guix/build-system/gnu.scm (gnu-build): Likewise, and remove
'canonicalize-reference'.
(gnu-cross-build): Likewise, and expect #:build-inputs, #:host-inputs,
and #:target-inputs instead of #:native-drvs and #:target-drvs.
(lower): Likewise.
* guix/build-system/perl.scm (perl-build, lower): Likewise.
* guix/build-system/python.scm (python-build, lower): Likewise.
* guix/build-system/ruby.scm (ruby-build, lower): Likewise.
* guix/build-system/waf.scm (waf-build, lower): Likewise.
* guix/build-system/trivial.scm (guile-for-build): Remove.
(trivial-build): Remove 'store' parameter, change to gexps.
(trivial-cross-build): Ditto, and change to #:build-inputs & co.
* guix/build-system/cargo.scm (cargo-build): Change to 'gexp->derivation'.
* guix/build-system/copy.scm (copy-build): Likewise.
* guix/build-system/dune.scm (dune-build): Likewise.
* guix/build-system/guile.scm (guile-build, guile-cross-build):
Likewise.
* guix/build-system/meson.scm (meson-build): Likewise.
* guix/build-system/ocaml.scm (ocaml-build): Likewise.
* guix/build-system/scons.scm (scons-build): Likewise.
* guix/build-system/texlive.scm (texlive-build): Likewise.
* guix/build-system/android-ndk.scm (android-ndk-build): Likewise.
* guix/build-system/ant.scm (ant-build): Likewise.
* guix/build-system/asdf.scm (asdf-build/source, asdf-build): Likewise.
* guix/build-system/chicken.scm (chicken-build): Likewise.
* guix/build-system/clojure.scm (clojure-build): Likewise.
(source->output-path, maybe-guile->guile): Remove.
* guix/build-system/dub.scm (dub-build): Likewise.
* guix/build-system/emacs.scm (emacs-build): Likewise.
* guix/build-system/go.scm (go-build): Likewise.
* guix/build-system/haskell.scm (haskell-build): Likewise.
* guix/build-system/julia.scm (julia-build): Likewise.
* guix/build-system/linux-module.scm (linux-module-build)
(linux-module-build-cross): Likewise.
* guix/build-system/maven.scm (maven-build): Likewise.
* guix/build-system/minify.scm (minify-build): Likewise.
* guix/build-system/node.scm (node-build): Likewise.
* guix/build-system/qt.scm (qt-build, qt-cross-build): Likewise.
* guix/build-system/r.scm (r-build): Likewise.
* guix/build-system/rakudo.scm (rakudo-build): Likewise.
* guix/build-system/renpy.scm (renpy-build): Likewise.
* tests/builders.scm ("gnu-build"): Call 'store-lower' on 'gnu-build'.
Pass #:source parameter.
* tests/packages.scm ("search paths"): Use 'abort-to-prompt' instead of
a normal return from the 'build' method.
("package->bag, sensitivity to %current-target-system"): Change 'build'
to match the new build system signature.
squash! build-system: Rewrite using gexps.
squash! build-system: Rewrite using gexps.
Diffstat (limited to 'guix/packages.scm')
-rw-r--r-- | guix/packages.scm | 77 |
1 files changed, 29 insertions, 48 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index 56173e1204..6dc652fe7a 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1174,10 +1174,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." @@ -1209,48 +1205,29 @@ Return the cached result when available." ((_ 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))) +(define* (expand-input package input #:key native?) + "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is +only used to provide contextual information in exceptions." + (define (valid? x) + (or (package? x) (origin? x) (derivation? x))) (match input - (((? string? name) (? package? package)) - (list name (derivation package))) - (((? string? name) (? package? package) - (? string? sub-drv)) - (list name (derivation package) - sub-drv)) - (((? string? name) - (and (? string?) (? derivation-path?) drv)) - (list name drv)) + (((? string? name) (? valid? thing)) + (list name (gexp-input thing #:native? native?))) + (((? string? name) (? valid? thing) (? string? output)) + (list name (gexp-input thing output #:native? native?))) (((? string? name) (and (? string?) (? file-exists? file))) ;; Add FILE to the store. When FILE is in the sub-directory of a ;; store path, it needs to be added anyway, so it can be used as a ;; source. - (list name (intern file))) + (list name (gexp-input (local-file file #:recursive? #t) + #:native? native?))) (((? 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)))) + ;; location info, so we used to catch and rethrow here (FIXME!). + (list name (gexp-input source))) (x (raise (condition (&package-input-error (package package) @@ -1434,12 +1411,14 @@ TARGET." (define (input=? input1 input2) "Return true if INPUT1 and INPUT2 are equivalent." (match input1 - ((label1 drv1 . outputs1) + ((label1 obj1 . outputs1) (match input2 - ((label2 drv2 . outputs2) + ((label2 obj2 . outputs2) (and (string=? label1 label2) (equal? outputs1 outputs2) - (derivation=? drv1 drv2))))))) + (or (and (derivation? obj1) (derivation? obj2) + (derivation=? obj1 obj2)) + (equal? obj1 obj2)))))))) (define* (bag->derivation store bag #:optional context) @@ -1450,7 +1429,7 @@ error reporting." (bag->cross-derivation store bag) (let* ((system (bag-system bag)) (inputs (bag-transitive-inputs bag)) - (input-drvs (map (cut expand-input store context <> system) + (input-drvs (map (cut expand-input context <> #:native? #t) inputs)) (paths (delete-duplicates (append-map (match-lambda @@ -1462,7 +1441,8 @@ error reporting." ;; 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) + ;; TODO: Change to monadic style. + (apply (store-lower (bag-build bag)) store (bag-name bag) (delete-duplicates input-drvs input=?) #:search-paths paths @@ -1477,13 +1457,13 @@ This is an internal procedure." (let* ((system (bag-system bag)) (target (bag-target bag)) (host (bag-transitive-host-inputs bag)) - (host-drvs (map (cut expand-input store context <> system target) + (host-drvs (map (cut expand-input context <> #:native? #f) host)) (target* (bag-transitive-target-inputs bag)) - (target-drvs (map (cut expand-input store context <> system) + (target-drvs (map (cut expand-input context <> #:native? #t) target*)) (build (bag-transitive-build-inputs bag)) - (build-drvs (map (cut expand-input store context <> system) + (build-drvs (map (cut expand-input context <> #:native? #t) build)) (all (append build target* host)) (paths (delete-duplicates @@ -1500,11 +1480,12 @@ This is an internal procedure." (_ '())) all)))) - (apply (bag-build bag) + ;; TODO: Change to monadic style. + (apply (store-lower (bag-build bag)) store (bag-name bag) - #:native-drvs (delete-duplicates build-drvs input=?) - #:target-drvs (delete-duplicates (append host-drvs target-drvs) - input=?) + #: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) |