aboutsummaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-04-11 13:48:55 +0200
committerLudovic Courtès <ludo@gnu.org>2014-04-11 19:08:25 +0200
commitef09fdfb67d9c123dd807124e3f8381875d7d12c (patch)
tree09e10ab8bb639200ae40f480d8fc6ac2b9f05b78 /gnu/system
parente1a87b904a7f889bf080085c2aaef035b55d111a (diff)
downloadgnu-guix-ef09fdfb67d9c123dd807124e3f8381875d7d12c.tar
gnu-guix-ef09fdfb67d9c123dd807124e3f8381875d7d12c.tar.gz
vm: Factorize input conversion.
* gnu/system/vm.scm (input->name+output): New procedure. (expression->derivation-in-linux-vm): Use it for 'input-alist'. (qemu-image)[input->name+derivation]: Remove. Use 'input->name+output' instead.
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/vm.scm56
1 files changed, 22 insertions, 34 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 9d8ad87b88..91b804d018 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -64,6 +64,26 @@
;;;
;;; Code:
+(define* (input->name+output tuple #:key (system (%current-system)))
+ "Return as a monadic value a name/file-name pair corresponding to TUPLE, an
+input tuple. The output file name is when building for SYSTEM."
+ (with-monad %store-monad
+ (match tuple
+ ((input (? package? package))
+ (mlet %store-monad ((out (package-file package #:system system)))
+ (return `(,input . ,out))))
+ ((input (? package? package) sub-drv)
+ (mlet %store-monad ((out (package-file package
+ #:output sub-drv
+ #:system system)))
+ (return `(,input . ,out))))
+ ((input (? derivation? drv))
+ (return `(,input . ,(derivation->output-path drv))))
+ ((input (? derivation? drv) sub-drv)
+ (return `(,input . ,(derivation->output-path drv sub-drv))))
+ ((input (and (? string?) (? store-path?) file))
+ (return `(,input . ,file))))))
+
(define* (expression->derivation-in-linux-vm name exp
#:key
(system (%current-system))
@@ -97,23 +117,7 @@ made available under the /xchg CIFS share."
;; `build-expression->derivation'.
(define input-alist
- (with-monad %store-monad
- (map (match-lambda
- ((input (? package? package))
- (mlet %store-monad ((out (package-file package #:system system)))
- (return `(,input . ,out))))
- ((input (? package? package) sub-drv)
- (mlet %store-monad ((out (package-file package
- #:output sub-drv
- #:system system)))
- (return `(,input . ,out))))
- ((input (? derivation? drv))
- (return `(,input . ,(derivation->output-path drv))))
- ((input (? derivation? drv) sub-drv)
- (return `(,input . ,(derivation->output-path drv sub-drv))))
- ((input (and (? string?) (? store-path?) file))
- (return `(,input . ,file))))
- inputs)))
+ (map input->name+output inputs))
(define builder
;; Code that launches the VM that evaluates EXP.
@@ -192,25 +196,9 @@ POPULATE is a list of directives stating directories or symlinks to be created
in the disk image partition. It is evaluated once the image has been
populated with INPUTS-TO-COPY. It can be used to provide additional files,
such as /etc files."
- (define (input->name+derivation tuple)
- (with-monad %store-monad
- (match tuple
- ((name (? package? package))
- (mlet %store-monad ((drv (package->derivation package system)))
- (return `(,name . ,(derivation->output-path drv)))))
- ((name (? package? package) sub-drv)
- (mlet %store-monad ((drv (package->derivation package system)))
- (return `(,name . ,(derivation->output-path drv sub-drv)))))
- ((name (? derivation? drv))
- (return `(,name . ,(derivation->output-path drv))))
- ((name (? derivation? drv) sub-drv)
- (return `(,name . ,(derivation->output-path drv sub-drv))))
- ((input (and (? string?) (? store-path?) file))
- (return `(,input . ,file))))))
-
(mlet %store-monad
((graph (sequence %store-monad
- (map input->name+derivation inputs-to-copy))))
+ (map input->name+output inputs-to-copy))))
(expression->derivation-in-linux-vm
"qemu-image"
`(let ()