04/04: gexp: Add 'raw-derivation-file'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

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

    gexp: Add 'raw-derivation-file'.
    
    * guix/gexp.scm (<raw-derivation-file>): New record type.
    (raw-derivation-file-compiler): New gexp compiler.
    * tests/gexp.scm ("lower-gexp, raw-derivation-file")
    ("raw-derivation-file"): New tests.
---
 guix/gexp.scm  | 26 ++++++++++++++++++++++++++
 tests/gexp.scm | 31 ++++++++++++++++++++++++++++++-
 2 files changed, 56 insertions(+), 1 deletion(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 912960f..c4f4e80 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -79,6 +79,9 @@
             file-append-base
             file-append-suffix
 
+            raw-derivation-file
+            raw-derivation-file?
+
             load-path-expression
             gexp-modules
 
@@ -265,6 +268,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.
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 8b1596f..7c8985d 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès 
<address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -879,6 +879,17 @@
                    (eq? (derivation-input-derivation (lowered-gexp-guile lexp))
                         (%guile-for-build)))))))
 
+(test-assertm "lower-gexp, raw-derivation-file"
+  (mlet* %store-monad ((thing -> (program-file "prog" #~(display "hi!")))
+                       (exp -> #~(list #$(raw-derivation-file thing)))
+                       (drv  (lower-object thing))
+                       (lexp (lower-gexp exp #:effective-version "2.0")))
+    (return (and (equal? `(list ,(derivation-file-name drv))
+                         (lowered-gexp-sexp lexp))
+                 (equal? (list (derivation-file-name drv))
+                         (lowered-gexp-sources lexp))
+                 (null? (lowered-gexp-inputs lexp))))))
+
 (test-eq "lower-gexp, non-self-quoting input"
   +
   (guard (c ((gexp-input-error? c)
@@ -1157,6 +1168,24 @@
                        (equal? `(list "foo" ,text)
                                (call-with-input-file out read)))))))))
 
+(test-assertm "raw-derivation-file"
+  (let* ((exp #~(let ((drv #$(raw-derivation-file coreutils)))
+                  (when (file-exists? drv)
+                    (symlink drv #$output)))))
+    (mlet* %store-monad ((dep    (lower-object coreutils))
+                         (drv    (gexp->derivation "drv-ref" exp))
+                         (out -> (derivation->output-path drv)))
+      (mbegin %store-monad
+        (built-derivations (list drv))
+        (mlet %store-monad ((refs (references* out)))
+          (return (and (member (derivation-file-name dep)
+                               (derivation-sources drv))
+                       (not (member (derivation-file-name dep)
+                                    (map derivation-input-path
+                                         (derivation-inputs drv))))
+                       (equal? (readlink out) (derivation-file-name dep))
+                       (equal? refs (list (derivation-file-name dep))))))))))
+
 (test-assert "text-file*"
   (run-with-store %store
     (mlet* %store-monad