Ludovic Courtès <l...@gnu.org> writes:
> 宋文武 <iyzs...@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:
>From 96381da9c8680e2060e1c13c59698c635498094b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=E5=AE=8B=E6=96=87=E6=AD=A6?= <iyzs...@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 <nik...@karetnikov.org>
;;; Copyright © 2014 Alex Kost <alez...@gmail.com>
;;; Copyright © 2015 Mark H Weaver <m...@netris.org>
+;;; Copyright © 2015 Sou Bunnbu <iyzs...@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
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?
