all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
* [PATCH] profiles: Add gtk-icon-themes hook.
@ 2015-05-13  9:12 宋文武
  2015-05-21 16:33 ` Ludovic Courtès
  0 siblings, 1 reply; 8+ messages in thread
From: 宋文武 @ 2015-05-13  9:12 UTC (permalink / raw)
  To: guix-devel

* guix/profiles.scm (gtk-icon-themes): New function.
  (%default-profile-hooks): Add it.
---
 guix/profiles.scm | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 78 insertions(+), 1 deletion(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 11d9bf0..33cdb28 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -573,12 +574,88 @@ MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
                     #:modules '((guix build utils))
                     #:local-build? #t))
 
+(define (gtk-icon-themes manifest)
+  "Return a derivation that unions all icon themes from manifest entries and
+creates the GTK+ 'icon-theme.cache' file for each 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)))
+
+  (define gtk+
+    (with-store store
+      (manifest-lookup-gtk+ store manifest)))
+
+  (define build
+    #~(begin
+        (use-modules (guix build utils)
+                     (guix build union)
+                     (srfi srfi-26)
+                     (ice-9 ftw))
+        (let* ((destdir  (string-append #$output "/share/icons"))
+               (icons    (filter file-exists?
+                                 (map (cut string-append <> "/share/icons")
+                                      '#$(manifest-inputs manifest))))
+               (update-icon-cache (string-append
+                                   #+gtk+ "/bin/gtk-update-icon-cache")))
+
+          ;; XXX: Should move to (guix build utils).
+          (define ensure-writable-directory
+            (@@ (guix build profiles) ensure-writable-directory))
+
+          ;; Union all the icons.
+          (mkdir-p (string-append #$output "/share"))
+          (union-build destdir icons)
+          ;; Update the 'icon-theme.cache' file for each icon theme.
+          (for-each
+           (lambda (theme)
+             (let ((dir (string-append #$output "/share/icons/" theme)))
+               (ensure-writable-directory dir)
+               (system* update-icon-cache "-t" dir)))
+           (scandir destdir (negate (cut member <> '("." ".."))))))))
+
+  ;; Don't run the hook when there's nothing to do.
+  (if gtk+
+      (gexp->derivation "gtk-icon-themes" build
+                        #:modules '((guix build utils)
+                                    (guix build union)
+                                    (guix build profiles)
+                                    (guix search-paths)
+                                    (guix records))
+                        #: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-themes))
 
 (define* (profile-derivation manifest
                              #:key
-- 
2.2.1

^ permalink raw reply related	[flat|nested] 8+ messages in thread

end of thread, other threads:[~2015-05-28 12:42 UTC | newest]

Thread overview: 8+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2015-05-13  9:12 [PATCH] profiles: Add gtk-icon-themes hook 宋文武
2015-05-21 16:33 ` Ludovic Courtès
2015-05-22  6:43   ` 宋文武
2015-05-27  7:50     ` Ludovic Courtès
2015-05-27 13:11       ` 宋文武
2015-05-27 15:25         ` Ludovic Courtès
2015-05-28  3:25         ` Mark H Weaver
2015-05-28 12:42           ` Ludovic Courtès

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.