mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
packages: Call 'bag-grafts' only on the tip of the package graph.
This reinstates pre-gexp behavior where 'expand-input' would explicitly pass #:graft? #f in recursive calls, thereby preventing redundant calls to 'bag-grafts'. * guix/packages.scm (expand-input): Turn into a monadic procedure. Lower INPUT when it's a package, passing #:graft? #f. (bag->derivation, bag->cross-derivation): Adjust accordingly. * tests/packages.scm ("search paths"): Adjust so BUILD aborts only when passed the package of interest.
This commit is contained in:
parent
e7477dd59b
commit
89b0c2390a
2 changed files with 98 additions and 67 deletions
|
@ -1210,25 +1210,45 @@ (define-syntax cached
|
||||||
(#f
|
(#f
|
||||||
(cache! cache package key thunk)))))))
|
(cache! cache package key thunk)))))))
|
||||||
|
|
||||||
(define* (expand-input package input #:key native?)
|
(define* (expand-input package input #:key target)
|
||||||
"Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
|
"Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
|
||||||
only used to provide contextual information in exceptions."
|
only used to provide contextual information in exceptions."
|
||||||
|
(with-monad %store-monad
|
||||||
(match input
|
(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))
|
(((? string? name) (? file-like? thing))
|
||||||
(list name (gexp-input thing #:native? native?)))
|
(return (list name (gexp-input thing #:native? (not target)))))
|
||||||
(((? string? name) (? file-like? thing) (? string? output))
|
(((? string? name) (? file-like? thing) (? string? output))
|
||||||
(list name (gexp-input thing output #:native? native?)))
|
(return (list name (gexp-input thing output #:native? (not target)))))
|
||||||
(((? string? name)
|
(((? string? name)
|
||||||
(and (? string?) (? file-exists? file)))
|
(and (? string?) (? file-exists? file)))
|
||||||
;; Add FILE to the store. When FILE is in the sub-directory of a
|
;; 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
|
;; store path, it needs to be added anyway, so it can be used as a
|
||||||
;; source.
|
;; source.
|
||||||
(list name (gexp-input (local-file file #:recursive? #t)
|
(return (list name (gexp-input (local-file file #:recursive? #t)
|
||||||
#:native? native?)))
|
#:native? (not target)))))
|
||||||
(x
|
(x
|
||||||
(raise (condition (&package-input-error
|
(raise (condition (&package-input-error
|
||||||
(package package)
|
(package package)
|
||||||
(input x)))))))
|
(input x))))))))
|
||||||
|
|
||||||
(define %bag-cache
|
(define %bag-cache
|
||||||
;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
|
;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
|
||||||
|
@ -1438,11 +1458,12 @@ (define* (bag->derivation bag #:optional context)
|
||||||
error reporting."
|
error reporting."
|
||||||
(if (bag-target bag)
|
(if (bag-target bag)
|
||||||
(bag->cross-derivation bag)
|
(bag->cross-derivation bag)
|
||||||
(let* ((system (bag-system bag))
|
(mlet* %store-monad ((system -> (bag-system bag))
|
||||||
(inputs (bag-transitive-inputs bag))
|
(inputs -> (bag-transitive-inputs bag))
|
||||||
(input-drvs (map (cut expand-input context <> #:native? #t)
|
(input-drvs (mapm %store-monad
|
||||||
|
(cut expand-input context <>)
|
||||||
inputs))
|
inputs))
|
||||||
(paths (delete-duplicates
|
(paths -> (delete-duplicates
|
||||||
(append-map (match-lambda
|
(append-map (match-lambda
|
||||||
((_ (? package? p) _ ...)
|
((_ (? package? p) _ ...)
|
||||||
(package-native-search-paths
|
(package-native-search-paths
|
||||||
|
@ -1462,25 +1483,29 @@ (define* (bag->cross-derivation bag #:optional context)
|
||||||
"Return the derivation to build BAG, which is actually a cross build.
|
"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.
|
Optionally, CONTEXT can be a package object denoting the context of the call.
|
||||||
This is an internal procedure."
|
This is an internal procedure."
|
||||||
(let* ((system (bag-system bag))
|
(mlet* %store-monad ((system -> (bag-system bag))
|
||||||
(target (bag-target bag))
|
(target -> (bag-target bag))
|
||||||
(host (bag-transitive-host-inputs bag))
|
(host -> (bag-transitive-host-inputs bag))
|
||||||
(host-drvs (map (cut expand-input context <> #:native? #f)
|
(host-drvs (mapm %store-monad
|
||||||
|
(cut expand-input context <>
|
||||||
|
#:target target)
|
||||||
host))
|
host))
|
||||||
(target* (bag-transitive-target-inputs bag))
|
(target* -> (bag-transitive-target-inputs bag))
|
||||||
(target-drvs (map (cut expand-input context <> #:native? #t)
|
(target-drvs (mapm %store-monad
|
||||||
|
(cut expand-input context <>)
|
||||||
target*))
|
target*))
|
||||||
(build (bag-transitive-build-inputs bag))
|
(build -> (bag-transitive-build-inputs bag))
|
||||||
(build-drvs (map (cut expand-input context <> #:native? #t)
|
(build-drvs (mapm %store-monad
|
||||||
|
(cut expand-input context <>)
|
||||||
build))
|
build))
|
||||||
(all (append build target* host))
|
(all -> (append build target* host))
|
||||||
(paths (delete-duplicates
|
(paths -> (delete-duplicates
|
||||||
(append-map (match-lambda
|
(append-map (match-lambda
|
||||||
((_ (? package? p) _ ...)
|
((_ (? package? p) _ ...)
|
||||||
(package-search-paths p))
|
(package-search-paths p))
|
||||||
(_ '()))
|
(_ '()))
|
||||||
all)))
|
all)))
|
||||||
(npaths (delete-duplicates
|
(npaths -> (delete-duplicates
|
||||||
(append-map (match-lambda
|
(append-map (match-lambda
|
||||||
((_ (? package? p) _ ...)
|
((_ (? package? p) _ ...)
|
||||||
(package-native-search-paths
|
(package-native-search-paths
|
||||||
|
|
|
@ -858,6 +858,7 @@ (define compressors '(("gzip" . "gz")
|
||||||
|
|
||||||
(test-assert "search paths"
|
(test-assert "search paths"
|
||||||
(let* ((p (make-prompt-tag "return-search-paths"))
|
(let* ((p (make-prompt-tag "return-search-paths"))
|
||||||
|
(t (make-parameter "guile-0"))
|
||||||
(s (build-system
|
(s (build-system
|
||||||
(name 'raw)
|
(name 'raw)
|
||||||
(description "Raw build system with direct store access")
|
(description "Raw build system with direct store access")
|
||||||
|
@ -870,7 +871,10 @@ (define compressors '(("gzip" . "gz")
|
||||||
(build
|
(build
|
||||||
(lambda* (name inputs
|
(lambda* (name inputs
|
||||||
#:key outputs system search-paths)
|
#:key outputs system search-paths)
|
||||||
(abort-to-prompt p search-paths))))))))
|
(if (string=? name (t))
|
||||||
|
(abort-to-prompt p search-paths)
|
||||||
|
(gexp->derivation name
|
||||||
|
#~(mkdir #$output))))))))))
|
||||||
(x (list (search-path-specification
|
(x (list (search-path-specification
|
||||||
(variable "GUILE_LOAD_PATH")
|
(variable "GUILE_LOAD_PATH")
|
||||||
(files '("share/guile/site/2.0")))
|
(files '("share/guile/site/2.0")))
|
||||||
|
@ -895,8 +899,10 @@ (define compressors '(("gzip" . "gz")
|
||||||
(lambda (k search-paths)
|
(lambda (k search-paths)
|
||||||
search-paths))))))
|
search-paths))))))
|
||||||
(and (null? (collect (package-derivation %store a)))
|
(and (null? (collect (package-derivation %store a)))
|
||||||
(equal? x (collect (package-derivation %store b)))
|
(parameterize ((t "guile-foo-0"))
|
||||||
(equal? x (collect (package-derivation %store c)))))))
|
(equal? x (collect (package-derivation %store b))))
|
||||||
|
(parameterize ((t "guile-bar-0"))
|
||||||
|
(equal? x (collect (package-derivation %store c))))))))
|
||||||
|
|
||||||
(test-assert "package-transitive-native-search-paths"
|
(test-assert "package-transitive-native-search-paths"
|
||||||
(let* ((sp (lambda (name)
|
(let* ((sp (lambda (name)
|
||||||
|
|
Loading…
Reference in a new issue