05/08: DRAFT gexp: Add 'raw-derivation-file'.

[guix-commits]

civodul pushed a commit to branch wip-system-bootstrap
in repository guix.

commit e6686ee5a9144f65b58d05a04d654bb243fb07d5
Author: Ludovic Courtès <address@hidden>
Date:   Fri Dec 6 23:12:49 2019 +0100

    DRAFT gexp: Add 'raw-derivation-file'.
    
    DRAFT: Add tests.
    
    * guix/gexp.scm (<raw-derivation-file>): New record type.
    (raw-derivation-file-compiler): New gexp compiler.
---
 guix/gexp.scm | 26 ++++++++++++++++++++++++++
 1 file changed, 26 insertions(+)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index a96592a..34df49f 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -78,6 +78,9 @@
             file-append-base
             file-append-suffix
 
+            raw-derivation-file
+            raw-derivation-file?
+
             load-path-expression
             gexp-modules
 
@@ -264,6 +267,29 @@ The expander specifies how an object is converted to its 
sexp representation."
   (with-monad %store-monad
     (return drv)))
 
+;; Expand to a raw ".drv" file for the lowerable object it wraps.  In other
+;; words, this gives the raw ".drv" file instead of its build result.
+(define-record-type <raw-derivation-file>
+  (raw-derivation-file obj)
+  raw-derivation-file?
+  (obj  raw-derivation-file-object))              ;lowerable object
+
+(define-gexp-compiler raw-derivation-file-compiler <raw-derivation-file>
+  compiler => (lambda (obj system target)
+                (mlet %store-monad ((obj (lower-object
+                                          (raw-derivation-file-object obj)
+                                          system #:target target)))
+                  ;; Returning the .drv file name instead of the <derivation>
+                  ;; record ensures that 'lower-gexp' will classify it as a
+                  ;; "source" and not as an "input".
+                  (return (if (derivation? obj)
+                              (derivation-file-name obj)
+                              obj))))
+  expander => (lambda (obj lowered output)
+                (if (derivation? lowered)
+                    (derivation-file-name lowered)
+                    lowered)))
+
 
 ;;;
 ;;; File declarations.