From mboxrd@z Thu Jan 1 00:00:00 1970 From: =?utf-8?B?5a6L5paH5q2m?= Subject: Re: [PATCH] profiles: Add gtk-icon-themes hook. Date: Fri, 22 May 2015 14:43:05 +0800 Message-ID: <878uchaz9i.fsf@gmail.com> References: <1431508332-8042-1-git-send-email-iyzsong@gmail.com> <87h9r53n60.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:52032) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YvgfF-0004bY-9L for guix-devel@gnu.org; Fri, 22 May 2015 02:42:38 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1YvgfD-0003hm-Un for guix-devel@gnu.org; Fri, 22 May 2015 02:42:37 -0400 In-Reply-To: <87h9r53n60.fsf@gnu.org> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: Ludovic =?utf-8?Q?Court=C3=A8s?= Cc: guix-devel@gnu.org --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > =E5=AE=8B=E6=96=87=E6=AD=A6 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 entrie= s 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 E= NTRY, 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: --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: attachment; filename=0001-profiles-Add-gtk-icon-themes-hook.patch Content-Transfer-Encoding: quoted-printable >From 96381da9c8680e2060e1c13c59698c635498094b Mon Sep 17 00:00:00 2001 From: =3D?UTF-8?q?=3DE5=3DAE=3D8B=3DE6=3D96=3D87=3DE6=3DAD=3DA6?=3D 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 =C2=A9 2013 Nikita Karetnikov ;;; Copyright =C2=A9 2014 Alex Kost ;;; Copyright =C2=A9 2015 Mark H Weaver +;;; Copyright =C2=A9 2015 Sou Bunnbu ;;; ;;; This file is part of GNU Guix. ;;; @@ -586,12 +587,89 @@ MANIFEST. Single-file bundles are required by progra= ms such as Git and Lynx." #:modules '((guix build utils)) #:local-build? #t)) =20 +(define (gtk-icon-themes manifest) + "Return a derivation that unions all icon themes from manifest entries a= nd +creates the GTK+ 'icon-theme.cache' file for each icon theme." + ;; Return as a monadic value the GTK+ package or store path referenced b= y 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/icon= s") + '#$(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)) =20 (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))) =20 (define builder --=20 2.2.1 --=-=-= Content-Type: text/plain 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? --=-=-=--