mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 13:36:36 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

DRAFT gexp: Turn grafting into a build continuation.

Browse source 
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 2017-01-09 23:20:25 +01:00
parent ca9050d517
commit 0602d92bb0
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 71 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

81
guix/gexp.scm
View file

@ -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

23
guix/grafts.scm
View file

@ -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.

19
tests/gexp.scm
View file

@ -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"