[PATCH] ui: Report profile hooks separately.

DoneSubmitted by Ricardo Wurmus.
Details
2 participants
  • Ludovic Courtès
  • Ricardo Wurmus
Owner
unassigned
Severity
normal
R
R
Ricardo Wurmus wrote on 19 Dec 2018 13:56
(address . guix-patches@gnu.org)(name . Ricardo Wurmus)(address . ricardo.wurmus@mdc-berlin.de)
20181219125632.17532-1-ricardo.wurmus@mdc-berlin.de
* guix/ui.scm (profile-hook-derivation?): New procedure.(show-what-to-build): Distinguish among BUILD derivations that match'profile-hook-derivation?'. Report them separately.* guix/status.scm (print-build-event): Display profile hooks with readablehook name.* guix/profiles.scm (info-dir-file, ghc-package-cache-file,ca-certificate-bundle, glib-schemas, gtk-icon-themes, gtk-im-modules,xdg-desktop-database, xdg-mime-database, fonts-dir-file, manual-database):Augment derivation with "type" and "hook" properties.--- guix/profiles.scm | 52 +++++++++++++++++++++++++++++++++++++---------- guix/status.scm | 4 ++++ guix/ui.scm | 46 +++++++++++++++++++++++++++++++++++------ 3 files changed, 85 insertions(+), 17 deletions(-)
Toggle diff (234 lines)diff --git a/guix/profiles.scm b/guix/profiles.scmindex ba4446bc2..4739d28a9 100644--- a/guix/profiles.scm+++ b/guix/profiles.scm@@ -4,7 +4,7 @@ ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>-;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>+;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>@@ -788,7 +788,10 @@ MANIFEST." (gexp->derivation "info-dir" build #:local-build? #t- #:substitutable? #f))+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . "info manuals directory")))) (define (ghc-package-cache-file manifest) "Return a derivation that builds the GHC 'package.cache' file for all the@@ -842,7 +845,10 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (map manifest-entry-name (manifest-entries manifest))) (gexp->derivation "ghc-package-cache" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . "GHC package cache"))) (return #f)))) (define (ca-certificate-bundle manifest)@@ -910,7 +916,10 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." (gexp->derivation "ca-certificate-bundle" build #:local-build? #t- #:substitutable? #f))+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . "CA certificate bundle")))) (define (glib-schemas manifest) "Return a derivation that unions all schemas from manifest entries and@@ -960,7 +969,10 @@ creates the Glib 'gschemas.compiled' file." (if %glib (gexp->derivation "glib-schemas" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . "Glib schemas"))) (return #f)))) (define (gtk-icon-themes manifest)@@ -1016,7 +1028,10 @@ creates the GTK+ 'icon-theme.cache' file for each theme." (if %gtk+ (gexp->derivation "gtk-icon-themes" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . "GTK icon themes"))) (return #f)))) (define (gtk-im-modules manifest)@@ -1088,7 +1103,10 @@ for both major versions of GTK+." (if (or gtk+ gtk+-2) (gexp->derivation "gtk-im-modules" gexp #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . "GTK inputs method modules"))) (return #f))))) (define (xdg-desktop-database manifest)@@ -1126,7 +1144,10 @@ MIME type." (if glib (gexp->derivation "xdg-desktop-database" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . "XDG desktop database"))) (return #f)))) (define (xdg-mime-database manifest)@@ -1165,7 +1186,10 @@ entries. It's used to query the MIME type of a given file." (if glib (gexp->derivation "xdg-mime-database" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . "XDG MIME database"))) (return #f)))) ;; Several font packages may install font files into same directory, so@@ -1236,7 +1260,10 @@ files for the fonts of the @var{manifest} entries." (guix build union) (srfi srfi-26)) #:local-build? #t- #:substitutable? #f))+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . "fonts directory")))) (define (manual-database manifest) "Return a derivation that builds the manual page database (\"mandb\") for@@ -1306,7 +1333,10 @@ the entries in MANIFEST." ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>. #:env-vars `(("MALLOC_PERTURB_" . "1")) - #:local-build? #t))+ #:local-build? #t+ #:properties+ `((type . profile-hook)+ (hook . "manual page database")))) (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called bydiff --git a/guix/status.scm b/guix/status.scmindex 868bfdca2..070c1d132 100644--- a/guix/status.scm+++ b/guix/status.scm@@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;;@@ -336,6 +337,9 @@ addition to build events." "applying ~a grafts for ~a..." count)) count drv)))+ ('profile-hook+ (format port (info (G_ "building profile hook for ~a..."))+ (assq-ref properties 'hook))) (_ (format port (info (G_ "building ~a...")) drv)))) (newline port))diff --git a/guix/ui.scm b/guix/ui.scmindex 60636edac..bf70fc134 100644--- a/guix/ui.scm+++ b/guix/ui.scm@@ -822,6 +822,12 @@ warning." ('graft #t) (_ #f))) +(define (profile-hook-derivation? drv)+ "Return true if DRV is definitely a profile hook derivation, false otherwise."+ (match (assq-ref (derivation-properties drv) 'type)+ ('profile-hook #t)+ (_ #f)))+ (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t) (mode (build-mode normal)))@@ -872,10 +878,28 @@ report what is prerequisites are available for download." substitutable-references download)))) download))- ((graft build)- (partition (compose graft-derivation?- read-derivation-from-file)- build)))+ ((graft hook build)+ (match (fold (lambda (file acc)+ (let ((drv (read-derivation-from-file file)))+ (match acc+ ((#:graft graft #:hook hook #:build build)+ (cond+ ((graft-derivation? drv)+ `(#:graft ,(cons file graft)+ #:hook ,hook+ #:build ,build))+ ((profile-hook-derivation? drv)+ `(#:graft ,graft+ #:hook ,(cons file hook)+ #:build ,build))+ (else+ `(#:graft ,graft+ #:hook ,hook+ #:build ,(cons file build))))))))+ '(#:graft () #:hook () #:build ())+ build)+ ((#:graft graft #:hook hook #:build build)+ (values graft hook build))))) (define installed-size (reduce + 0 (map substitutable-nar-size download))) @@ -913,7 +937,12 @@ report what is prerequisites are available for download." (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" (length graft))- (null? graft) graft))+ (null? graft) graft)+ (format (current-error-port)+ (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]"+ "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]"+ (length hook))+ (null? hook) hook)) (begin (format (current-error-port) (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]"@@ -938,7 +967,12 @@ report what is prerequisites are available for download." (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" (length graft))- (null? graft) graft)))+ (null? graft) graft)+ (format (current-error-port)+ (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]"+ "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]"+ (length hook))+ (null? hook) hook))) (check-available-space installed-size) -- 2.19.1
R
R
Ricardo Wurmus wrote on 19 Dec 2018 14:36
[PATCH v2] ui: Report profile hooks separately.
(address . 33802@debbugs.gnu.org)(name . Ricardo Wurmus)(address . ricardo.wurmus@mdc-berlin.de)
20181219133629.472-1-ricardo.wurmus@mdc-berlin.de
* guix/ui.scm (profile-hook-derivation?): New procedure.(show-what-to-build): Distinguish among BUILD derivations that match'profile-hook-derivation?'. Report them separately.* guix/status.scm (hook-message): New procedure.(print-build-event): Display profile hooks with readable hook name.* guix/profiles.scm (info-dir-file, ghc-package-cache-file,ca-certificate-bundle, glib-schemas, gtk-icon-themes, gtk-im-modules,xdg-desktop-database, xdg-mime-database, fonts-dir-file, manual-database):Augment derivation with "type" and "hook" properties.--- guix/profiles.scm | 52 +++++++++++++++++++++++++++++++++++++---------- guix/status.scm | 29 ++++++++++++++++++++++++++ guix/ui.scm | 46 +++++++++++++++++++++++++++++++++++------ 3 files changed, 110 insertions(+), 17 deletions(-)
Toggle diff (266 lines)diff --git a/guix/profiles.scm b/guix/profiles.scmindex ba4446bc2..6d5da0ac4 100644--- a/guix/profiles.scm+++ b/guix/profiles.scm@@ -4,7 +4,7 @@ ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>-;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>+;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>@@ -788,7 +788,10 @@ MANIFEST." (gexp->derivation "info-dir" build #:local-build? #t- #:substitutable? #f))+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . info-dir)))) (define (ghc-package-cache-file manifest) "Return a derivation that builds the GHC 'package.cache' file for all the@@ -842,7 +845,10 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (map manifest-entry-name (manifest-entries manifest))) (gexp->derivation "ghc-package-cache" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . ghc-package-cache))) (return #f)))) (define (ca-certificate-bundle manifest)@@ -910,7 +916,10 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." (gexp->derivation "ca-certificate-bundle" build #:local-build? #t- #:substitutable? #f))+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . ca-certificate-bundle)))) (define (glib-schemas manifest) "Return a derivation that unions all schemas from manifest entries and@@ -960,7 +969,10 @@ creates the Glib 'gschemas.compiled' file." (if %glib (gexp->derivation "glib-schemas" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . glib-schemas))) (return #f)))) (define (gtk-icon-themes manifest)@@ -1016,7 +1028,10 @@ creates the GTK+ 'icon-theme.cache' file for each theme." (if %gtk+ (gexp->derivation "gtk-icon-themes" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . gtk-icon-themes))) (return #f)))) (define (gtk-im-modules manifest)@@ -1088,7 +1103,10 @@ for both major versions of GTK+." (if (or gtk+ gtk+-2) (gexp->derivation "gtk-im-modules" gexp #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . gtk-im-modules))) (return #f))))) (define (xdg-desktop-database manifest)@@ -1126,7 +1144,10 @@ MIME type." (if glib (gexp->derivation "xdg-desktop-database" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . xdg-desktop-database))) (return #f)))) (define (xdg-mime-database manifest)@@ -1165,7 +1186,10 @@ entries. It's used to query the MIME type of a given file." (if glib (gexp->derivation "xdg-mime-database" build #:local-build? #t- #:substitutable? #f)+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . xdg-mime-database))) (return #f)))) ;; Several font packages may install font files into same directory, so@@ -1236,7 +1260,10 @@ files for the fonts of the @var{manifest} entries." (guix build union) (srfi srfi-26)) #:local-build? #t- #:substitutable? #f))+ #:substitutable? #f+ #:properties+ `((type . profile-hook)+ (hook . fonts-dir)))) (define (manual-database manifest) "Return a derivation that builds the manual page database (\"mandb\") for@@ -1306,7 +1333,10 @@ the entries in MANIFEST." ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>. #:env-vars `(("MALLOC_PERTURB_" . "1")) - #:local-build? #t))+ #:local-build? #t+ #:properties+ `((type . profile-hook)+ (hook . manual-database)))) (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called bydiff --git a/guix/status.scm b/guix/status.scmindex 868bfdca2..220f2076b 100644--- a/guix/status.scm+++ b/guix/status.scm@@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;;@@ -289,6 +290,32 @@ on." ("^(.*)(warning)([[:blank:]]*)(:)(.*)" RESET MAGENTA BOLD BOLD BOLD))) +(define (hook-message hook-type)+ "Return a human-readable string for the profile hook type HOOK-TYPE."+ (match hook-type+ ('info-dir+ "building directory of Info manuals...")+ ('ghc-package-cache+ "building GHC package cache...")+ ('ca-certificate-bundle+ "building CA certificate bundle...")+ ('glib-schemas+ "generating Glib schema cache...")+ ('gtk-icon-themes+ "creating GTK+ icon theme cache...")+ ('gtk-im-modules+ "building cache files for GTK+ input methods...")+ ('xdg-desktop-database+ "building XDG desktop file cache...")+ ('xdg-mime-database+ "building XDG MIME database...")+ ('fonts-dir+ "building fonts directory...")+ ('manual-database+ "building database for manual pages...")+ (_+ (format #f "running profile hook of type '~a'...~%" hook-type))))+ (define* (print-build-event event old-status status #:optional (port (current-error-port)) #:key@@ -336,6 +363,8 @@ addition to build events." "applying ~a grafts for ~a..." count)) count drv)))+ ('profile-hook+ (format port (info (G_ (hook-message (assq-ref properties 'hook)))))) (_ (format port (info (G_ "building ~a...")) drv)))) (newline port))diff --git a/guix/ui.scm b/guix/ui.scmindex 60636edac..bf70fc134 100644--- a/guix/ui.scm+++ b/guix/ui.scm@@ -822,6 +822,12 @@ warning." ('graft #t) (_ #f))) +(define (profile-hook-derivation? drv)+ "Return true if DRV is definitely a profile hook derivation, false otherwise."+ (match (assq-ref (derivation-properties drv) 'type)+ ('profile-hook #t)+ (_ #f)))+ (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t) (mode (build-mode normal)))@@ -872,10 +878,28 @@ report what is prerequisites are available for download." substitutable-references download)))) download))- ((graft build)- (partition (compose graft-derivation?- read-derivation-from-file)- build)))+ ((graft hook build)+ (match (fold (lambda (file acc)+ (let ((drv (read-derivation-from-file file)))+ (match acc+ ((#:graft graft #:hook hook #:build build)+ (cond+ ((graft-derivation? drv)+ `(#:graft ,(cons file graft)+ #:hook ,hook+ #:build ,build))+ ((profile-hook-derivation? drv)+ `(#:graft ,graft+ #:hook ,(cons file hook)+ #:build ,build))+ (else+ `(#:graft ,graft+ #:hook ,hook+ #:build ,(cons file build))))))))+ '(#:graft () #:hook () #:build ())+ build)+ ((#:graft graft #:hook hook #:build build)+ (values graft hook build))))) (define installed-size (reduce + 0 (map substitutable-nar-size download))) @@ -913,7 +937,12 @@ report what is prerequisites are available for download." (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" (length graft))- (null? graft) graft))+ (null? graft) graft)+ (format (current-error-port)+ (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]"+ "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]"+ (length hook))+ (null? hook) hook)) (begin (format (current-error-port) (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]"@@ -938,7 +967,12 @@ report what is prerequisites are available for download." (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" (length graft))- (null? graft) graft)))+ (null? graft) graft)+ (format (current-error-port)+ (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]"+ "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]"+ (length hook))+ (null? hook) hook))) (check-available-space installed-size) -- 2.19.1
L
L
Ludovic Courtès wrote on 19 Dec 2018 22:51
(name . Ricardo Wurmus)(address . ricardo.wurmus@mdc-berlin.de)(address . 33802@debbugs.gnu.org)
875zvptcc4.fsf@gnu.org
Hi!
Ricardo Wurmus <ricardo.wurmus@mdc-berlin.de> skribis:
Toggle quote (10 lines)> * guix/ui.scm (profile-hook-derivation?): New procedure.> (show-what-to-build): Distinguish among BUILD derivations that match> 'profile-hook-derivation?'. Report them separately.> * guix/status.scm (hook-message): New procedure.> (print-build-event): Display profile hooks with readable hook name.> * guix/profiles.scm (info-dir-file, ghc-package-cache-file,> ca-certificate-bundle, glib-schemas, gtk-icon-themes, gtk-im-modules,> xdg-desktop-database, xdg-mime-database, fonts-dir-file, manual-database):> Augment derivation with "type" and "hook" properties.
Really cool!
Toggle quote (12 lines)> +(define (hook-message hook-type)> + "Return a human-readable string for the profile hook type HOOK-TYPE."> + (match hook-type> + ('info-dir> + "building directory of Info manuals...")> + ('ghc-package-cache> + "building GHC package cache...")> + ('ca-certificate-bundle> + "building CA certificate bundle...")> + ('glib-schemas> + "generating Glib schema cache...")
s/Glib/GLib/ :-)
Toggle quote (15 lines)> + ('gtk-icon-themes> + "creating GTK+ icon theme cache...")> + ('gtk-im-modules> + "building cache files for GTK+ input methods...")> + ('xdg-desktop-database> + "building XDG desktop file cache...")> + ('xdg-mime-database> + "building XDG MIME database...")> + ('fonts-dir> + "building fonts directory...")> + ('manual-database> + "building database for manual pages...")> + (_> + (format #f "running profile hook of type '~a'...~%" hook-type))))
You need to wrap each of these strings in (G_ …), so that xgettext willfind them, and…
Toggle quote (9 lines)> (define* (print-build-event event old-status status> #:optional (port (current-error-port))> #:key> @@ -336,6 +363,8 @@ addition to build events."> "applying ~a grafts for ~a..."> count))> count drv)))> + ('profile-hook> + (format port (info (G_ (hook-message (assq-ref properties 'hook))))))
^… remove the ‘G_’ call from here.
Thanks!
Ludo’.
R
R
Ricardo Wurmus wrote on 19 Dec 2018 23:46
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 33802-done@debbugs.gnu.org)
87va3prv6k.fsf@mdc-berlin.de
Thanks for the review! I pushed a modified version with commit80eebee9f.
--Ricardo
Closed
?
Your comment

This issue is archived.

To comment on this conversation send email to 33802@debbugs.gnu.org