From 80eebee9f7578ed096fed4cb6adfcbae3cfefc58 Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <ricardo.wurmus@mdc-berlin.de>
Date: Wed, 19 Dec 2018 14:36:29 +0100
Subject: 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.
---
 guix/ui.scm | 46 ++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 40 insertions(+), 6 deletions(-)

(limited to 'guix/ui.scm')

diff --git a/guix/ui.scm b/guix/ui.scm
index 148c181039..44336ee8fd 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -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)
 
-- 
cgit v1.2.3