nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ui: Report profile hooks separately. 

* 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.
master
Ricardo Wurmus 2018-12-19 14:36:29 +01:00 committed by Ricardo Wurmus
parent 0485717ee9
commit 80eebee9f7
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
3 changed files with 114 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
guix/profiles.scm
View File

@ -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 by

33
guix/status.scm
View File

@ -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,31 @@ 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
(G_ "building directory of Info manuals..."))
('ghc-package-cache
(G_ "building GHC package cache..."))
('ca-certificate-bundle
(G_ "building CA certificate bundle..."))
('glib-schemas
(G_ "generating GLib schema cache..."))
('gtk-icon-themes
(G_ "creating GTK+ icon theme cache..."))
('gtk-im-modules
(G_ "building cache files for GTK+ input methods..."))
('xdg-desktop-database
(G_ "building XDG desktop file cache..."))
('xdg-mime-database
(G_ "building XDG MIME database..."))
('fonts-dir
(G_ "building fonts directory..."))
('manual-database
(G_ "building database for manual pages..."))
(_ #f)))
(define* (print-build-event event old-status status
#:optional (port (current-error-port))
#:key
@ -336,6 +362,13 @@ addition to build events."
"applying ~a grafts for ~a..."
count))
count drv)))
('profile-hook
(let ((hook-type (assq-ref properties 'hook)))
(or (and=> (hook-message hook-type)
(lambda (msg)
(format port (info msg))))
(format port (info (G_ "running profile hook of type '~a'..."))
hook-type))))
(_
(format port (info (G_ "building ~a...")) drv))))
(newline port))

46
guix/ui.scm
View File

@ -829,6 +829,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)))
@ -879,10 +885,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)))
@ -920,7 +944,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~%~}~;~]"
@ -945,7 +974,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)