TakeV/guix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

scripts: Add 'build-package'.

Browse source 
* guix/scripts/system.scm (maybe-build): Move to ...
* guix/scripts.scm: ...here.
  (build-package): New procedure.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Alex Kost 2015-07-23 16:16:41 +03:00
parent f80a7a6c58
commit 430505eba3
2 changed files with 38 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
guix/scripts.scm
View file

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -20,11 +21,17 @@
(define-module (guix scripts) (define-module (guix scripts)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (args-fold* #:export (args-fold*
parse-command-line)) parse-command-line
maybe-build
build-package))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -78,4 +85,34 @@ (define (parse-options-from args seeds)
;; ARGS take precedence over what the environment variable specifies. ;; ARGS take precedence over what the environment variable specifies.
(parse-options-from args seeds)))) (parse-options-from args seeds))))
(define* (maybe-build drvs
#:key dry-run? use-substitutes?)
"Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
true."
(with-monad %store-monad
(>>= (show-what-to-build* drvs
#:dry-run? dry-run?
#:use-substitutes? use-substitutes?)
(lambda (_)
(if dry-run?
(return #f)
(built-derivations drvs))))))
(define* (build-package package
#:key dry-run? (use-substitutes? #t)
#:allow-other-keys
#:rest build-options)
"Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
Show what and how will/would be built."
(mbegin %store-monad
(apply set-build-options*
#:use-substitutes? use-substitutes?
(strip-keyword-arguments '(#:dry-run?) build-options))
(mlet %store-monad ((derivation (package->derivation package)))
(mbegin %store-monad
(maybe-build (list derivation)
#:use-substitutes? use-substitutes?
#:dry-run? dry-run?)
(return (show-derivation-outputs derivation))))))
;;; scripts.scm ends here ;;; scripts.scm ends here

13
guix/scripts/system.scm
View file

@ -299,19 +299,6 @@ (define* (system-derivation-for-action os action
((disk-image) ((disk-image)
(system-disk-image os #:disk-image-size image-size)))) (system-disk-image os #:disk-image-size image-size))))
(define* (maybe-build drvs
#:key dry-run? use-substitutes?)
"Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
true."
(with-monad %store-monad
(>>= (show-what-to-build* drvs
#:dry-run? dry-run?
#:use-substitutes? use-substitutes?)
(lambda (_)
(if dry-run?
(return #f)
(built-derivations drvs))))))
(define* (perform-action action os (define* (perform-action action os
#:key grub? dry-run? #:key grub? dry-run?
use-substitutes? device target use-substitutes? device target