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

[Ludovic Courtès]

civodul pushed a commit to branch wip-gexp-grafts
in repository guix.

commit fddade98692da81b91329e7a77dd2c4942fd84cf
Author: Ludovic Courtès <address@hidden>
Date:   Sat Jan 7 12:31:02 2017 +0100

    gexp: Compilers can now provide a procedure returning applicable grafts.
    
    * guix/gexp.scm (<gexp-compiler>)[grafts]: New field.
    (default-applicable-grafts, lookup-graft-procedure): New procedures.
    (define-gexp-compiler): Support 'applicable-grafts' form.
    (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     |   86 ++++++++++++++++++++++++++++++++++++++++++++++-------
 guix/packages.scm |   39 ++++++++++++++++++++----
 tests/gexp.scm    |   28 +++++++++++++++++
 3 files changed, 137 insertions(+), 16 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 1f7fbef..b92f89b 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -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,12 @@ 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 (register-compiler! compiler)
   "Register COMPILER as a gexp compiler."
   (hashq-set! %gexp-compilers
@@ -167,6 +176,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 +193,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.
 
@@ -190,19 +205,30 @@ The more elaborate form allows you to specify an expander:
 
   (define-gexp-compiler something 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
+        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 <derivation>) system target)
@@ -391,7 +417,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 +541,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)
diff --git a/guix/packages.scm b/guix/packages.scm
index efa1623..57ae7f9 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -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)))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index baf7883..c9a77fd 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -453,6 +453,34 @@
                  (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"))))))
+    (mlet* %store-monad ((grafts0 (gexp-grafts exp0))
+                         (grafts1 (gexp-grafts exp1))
+                         (grafts2 (gexp-grafts exp2))
+                         (grafts3 (gexp-grafts exp3))
+                         (grafts4 (gexp-grafts exp4))
+                         (p0-drv  (package->derivation p0))
+                         (r-drv   (package->derivation r))
+                         (expected -> (graft
+                                        (origin p0-drv)
+                                        (replacement r-drv))))
+      (return (and (null? grafts0)
+                   (equal? grafts1 (list expected))
+                   (equal? grafts2 (list expected))
+                   (equal? grafts3 (list expected))
+                   (equal? grafts4 (list expected)))))))
+
 (test-assertm "gexp->derivation, composed gexps"
   (mlet* %store-monad ((exp0 -> (gexp (begin
                                         (mkdir (ungexp output))