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.master
parent
f918a8d9d8
commit
d63ee94d63
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
Reference in New Issue