summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-12-06 23:12:49 +0100
committerLudovic Courtès <ludo@gnu.org>2020-01-04 23:44:26 +0100
commitd63ee94d63c667e0c63651d6b775460f4c67497d (patch)
treeb9b2615305e4c95fd80532b30f1517bfa28e499f
parentf918a8d9d80b9500d5f336c0d872fe06ef48c1e2 (diff)
downloadpatches-d63ee94d63c667e0c63651d6b775460f4c67497d.tar
patches-d63ee94d63c667e0c63651d6b775460f4c67497d.tar.gz
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.
-rw-r--r--guix/gexp.scm26
-rw-r--r--tests/gexp.scm31
2 files changed, 56 insertions, 1 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 912960fd1d..c4f4e80209 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 8b1596f66d..7c8985d846 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 <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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