ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

vm: Factorize input conversion.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2014-04-11 13:48:55 +02:00
parent e1a87b904a
commit ef09fdfb67
1 changed files with 22 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

56
gnu/system/vm.scm
View file

@ -64,6 +64,26 @@ (define-module (gnu system vm)
;;;
;;; 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 @@ (define* (expression->derivation-in-linux-vm name exp
;; `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 @@ (define* (qemu-image #:key
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 ()