>From 94065c2b415b0b52a5617d381e1b7fac19ee9f45 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=E5=AE=8B=E6=96=87=E6=AD=A6?= <address@hidden>
Date: Sat, 9 May 2015 12:45:39 +0800
Subject: [PATCH] profiles: Add 'hicolor' and 'HighContrast' icon theme hooks.

* guix/profiles.scm (gtk-icon-theme-hook): New function.
  (%default-profile-hooks): Add `(gtk-icon-theme-hook "hicolor")' and
  `(gtk-icon-theme-hook "HighContrast")'.
---
 guix/profiles.scm | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 68 insertions(+), 1 deletion(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 11d9bf0..08f05a6 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;; Copyright © 2014 Alex Kost <address@hidden>
 ;;; Copyright © 2015 Mark H Weaver <address@hidden>
+;;; Copyright © 2015 Sou Bunnbu <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -573,12 +574,78 @@ MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
                     #:modules '((guix build utils))
                     #:local-build? #t))
 
+(define (gtk-icon-theme-hook name)
+  "Return a profile hook that unions all NAME icons from manifest entries and
+rebuilds the 'icon-theme.cache' file for the NAME icon theme."
+
+  (define (entry-lookup-gtk+ store entry)
+    "Return the GTK+ package or store path referenced by the manifest ENTRY, or
+#f if not referenced."
+    ;; Find GTK+ in a list of packages.
+    (define (by-packages packages)
+      (find (lambda (package)
+              (equal? "gtk+" (package-name package)))
+            packages))
+
+    ;; Find GTK+ in a list of store paths.
+    (define (by-paths paths)
+      (find (lambda (path)
+              (equal? "gtk+"
+                      (package-name->name+version
+                       (store-path-package-name path))))
+            paths))
+
+    (match (manifest-entry-item entry)
+      ((? package? package)
+       (by-packages (delete-duplicates
+                     (map cadr (package-transitive-inputs package)))))
+      ((? string? path)
+       (by-paths (references store path)))))
+
+  (define (manifest-lookup-gtk+ store manifest)
+    "Return the first GTK+ package or store path referenced by MANIFEST entries,
+or #f if not referenced by any entry."
+    (any (cut entry-lookup-gtk+ store <>) (manifest-entries manifest)))
+
+  (lambda (manifest)
+    (define gtk+
+      (with-store store
+        (manifest-lookup-gtk+ store manifest)))
+
+    (define build
+      #~(begin
+          (use-modules (guix build utils)
+                       (guix build union))
+          (let* ((icon-dir (lambda (base)
+                             (string-append base "/share/icons/" #$name)))
+                 (destdir  (icon-dir #$output))
+                 (icons    (filter
+                            file-exists?
+                            (map icon-dir '#$(manifest-inputs manifest))))
+                 (update-icon-cache (string-append
+                                     #+gtk+ "/bin/gtk-update-icon-cache")))
+            (mkdir-p (string-append #$output "/share/icons"))
+            ;; Unions all the icons and update the 'icon-theme.cache'.
+            (union-build destdir icons)
+            (system* update-icon-cache "-t" destdir))))
+
+    ;; Don't run the hook when there's nothing to do.
+    (if gtk+
+        (gexp->derivation (string-append (string-downcase name) "-icon-theme")
+                          build
+                          #:modules '((guix build utils)
+                                      (guix build union))
+                          #:local-build? #t)
+        #f)))
+
 (define %default-profile-hooks
   ;; This is the list of derivation-returning procedures that are called by
   ;; default when making a non-empty profile.
   (list info-dir-file
         ghc-package-cache-file
-        ca-certificate-bundle))
+        ca-certificate-bundle
+        (gtk-icon-theme-hook "hicolor")
+        (gtk-icon-theme-hook "HighContrast")))
 
 (define* (profile-derivation manifest
                              #:key
-- 
2.2.1