Re: [PATCH] profiles: Add gtk-icon-themes hook.

[宋文武 <iyzsong@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 3118 bytes --]

Ludovic Courtès <ludo@gnu.org> writes:

> 宋文武 <iyzsong@gmail.com> skribis:
>
>> * guix/profiles.scm (gtk-icon-themes): New function.
>>   (%default-profile-hooks): Add it.
>
> [...]
>
>> +(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."
>
> Please use a comment rather than a docstring for inner defines.
OK.
>
>> +    ;; 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)))))
>
> This procedure must be turned into a monadic procedure along these
> lines (note: by-packages -> find-among-packages, and by-paths ->
> find-among-store-items):
>
>   (define (lookup-gtk+ entry)
>     (define (find-among-packages ...) ...)
>     (define (find-among-store-items ...) ...)
>
>     (with-monad %store-monad
>       (match (manifest-entry-item entry)
>         ((? package? package)
>          (match (package-transitive-inputs package)
>            (((labels packages . _) ...)
>             (return (find-among-packages packages)))))
>         ((? string? item)
>          (mlet %store-monad ((refs (references* item)))
>            (return (find-among-store-items refs)))))))
>
DONE.
>> +  (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)))
>
> This becomes:
>
>   (anym %store-monad
>         (cut entry-lookup-gtk+ store <>)
>         (manifest-entries manifest))
This doesn't work, 'anym' need a list of monadic values, I endup with:

  (anym %store-monad
        (lambda (x) x) ; any better idea?
        (map entry-lookup-gtk+ (manifest-entries manifest)))
>
>> +  (define gtk+
>> +    (with-store store
>> +      (manifest-lookup-gtk+ store manifest)))
>
> Opening an extra connection like this is Very Bad.  ;-)
> This is addressed by the above.
>
> So this becomes:
>
>
>   (mlet %store-monad ((gtk+ (lookup-gtk+ manifest)))
>     (define build
>       #~(...))
>
>     ...)
>
> Could you send an updated patch?
Here it is:

[-- Attachment #2: 0001-profiles-Add-gtk-icon-themes-hook.patch --]
[-- Type: text/x-patch, Size: 5230 bytes --]

From 96381da9c8680e2060e1c13c59698c635498094b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=E5=AE=8B=E6=96=87=E6=AD=A6?= <iyzsong@gmail.com>
Date: Sat, 9 May 2015 12:45:39 +0800
Subject: [PATCH] profiles: Add gtk-icon-themes hook.

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

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 9cb226e..d386d80 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.
 ;;;
@@ -586,12 +587,89 @@ 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."
+  ;; Return as a monadic value the GTK+ package or store path referenced by the
+  ;; manifest ENTRY, or #f if not referenced.
+  (define (entry-lookup-gtk+ entry)
+    (define (find-among-packages packages)
+      (find (lambda (package)
+              (equal? "gtk+" (package-name package)))
+            packages))
+
+    (define (find-among-store-items items)
+      (find (lambda (item)
+              (equal? "gtk+"
+                      (package-name->name+version
+                       (store-path-package-name item))))
+            items))
+
+    ;; XXX: put into (guix store).
+    (define references*
+      (store-lift references))
+
+    (with-monad %store-monad
+      (match (manifest-entry-item entry)
+        ((? package? package)
+         (match (package-transitive-inputs package)
+           (((labels packages . _) ...)
+            (return (find-among-packages packages)))))
+        ((? string? item)
+         (mlet %store-monad ((refs (references* item)))
+           (return (find-among-store-items refs)))))))
+
+  (define (manifest-lookup-gtk+ manifest)
+    (anym %store-monad
+          (lambda (x) x)
+          (map entry-lookup-gtk+ (manifest-entries manifest))))
+
+  (mlet %store-monad ((gtk+ (manifest-lookup-gtk+ 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"))
+                 (icondirs (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 icondirs)
+            ;; 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)
+        (return #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
@@ -606,7 +684,7 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc."
                                                           (hook manifest))
                                                         hooks)))))
     (define inputs
-      (append (map gexp-input extras)
+      (append (map gexp-input (filter (lambda (x) x) extras))
               (manifest-inputs manifest)))
 
     (define builder
-- 
2.2.1


[-- Attachment #3: Type: text/plain, Size: 152 bytes --]


And I have to modify 'profile-derivation' to do an extra filter for
'extras', because 'gtk-icon-themes' could return a monadic '#f'.
Any better idea?