mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2025-01-18 21:46:35 +01:00
DRAFT gexp: Turn grafting into a build continuation.
TODO: See FIXME in gexp.scm.
* guix/gexp.scm (gexp->derivation): Rename 'graft?' local variable to
'prev-graft?' and call (set-grafting? #f) unconditionally. When GRAFT?
is true, call 'set-build-continuation' for DRV.
* guix/grafts.scm (graft-derivation*, graft-continuation): New
procedures.
* tests/gexp.scm ("gexp-grafts"): Remove test that is now obsolete.
This commit is contained in:
Ludovic Courtès
parent
ca9050d517
commit
0602d92bb0
3 changed files with 71 additions and 52 deletions
|
|
@ -195,6 +195,9 @@ (define* (lower-object obj
|
|||
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 @@ (define (graphs-file-names graphs)
|
|||
(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 @@ (define (graphs-file-names graphs)
|
|||
#: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
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ (define-module (guix grafts)
|
|||
#: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 @@ (define-module (guix grafts)
|
|||
graft-derivation
|
||||
graft-derivation/shallow
|
||||
|
||||
graft-continuation
|
||||
|
||||
%graft?
|
||||
set-grafting))
|
||||
|
||||
|
|
@ -321,6 +324,26 @@ (define references
|
|||
(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.
|
||||
|
|
|
|||
|
|
@ -434,25 +434,6 @@ (define (match-input thing)
|
|||
(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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue