From ea7b5a8f3d3f5d66ba9c45fb0bc76d25b6ba916f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 7 Jan 2017 12:31:02 +0100 Subject: gexp: Compilers can now provide a procedure returning applicable grafts. * guix/gexp.scm ()[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. --- guix/gexp.scm | 139 ++++++++++++++++++++++++++++++++++++++++++------------ guix/packages.scm | 39 ++++++++++++--- tests/gexp.scm | 33 +++++++++++++ 3 files changed, 174 insertions(+), 37 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index 1f7fbef0a0..574d51e10d 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -34,6 +34,8 @@ (define-module (guix gexp) gexp-input gexp-input? + gexp-grafts + local-file local-file? local-file-file @@ -131,11 +133,12 @@ (define (write-gexp gexp port) ;; Compiler for a type of objects that may be introduced in a gexp. (define-record-type - (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 . @@ -150,6 +153,18 @@ (define (default-expander thing obj 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 @@ (define (lookup-expander object) (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 @@ (define* (lower-object obj (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 @@ (define-syntax define-gexp-compiler The more elaborate form allows you to specify an expander: - (define-gexp-compiler something something? + (define-gexp-compiler something-compiler 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 + applicable-grafts => grafts) + (define-gexp-compiler name record-type + compiler => compile + expander => default-expander + applicable-grafts => grafts)) ((_ name record-type compiler => compile - expander => expand) + 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 ) system target) @@ -320,13 +352,14 @@ (define* (computed-file name gexp This is the declarative counterpart of 'gexp->derivation'." (%computed-file name gexp options)) -(define-gexp-compiler (computed-file-compiler (file ) - system target) - ;; Compile FILE by returning a derivation whose build expression is its - ;; gexp. - (match file - (($ name gexp options) - (apply gexp->derivation name gexp options)))) +(define-gexp-compiler computed-file-compiler + compiler => (lambda (file system target) + ;; Compile FILE by returning a derivation whose build + ;; expression is its gexp. + (match file + (($ name gexp options) + (apply gexp->derivation name gexp options)))) + applicable-grafts => (propagated-applicable-grafts computed-file-gexp)) (define-record-type (%program-file name gexp guile) @@ -342,13 +375,15 @@ (define* (program-file name gexp #:key (guile #f)) This is the declarative counterpart of 'gexp->script'." (%program-file name gexp guile)) -(define-gexp-compiler (program-file-compiler (file ) - system target) - ;; Compile FILE by returning a derivation that builds the script. - (match file - (($ name gexp guile) - (gexp->script name gexp - #:guile (or guile (default-guile)))))) +(define-gexp-compiler program-file-compiler + compiler => (lambda (file system target) + ;; Compile FILE by returning a derivation that builds the + ;; script. + (match 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 name gexp) @@ -362,12 +397,14 @@ (define* (scheme-file name gexp) This is the declarative counterpart of 'gexp->file'." (%scheme-file name gexp)) -(define-gexp-compiler (scheme-file-compiler (file ) - system target) - ;; Compile FILE by returning a derivation that builds the file. - (match file - (($ name gexp) - (gexp->file name gexp)))) +(define-gexp-compiler scheme-file-compiler + compiler => (lambda (file system target) + ;; Compile FILE by returning a derivation that builds the + ;; file. + (match 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 @@ -391,7 +428,12 @@ (define-gexp-compiler file-append-compiler (($ 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 + (($ base _) + (let ((proc (lookup-graft-procedure base))) + (proc base system target)))))) ;;; @@ -510,6 +552,41 @@ (define default-guile-derivation (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? exp) _ #t) + (gexp-grafts exp system #:target #f)) + (($ (? gexp? exp) _ #f) + (gexp-grafts exp system #:target target)) + (($ (? struct? obj) _ #t) + (let ((applicable-grafts (lookup-graft-procedure obj))) + (applicable-grafts obj system #f))) + (($ (? struct? obj) _ #f) + (let ((applicable-grafts (lookup-graft-procedure obj))) + (applicable-grafts obj system target))) + (($ (lst ...) _ native?) + (foldm %store-monad + (lambda (input grafts) + (mlet %store-monad ((g (gexp-input-grafts input))) + (return (append g grafts)))) + '() + lst)) + (_ ;another or a + (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) diff --git a/guix/packages.scm b/guix/packages.scm index efa1623bc5..57ae7f9584 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1194,12 +1194,39 @@ (define package->derivation (define package->cross-derivation (store-lift package-cross-derivation)) -(define-gexp-compiler (package-compiler (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 + 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))) diff --git a/tests/gexp.scm b/tests/gexp.scm index baf78837ae..ea4243a3a6 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -453,6 +453,39 @@ (define (match-input thing) (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)) -- cgit v1.2.3