From 7804c45b9ce5a8edd06452d828249e588ae26263 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 9 Jan 2019 11:25:11 +0100 Subject: [PATCH] status: Add 'with-status-verbosity'. * 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 | 2 +- guix/scripts/package.scm | 4 ++-- guix/scripts/pull.scm | 2 +- guix/scripts/system.scm | 7 +++---- guix/status.scm | 17 ++++++++++++++++- 8 files changed, 28 insertions(+), 13 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 +;;; Copyright © 2016, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -64,7 +64,7 @@ (define tests (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 -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Mike Gerwitz ;;; ;;; This file is part of GNU Guix. @@ -674,7 +674,7 @@ (define (guix-environment . args) (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 e137fb136a..d9e0050159 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -772,7 +772,7 @@ (define (manifest-from-args store opts) (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 +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2013, 2015 Mark H Weaver ;;; Copyright © 2014, 2016 Alex Kost @@ -914,7 +914,7 @@ (define verbose? (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 @@ (define (guix-pull . args) (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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe @@ -1267,9 +1267,8 @@ (define (fail) (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 1a7cb313ea..2928733257 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -63,7 +63,8 @@ (define-module (guix status) print-build-event/quiet print-build-status - with-status-report)) + with-status-report + with-status-verbosity)) ;;; Commentary: ;;; @@ -649,3 +650,17 @@ (define-syntax-rule (with-status-report on-event exp ...) "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 ...)))