08/08: time-machine: Honor the standard build options.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 87e7faa2ae641d8302efc8b90f1e45f43f67f6da
Author: Ludovic Courtès <address@hidden>
Date:   Fri Nov 15 21:48:35 2019 +0100

    time-machine: Honor the standard build options.
    
    * guix/scripts/time-machine.scm (show-help): Call 'show-build-options-help'.
    (%options): Add %STANDARD-BUILD-OPTIONS.
    (%default-options): New variable.
    (parse-args): Pass (list %default-options) to 'parse-command-line' and
    remove #:build-options? parameter.
    (guix-time-machine): Call 'set-build-options-from-command-line' and wrap
    'cached-channel-instance' call in 'with-status-verbosity'.
    * doc/guix.texi (Invoking guix time-machine): Mention common build options.
---
 doc/guix.texi                 |  4 ++++
 guix/scripts/time-machine.scm | 55 +++++++++++++++++++++++++++++++++----------
 2 files changed, 46 insertions(+), 13 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index bc1d5d8..51147e3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4222,6 +4222,10 @@ will thus build the package @code{hello} as defined in 
the master branch,
 which is in general a newer revison of Guix than you have installed.
 Time travel works in both directions!
 
+Note that @command{guix time-machine} can trigger builds of channels and
+their dependencies, and these are controlled by the standard build
+options (@pxref{Common Build Options}).
+
 @node Inferiors
 @section Inferiors
 
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
index 946b523..19e6355 100644
--- a/guix/scripts/time-machine.scm
+++ b/guix/scripts/time-machine.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Konrad Hinsen <address@hidden>
+;;; Copyright © 2019 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,8 +23,15 @@
   #:use-module (guix inferior)
   #:use-module (guix channels)
   #:use-module (guix store)
+  #:use-module (guix status)
+  #:use-module ((guix utils)
+                #:select (%current-system))
   #:use-module ((guix scripts pull)
                 #:select (with-git-error-handling channel-list))
+  #:use-module ((guix scripts build)
+                #:select (%standard-build-options
+                          show-build-options-help
+                          set-build-options-from-command-line))
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -47,6 +55,9 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
       --commit=COMMIT    use the specified COMMIT"))
   (display (G_ "
       --branch=BRANCH    use the tip of the specified BRANCH"))
+  (newline)
+  (show-build-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
@@ -56,9 +67,9 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
 
 (define %options
   ;; Specifications of the command-line options.
-  (list (option '(#\C "channels") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'channel-file arg result)))
+  (cons* (option '(#\C "channels") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'channel-file arg result)))
          (option '("url") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'repository-url arg
@@ -69,20 +80,35 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
          (option '("branch") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'ref `(branch . ,arg) result)))
-        (option '(#\h "help") #f #f
-                (lambda args
-                  (show-help)
-                  (exit 0)))
-        (option '(#\V "version") #f #f
-                (lambda args
-                  (show-version-and-exit "guix time-machine")))))
+         (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix time-machine")))
+
+         %standard-build-options))
+
+(define %default-options
+  ;; Alist of default option values.
+  `((system . ,(%current-system))
+    (substitutes? . #t)
+    (build-hook? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
+    (multiplexed-build-output? . #t)
+    (graft? . #t)
+    (debug . 0)
+    (verbosity . 1)))
 
 (define (parse-args args)
   "Parse the list of command line arguments ARGS."
   ;; The '--' token is used to separate the command to run from the rest of
   ;; the operands.
   (let-values (((args command) (break (cut string=? "--" <>) args)))
-    (let ((opts (parse-command-line args %options '(()) #:build-options? #f)))
+    (let ((opts (parse-command-line args %options
+                                    (list %default-options))))
       (match command
         (() opts)
         (("--") opts)
@@ -100,7 +126,10 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
             (channels     (channel-list opts))
             (command-line (assoc-ref opts 'exec)))
        (when command-line
-         (let* ((directory  (with-store store
-                              (cached-channel-instance store channels)))
+         (let* ((directory
+                 (with-store store
+                   (with-status-verbosity (assoc-ref opts 'verbosity)
+                     (set-build-options-from-command-line store opts)
+                     (cached-channel-instance store channels))))
                 (executable (string-append directory "/bin/guix")))
            (apply execl (cons* executable executable command-line))))))))