[bug#34020] [PATCH 1/2] status: Add 'with-status-verbosity'.

[Ludovic Courtès]

* guix/status.scm (logger-for-level, call-with-status-verbosity): New
procedures.
(with-status-verbosity): New macro.
* guix/scripts/environment.scm (guix-environment): Use
'with-status-verbosity' instead of 'with-status-report'.
* guix/scripts/pack.scm (guix-pack): Likewise.
* guix/scripts/package.scm (guix-package): Likewise.
* guix/scripts/pull.scm (guix-pull): Likewise.
* guix/scripts/system.scm (guix-system): Likewise.
* build-aux/run-system-tests.scm (run-system-tests): Likewise.
---
 .dir-locals.el                 |  1 +
 build-aux/run-system-tests.scm |  4 ++--
 guix/scripts/environment.scm   |  4 ++--
 guix/scripts/pack.scm          |  4 ++--
 guix/scripts/package.scm       |  4 ++--
 guix/scripts/pull.scm          |  2 +-
 guix/scripts/system.scm        |  7 +++----
 guix/status.scm                | 17 ++++++++++++++++-
 8 files changed, 29 insertions(+), 14 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 1a3a05f100..593c767d2b 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -61,6 +61,7 @@
    (eval . (put 'with-derivation-narinfo 'scheme-indent-function 1))
    (eval . (put 'with-derivation-substitute 'scheme-indent-function 2))
    (eval . (put 'with-status-report 'scheme-indent-function 1))
+   (eval . (put 'with-status-verbosity 'scheme-indent-function 1))
 
    (eval . (put 'mlambda 'scheme-indent-function 1))
    (eval . (put 'mlambdaq 'scheme-indent-function 1))
diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm
index 953ba3e221..bcd7547704 100644
--- a/build-aux/run-system-tests.scm
+++ b/build-aux/run-system-tests.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016, 2018, 2019 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -64,7 +64,7 @@
           (length tests))
 
   (with-store store
-    (with-status-report print-build-event
+    (with-status-verbosity 2
       (run-with-store store
         (mlet* %store-monad ((drv (mapm %store-monad system-test-value tests))
                              (out -> (map derivation->output-path drv)))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 86e1eb115f..9461d04976 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2018 David Thompson <address@hidden>
-;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2018 Mike Gerwitz <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -674,7 +674,7 @@ message if any test fails."
         (leave (G_ "'--user' cannot be used without '--container'~%")))
 
       (with-store store
-        (with-status-report print-build-event
+        (with-status-verbosity 1
           (define manifest
             (options/resolve-packages store opts))
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 98b06971bd..173bdd1ef1 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2017, 2018 Ricardo Wurmus <address@hidden>
 ;;; Copyright © 2018 Konrad Hinsen <address@hidden>
 ;;; Copyright © 2018 Chris Marusich <address@hidden>
@@ -774,7 +774,7 @@ Create a bundle of PACKAGE.\n"))
 
   (with-error-handling
     (with-store store
-      (with-status-report print-build-event
+      (with-status-verbosity 2
         ;; Set the build options before we do anything else.
         (set-build-options-from-command-line store opts)
 
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5743816324..876787fbe2 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;; Copyright © 2013, 2015 Mark H Weaver <address@hidden>
 ;;; Copyright © 2014, 2016 Alex Kost <address@hidden>
@@ -914,7 +914,7 @@ processed, #f otherwise."
     (or (process-query opts)
         (parameterize ((%store  (open-connection))
                        (%graft? (assoc-ref opts 'graft?)))
-          (with-status-report print-build-event/quiet
+          (with-status-verbosity 1
             (set-build-options-from-command-line (%store) opts)
             (parameterize ((%guile-for-build
                             (package-derivation
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index e7ff44c0d5..6389d5ec09 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -510,7 +510,7 @@ Use '~/.config/guix/channels.scm' instead."))
               (process-query opts profile))
              (else
               (with-store store
-                (with-status-report print-build-event
+                (with-status-verbosity 2
                   (parameterize ((%current-system (assoc-ref opts 'system))
                                  (%graft? (assoc-ref opts 'graft?))
                                  (%repository-cache-directory cache))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 6cda3ccbd6..9e31baaddb 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2016 Alex Kost <address@hidden>
 ;;; Copyright © 2016, 2017, 2018 Chris Marusich <address@hidden>
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
@@ -1267,9 +1267,8 @@ argument list and OPTS is the option alist."
            (args     (option-arguments opts))
            (command  (assoc-ref opts 'action)))
       (parameterize ((%graft? (assoc-ref opts 'graft?)))
-        (with-status-report (if (memq command '(init reconfigure))
-                                print-build-event/quiet
-                                print-build-event)
+        (with-status-verbosity (if (memq command '(init reconfigure))
+                                   1 2)
           (process-command command args opts))))))
 
 ;;; Local Variables:
diff --git a/guix/status.scm b/guix/status.scm
index d4fc4ca16e..ddbf461739 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -63,7 +63,8 @@
             print-build-event/quiet
             print-build-status
 
-            with-status-report))
+            with-status-report
+            with-status-verbosity))
 
 ;;; Commentary:
 ;;;
@@ -651,3 +652,17 @@ The second return value is a thunk to retrieve the current 
state."
   "Set up build status reporting to the user using the ON-EVENT procedure;
 evaluate EXP... in that context."
   (call-with-status-report on-event (lambda () exp ...)))
+
+(define (logger-for-level level)
+  "Return the logging procedure that corresponds to LEVEL."
+  (cond ((<= level 0) (const #t))
+        ((= level 1)  print-build-event/quiet)
+        (else         print-build-event)))
+
+(define (call-with-status-verbosity level thunk)
+  (call-with-status-report (logger-for-level level) thunk))
+
+(define-syntax-rule (with-status-verbosity level exp ...)
+  "Set up build status reporting to the user at the given LEVEL: 0 means
+silent, 1 means quiet, 2 means verbose.  Evaluate EXP... in that context."
+  (call-with-status-verbosity level (lambda () exp ...)))
-- 
2.20.1