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 ea7b5a8f3d3f5d66ba9c45fb0bc76d25b6ba916f
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)
    (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 1f7fbef..574d51e 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,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
+        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)
@@ -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)
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..ea4243a 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -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))