04/04: scripts: Add 'build-package'.

[Alex Kost]

alezost pushed a commit to branch master
in repository guix.

commit 430505eba33b7bb59fa2d22e0f21ff317cbc320d
Author: Alex Kost <address@hidden>
Date:   Thu Jul 23 16:16:41 2015 +0300

    scripts: Add 'build-package'.
    
    * guix/scripts/system.scm (maybe-build): Move to ...
    * guix/scripts.scm: ...here.
      (build-package): New procedure.
    
    Co-authored-by: Ludovic Courtès <address@hidden>
---
 guix/scripts.scm        |   39 ++++++++++++++++++++++++++++++++++++++-
 guix/scripts/system.scm |   13 -------------
 2 files changed, 38 insertions(+), 14 deletions(-)

diff --git a/guix/scripts.scm b/guix/scripts.scm
index 6bb3e21..e34d389 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2014 Deck Pickard <address@hidden>
+;;; Copyright © 2015 Alex Kost <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,11 +21,17 @@
 (define-module (guix scripts)
   #:use-module (guix utils)
   #: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-37)
   #:use-module (ice-9 match)
   #:export (args-fold*
-            parse-command-line))
+            parse-command-line
+            maybe-build
+            build-package))
 
 ;;; Commentary:
 ;;;
@@ -78,4 +85,34 @@ parameter of 'args-fold'."
       ;; ARGS take precedence over what the environment variable specifies.
       (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
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 32d4057..5e2d226 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -299,19 +299,6 @@ it atomically, and then run OS's activation script."
     ((disk-image)
      (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
                          #:key grub? dry-run?
                          use-substitutes? device target