diff options
| -rw-r--r-- | guix/gexp.scm | 81 | ||||
| -rw-r--r-- | guix/grafts.scm | 23 | ||||
| -rw-r--r-- | tests/gexp.scm | 19 |
3 files changed, 71 insertions, 52 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index 574d51e10d..edeb12ea26 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -195,6 +195,9 @@ Upon success, return the three argument procedure; otherwise return #f." corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. OBJ must be an object that has an associated gexp compiler, such as a <package>." + ;; FIXME: Must register build continuation (or 'guix system build' does not + ;; graft its things because 'system-derivation' uses 'lower-object', not + ;; 'gexp->derivation'.) (let ((lower (lookup-compiler obj))) (lower obj system target))) @@ -656,7 +659,7 @@ The other arguments are as for 'derivation'." (mlet* %store-monad (;; The following binding forces '%current-system' and ;; '%current-target-system' to be looked up at >>= ;; time. - (graft? (set-grafting graft?)) + (prev-graft? (set-grafting #f)) (system -> (or system (%current-system))) (target -> (if (eq? target 'current) @@ -701,38 +704,50 @@ The other arguments are as for 'derivation'." #:system system #:target target) (return #f))) - (guile (if guile-for-build - (return guile-for-build) - (default-guile-derivation system)))) - (mbegin %store-monad - (set-grafting graft?) ;restore the initial setting - (raw-derivation name - (string-append (derivation->output-path guile) - "/bin/guile") - `("--no-auto-compile" - ,@(if (pair? %modules) - `("-L" ,(derivation->output-path modules) - "-C" ,(derivation->output-path compiled)) - '()) - ,builder) - #:outputs outputs - #:env-vars env-vars - #:system system - #:inputs `((,guile) - (,builder) - ,@(if modules - `((,modules) (,compiled) ,@inputs) - inputs) - ,@(match graphs - (((_ . inputs) ...) inputs) - (_ '()))) - #:hash hash #:hash-algo hash-algo #:recursive? recursive? - #:references-graphs (and=> graphs graphs-file-names) - #:allowed-references allowed - #:disallowed-references disallowed - #:leaked-env-vars leaked-env-vars - #:local-build? local-build? - #:substitutable? substitutable?)))) + (guile (if guile-for-build + (return guile-for-build) + (default-guile-derivation system)))) + (>>= (mbegin %store-monad + (set-grafting prev-graft?) ;restore the initial setting + (raw-derivation name + (string-append (derivation->output-path guile) + "/bin/guile") + `("--no-auto-compile" + ,@(if (pair? %modules) + `("-L" ,(derivation->output-path modules) + "-C" ,(derivation->output-path compiled)) + '()) + ,builder) + #:outputs outputs + #:env-vars env-vars + #:system system + #:inputs `((,guile) + (,builder) + ,@(if modules + `((,modules) (,compiled) ,@inputs) + inputs) + ,@(match graphs + (((_ . inputs) ...) inputs) + (_ '()))) + #:hash hash #:hash-algo hash-algo #:recursive? recursive? + #:references-graphs (and=> graphs graphs-file-names) + #:allowed-references allowed + #:disallowed-references disallowed + #:leaked-env-vars leaked-env-vars + #:local-build? local-build? + #:substitutable? substitutable?)) + (if graft? + (lambda (drv) + ;; Register a build continuation to apply the relevant grafts + ;; to the outputs of DRV. + (mlet %store-monad ((grafts (gexp-grafts exp system + #:target target))) + (mbegin %store-monad + (set-build-continuation (derivation-file-name drv) + (graft-continuation drv grafts)) + (return drv)))) + (lambda (drv) + (with-monad %store-monad (return drv))))))) (define* (gexp-inputs exp #:key native?) "Return the input list for EXP. When NATIVE? is true, return only native diff --git a/guix/grafts.scm b/guix/grafts.scm index 2006d3908e..da106ae0dc 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -29,6 +29,7 @@ #:use-module (srfi srfi-34) #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module (ice-9 format) #:export (graft? graft graft-origin @@ -39,6 +40,8 @@ graft-derivation graft-derivation/shallow + graft-continuation + %graft? set-grafting)) @@ -321,6 +324,26 @@ DRV itself to refer to those grafted dependencies." (graft-replacement first) drv)))) +(define graft-derivation* + (store-lift graft-derivation)) + +(define (graft-continuation drv grafts) + "Return a monadic thunk that acts as a built continuation applying GRAFTS to +the result of DRV." + (define _ gettext) ;FIXME: (guix ui)? + (match grafts + (() + (lift1 (const '()) %store-monad)) + (x + (lambda (drv-file-name) + (format #t (_ "applying ~a grafts to~{ ~a~}~%") + (length grafts) + (match (derivation->output-paths drv) + (((outputs . items) ...) + items))) + (mlet %store-monad ((drv (graft-derivation* drv grafts))) + (return (list (derivation-file-name drv)))))))) + ;; The following might feel more at home in (guix packages) but since (guix ;; gexp), which is a lower level, needs them, we put them here. diff --git a/tests/gexp.scm b/tests/gexp.scm index ea4243a3a6..cb4e1c9487 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -434,25 +434,6 @@ (equal? refs (list (dirname (dirname guile)))) (equal? refs2 (list file)))))) -(test-assertm "gexp->derivation vs. grafts" - (mlet* %store-monad ((graft? (set-grafting #f)) - (p0 -> (dummy-package "dummy" - (arguments - '(#:implicit-inputs? #f)))) - (r -> (package (inherit p0) (name "DuMMY"))) - (p1 -> (package (inherit p0) (replacement r))) - (exp0 -> (gexp (frob (ungexp p0) (ungexp output)))) - (exp1 -> (gexp (frob (ungexp p1) (ungexp output)))) - (void (set-guile-for-build %bootstrap-guile)) - (drv0 (gexp->derivation "t" exp0 #:graft? #t)) - (drv1 (gexp->derivation "t" exp1 #:graft? #t)) - (drv1* (gexp->derivation "t" exp1 #:graft? #f)) - (_ (set-grafting graft?))) - (return (and (not (string=? (derivation->output-path drv0) - (derivation->output-path drv1))) - (string=? (derivation->output-path drv0) - (derivation->output-path drv1*)))))) - (test-assertm "gexp-grafts" ;; Make sure 'gexp-grafts' returns the graft to replace P1 by R. (let* ((p0 (dummy-package "dummy" |