diff options
| -rw-r--r-- | guix/gexp.scm | 26 | ||||
| -rw-r--r-- | tests/gexp.scm | 31 |
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 |