amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

gexp: Compilers can now provide a procedure returning applicable grafts.

Browse source 
* guix/gexp.scm (<gexp-compiler>)[grafts]: New field.
(default-applicable-grafts, lookup-graft-procedure)
(propagated-applicable-grafts): New procedures.
(define-gexp-compiler): Support 'applicable-grafts' form.
(computed-file-compiler, program-file-compiler)
(scheme-file-compiler, file-append-compiler): Add 'applicable-grafts'
form.
(gexp-grafts): New procedure.
* guix/packages.scm (replacement-graft*): New procedure.
(package-compiler): Add 'applicable-grafts' form.
* tests/gexp.scm ("gexp-grafts"): New test.
This commit is contained in:
Ludovic Courtès 2017-01-07 12:31:02 +01:00
parent 2c13d74181
commit ea7b5a8f3d
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 174 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

139
guix/gexp.scm
View file

@ -34,6 +34,8 @@
gexp-input
gexp-input?
gexp-grafts
local-file
local-file?
local-file-file
@ -131,11 +133,12 @@
;; Compiler for a type of objects that may be introduced in a gexp.
(define-record-type <gexp-compiler>
(gexp-compiler type lower expand)
(gexp-compiler type lower expand grafts)
gexp-compiler?
(type gexp-compiler-type) ;record type descriptor
(type gexp-compiler-type) ;record type descriptor
(lower gexp-compiler-lower)
(expand gexp-compiler-expand)) ;#f | DRV -> sexp
(expand gexp-compiler-expand) ;DRV -> sexp
(grafts gexp-compiler-applicable-grafts)) ;thing system target -> grafts
(define %gexp-compilers
;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
@ -150,6 +153,18 @@ returns its output file name of OBJ's OUTPUT."
((? string? file)
file)))
(define (default-applicable-grafts thing system target)
"This is the default procedure returning applicable grafts for THING. It
returns the empty list---i.e., no grafts need to be applied."
(with-monad %store-monad
(return '())))
(define (propagated-applicable-grafts field)
"Return a monadic procedure that propagates applicable grafts of the gexp
returned by applying FIELD to the object."
(lambda (thing system target)
(gexp-grafts (field thing) #:target target)))
(define (register-compiler! compiler)
"Register COMPILER as a gexp compiler."
(hashq-set! %gexp-compilers
@ -167,6 +182,12 @@ procedure to expand it; otherwise return #f."
(and=> (hashq-ref %gexp-compilers (struct-vtable object))
gexp-compiler-expand))
(define (lookup-graft-procedure object)
"Search for a procedure returning the list of applicable grafts for OBJECT.
Upon success, return the three argument procedure; otherwise return #f."
(and=> (hashq-ref %gexp-compilers (struct-vtable object))
gexp-compiler-applicable-grafts))
(define* (lower-object obj
#:optional (system (%current-system))
#:key target)
@ -178,7 +199,7 @@ OBJ must be an object that has an associated gexp compiler, such as a
(lower obj system target)))
(define-syntax define-gexp-compiler
(syntax-rules (=> compiler expander)
(syntax-rules (=> compiler expander applicable-grafts)
"Define NAME as a compiler for objects matching PREDICATE encountered in
gexps.
@ -188,21 +209,32 @@ object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
The more elaborate form allows you to specify an expander:
(define-gexp-compiler something something?
(define-gexp-compiler something-compiler <something>
compiler => (lambda (param system target) ...)
expander => (lambda (param drv output) ...))
expander => (lambda (param drv output) ...)
applicable-grafts => (lambda (param system target) ...))
The expander specifies how an object is converted to its sexp representation."
The expander specifies how an object is converted to its sexp representation.
The 'applicable-grafts' monadic procedure returns a list of grafts that can be
applied to the object."
((_ (name (param record-type) system target) body ...)
(define-gexp-compiler name record-type
compiler => (lambda (param system target) body ...)
expander => default-expander))
applicable-grafts => default-applicable-grafts))
((_ name record-type
compiler => compile
expander => expand)
applicable-grafts => grafts)
(define-gexp-compiler name record-type
compiler => compile
expander => default-expander
applicable-grafts => grafts))
((_ name record-type
compiler => compile
expander => expand
applicable-grafts => grafts)
(begin
(define name
(gexp-compiler record-type compile expand))
(gexp-compiler record-type compile expand grafts))
(register-compiler! name)))))
(define-gexp-compiler (derivation-compiler (drv <derivation>) system target)
@ -320,13 +352,14 @@ to 'gexp->derivation'.
This is the declarative counterpart of 'gexp->derivation'."
(%computed-file name gexp options))
(define-gexp-compiler (computed-file-compiler (file <computed-file>)
system target)
;; Compile FILE by returning a derivation whose build expression is its
;; gexp.
(match file
(($ <computed-file> name gexp options)
(apply gexp->derivation name gexp options))))
(define-gexp-compiler computed-file-compiler <computed-file>
compiler => (lambda (file system target)
;; Compile FILE by returning a derivation whose build
;; expression is its gexp.
(match file
(($ <computed-file> name gexp options)
(apply gexp->derivation name gexp options))))
applicable-grafts => (propagated-applicable-grafts computed-file-gexp))
(define-record-type <program-file>
(%program-file name gexp guile)
@ -342,13 +375,15 @@ GEXP. GUILE is the Guile package used to execute that script.
This is the declarative counterpart of 'gexp->script'."
(%program-file name gexp guile))
(define-gexp-compiler (program-file-compiler (file <program-file>)
system target)
;; Compile FILE by returning a derivation that builds the script.
(match file
(($ <program-file> name gexp guile)
(gexp->script name gexp
#:guile (or guile (default-guile))))))
(define-gexp-compiler program-file-compiler <program-file>
compiler => (lambda (file system target)
;; Compile FILE by returning a derivation that builds the
;; script.
(match file
(($ <program-file> name gexp guile)
(gexp->script name gexp
#:guile (or guile (default-guile))))))
applicable-grafts => (propagated-applicable-grafts program-file-gexp))
(define-record-type <scheme-file>
(%scheme-file name gexp)
@ -362,12 +397,14 @@ This is the declarative counterpart of 'gexp->script'."
This is the declarative counterpart of 'gexp->file'."
(%scheme-file name gexp))
(define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
system target)
;; Compile FILE by returning a derivation that builds the file.
(match file
(($ <scheme-file> name gexp)
(gexp->file name gexp))))
(define-gexp-compiler scheme-file-compiler <scheme-file>
compiler => (lambda (file system target)
;; Compile FILE by returning a derivation that builds the
;; file.
(match file
(($ <scheme-file> name gexp)
(gexp->file name gexp))))
applicable-grafts => (propagated-applicable-grafts scheme-file-gexp))
;; Appending SUFFIX to BASE's output file name.
(define-record-type <file-append>
@ -391,7 +428,12 @@ SUFFIX."
(($ <file-append> base suffix)
(let* ((expand (lookup-expander base))
(base (expand base lowered output)))
(string-append base (string-concatenate suffix)))))))
(string-append base (string-concatenate suffix))))))
applicable-grafts => (lambda (obj system target)
(match obj
(($ <file-append> base _)
(let ((proc (lookup-graft-procedure base)))
(proc base system target))))))
;;;
@ -510,6 +552,41 @@ names and file names suitable for the #:allowed-references argument to
(lambda (system)
((force proc) system))))
(define* (gexp-grafts exp
#:optional (system (%current-system))
#:key target)
"Return the list of grafts applicable to a derivation built by EXP, a gexp,
for SYSTEM and TARGET (the latter is #f when building natively).
This works by querying the list applicable grafts of each object EXP
references---e.g., packages."
(with-monad %store-monad
(define gexp-input-grafts
(match-lambda
(($ <gexp-input> (? gexp? exp) _ #t)
(gexp-grafts exp system #:target #f))
(($ <gexp-input> (? gexp? exp) _ #f)
(gexp-grafts exp system #:target target))
(($ <gexp-input> (? struct? obj) _ #t)
(let ((applicable-grafts (lookup-graft-procedure obj)))
(applicable-grafts obj system #f)))
(($ <gexp-input> (? struct? obj) _ #f)
(let ((applicable-grafts (lookup-graft-procedure obj)))
(applicable-grafts obj system target)))
(($ <gexp-input> (lst ...) _ native?)
(foldm %store-monad
(lambda (input grafts)
(mlet %store-monad ((g (gexp-input-grafts input)))
(return (append g grafts))))
'()
lst))
(_ ;another <gexp-input> or a <gexp-output>
(return '()))))
(>>= (mapm %store-monad gexp-input-grafts (gexp-references exp))
(lift1 (compose delete-duplicates concatenate)
%store-monad))))
(define* (gexp->derivation name exp
#:key
system (target 'current)

39
guix/packages.scm
View file

@ -1194,12 +1194,39 @@ cross-compilation target triplet."
(define package->cross-derivation
(store-lift package-cross-derivation))
(define-gexp-compiler (package-compiler (package <package>) system target)
;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
;; TARGET. This is used when referring to a package from within a gexp.
(if target
(package->cross-derivation package target system)
(package->derivation package system)))
(define replacement-graft*
(let ((native (store-lift replacement-graft))
(cross (store-lift replacement-cross-graft)))
(lambda (package system target)
"Return, as a monadic value, the replacement graft for PACKAGE, assuming
it has a replacement."
(if target
(cross package system target)
(native package system)))))
(define-gexp-compiler package-compiler <package>
compiler
=> (lambda (package system target)
;; Compile PACKAGE to a derivation for SYSTEM, optionally
;; cross-compiled for TARGET. This is used when referring to a package
;; from within a gexp.
(if target
(package->cross-derivation package target system)
(package->derivation package system)))
applicable-grafts
=> (let ((bag-grafts* (store-lift bag-grafts)))
(lambda (package system target)
;; Return the list of grafts that apply to things that reference
;; PACKAGE.
(mlet* %store-monad ((bag -> (package->bag package
system target))
(grafts (bag-grafts* bag)))
(if (package-replacement package)
(mlet %store-monad ((repl (replacement-graft* package
system target)))
(return (cons repl grafts)))
(return grafts))))))
(define* (origin->derivation origin
#:optional (system (%current-system)))

33
tests/gexp.scm
View file

@ -453,6 +453,39 @@
(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"
(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))))
(exp2 (gexp (frob (ungexp (list (gexp-input p1))))))
(exp3 (gexp (stuff (ungexp exp1))))
(exp4 (gexp (frob (ungexp (file-append p1 "/bin/foo")))))
(exp5 (gexp (frob (ungexp (computed-file "foo" exp1)))))
(exp6 (gexp (frob (ungexp (program-file "foo" exp1)))))
(exp7 (gexp (frob (ungexp (scheme-file "foo" exp1))))))
(mlet* %store-monad ((grafts0 (gexp-grafts exp0))
(grafts1 (gexp-grafts exp1))
(grafts2 (gexp-grafts exp2))
(grafts3 (gexp-grafts exp3))
(grafts4 (gexp-grafts exp4))
(grafts5 (gexp-grafts exp5))
(grafts6 (gexp-grafts exp6))
(grafts7 (gexp-grafts exp7))
(p0-drv (package->derivation p0))
(r-drv (package->derivation r))
(expected -> (graft
(origin p0-drv)
(replacement r-drv))))
(return (and (null? grafts0)
(equal? grafts1 grafts2 grafts3 grafts4
grafts5 grafts6 grafts7
(list expected)))))))
(test-assertm "gexp->derivation, composed gexps"
(mlet* %store-monad ((exp0 -> (gexp (begin
(mkdir (ungexp output))