profiles: Factor out 'manifest-lookup-package'.
* guix/profiles.scm (manifest-lookup-package): New procedure. (gtk-icon-themes, xdg-desktop-database, xdg-mime-database): Use it.master
parent
7236045314
commit
d72d783301
|
@ -445,6 +445,40 @@ replace it."
|
||||||
(cons (gexp-input thing output) deps)))
|
(cons (gexp-input thing output) deps)))
|
||||||
(manifest-entries manifest)))
|
(manifest-entries manifest)))
|
||||||
|
|
||||||
|
(define (manifest-lookup-package manifest name)
|
||||||
|
"Return as a monadic value the first package or store path referenced by
|
||||||
|
MANIFEST that named NAME, or #f if not found."
|
||||||
|
;; Return as a monadic value the package or store path referenced by the
|
||||||
|
;; manifest ENTRY, or #f if not referenced.
|
||||||
|
(define (entry-lookup-package entry)
|
||||||
|
(define (find-among-inputs inputs)
|
||||||
|
(find (lambda (input)
|
||||||
|
(and (package? input)
|
||||||
|
(equal? name (package-name input))))
|
||||||
|
inputs))
|
||||||
|
(define (find-among-store-items items)
|
||||||
|
(find (lambda (item)
|
||||||
|
(equal? name (package-name->name+version
|
||||||
|
(store-path-package-name item))))
|
||||||
|
items))
|
||||||
|
|
||||||
|
;; TODO: Factorize.
|
||||||
|
(define references*
|
||||||
|
(store-lift references))
|
||||||
|
|
||||||
|
(with-monad %store-monad
|
||||||
|
(match (manifest-entry-item entry)
|
||||||
|
((? package? package)
|
||||||
|
(match (package-transitive-inputs package)
|
||||||
|
(((labels inputs . _) ...)
|
||||||
|
(return (find-among-inputs inputs)))))
|
||||||
|
((? string? item)
|
||||||
|
(mlet %store-monad ((refs (references* item)))
|
||||||
|
(return (find-among-store-items refs)))))))
|
||||||
|
|
||||||
|
(anym %store-monad
|
||||||
|
entry-lookup-package (manifest-entries manifest)))
|
||||||
|
|
||||||
(define (info-dir-file manifest)
|
(define (info-dir-file manifest)
|
||||||
"Return a derivation that builds the 'dir' file for all the entries of
|
"Return a derivation that builds the 'dir' file for all the entries of
|
||||||
MANIFEST."
|
MANIFEST."
|
||||||
|
@ -608,41 +642,7 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
|
||||||
(define (gtk-icon-themes manifest)
|
(define (gtk-icon-themes manifest)
|
||||||
"Return a derivation that unions all icon themes from manifest entries and
|
"Return a derivation that unions all icon themes from manifest entries and
|
||||||
creates the GTK+ 'icon-theme.cache' file for each theme."
|
creates the GTK+ 'icon-theme.cache' file for each theme."
|
||||||
;; Return as a monadic value the GTK+ package or store path referenced by the
|
(mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+")))
|
||||||
;; manifest ENTRY, or #f if not referenced.
|
|
||||||
(define (entry-lookup-gtk+ entry)
|
|
||||||
(define (find-among-inputs inputs)
|
|
||||||
(find (lambda (input)
|
|
||||||
(and (package? input)
|
|
||||||
(string=? "gtk+" (package-name input))))
|
|
||||||
inputs))
|
|
||||||
|
|
||||||
(define (find-among-store-items items)
|
|
||||||
(find (lambda (item)
|
|
||||||
(equal? "gtk+"
|
|
||||||
(package-name->name+version
|
|
||||||
(store-path-package-name item))))
|
|
||||||
items))
|
|
||||||
|
|
||||||
;; TODO: Factorize.
|
|
||||||
(define references*
|
|
||||||
(store-lift references))
|
|
||||||
|
|
||||||
(with-monad %store-monad
|
|
||||||
(match (manifest-entry-item entry)
|
|
||||||
((? package? package)
|
|
||||||
(match (package-transitive-inputs package)
|
|
||||||
(((labels inputs . _) ...)
|
|
||||||
(return (find-among-inputs inputs)))))
|
|
||||||
((? string? item)
|
|
||||||
(mlet %store-monad ((refs (references* item)))
|
|
||||||
(return (find-among-store-items refs)))))))
|
|
||||||
|
|
||||||
(define (manifest-lookup-gtk+ manifest)
|
|
||||||
(anym %store-monad
|
|
||||||
entry-lookup-gtk+ (manifest-entries manifest)))
|
|
||||||
|
|
||||||
(mlet %store-monad ((gtk+ (manifest-lookup-gtk+ manifest)))
|
|
||||||
(define build
|
(define build
|
||||||
#~(begin
|
#~(begin
|
||||||
(use-modules (guix build utils)
|
(use-modules (guix build utils)
|
||||||
|
@ -690,10 +690,9 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
|
||||||
"Return a derivation that builds the @file{mimeinfo.cache} database from
|
"Return a derivation that builds the @file{mimeinfo.cache} database from
|
||||||
desktop files. It's used to query what applications can handle a given
|
desktop files. It's used to query what applications can handle a given
|
||||||
MIME type."
|
MIME type."
|
||||||
(define desktop-file-utils
|
(mlet %store-monad ((desktop-file-utils
|
||||||
(module-ref (resolve-interface '(gnu packages gnome))
|
(manifest-lookup-package
|
||||||
'desktop-file-utils))
|
manifest "desktop-file-utils")))
|
||||||
|
|
||||||
(define build
|
(define build
|
||||||
#~(begin
|
#~(begin
|
||||||
(use-modules (srfi srfi-26)
|
(use-modules (srfi srfi-26)
|
||||||
|
@ -712,22 +711,21 @@ MIME type."
|
||||||
#:log-port (%make-void-port "w"))
|
#:log-port (%make-void-port "w"))
|
||||||
(zero? (system* update-desktop-database destdir)))))
|
(zero? (system* update-desktop-database destdir)))))
|
||||||
|
|
||||||
;; Don't run the hook when 'desktop-file-utils' is not installed.
|
;; Don't run the hook when 'desktop-file-utils' is not referenced.
|
||||||
(if (manifest-lookup manifest (manifest-pattern (name "desktop-file-utils")))
|
(if desktop-file-utils
|
||||||
(gexp->derivation "xdg-desktop-database" build
|
(gexp->derivation "xdg-desktop-database" build
|
||||||
#:modules '((guix build utils)
|
#:modules '((guix build utils)
|
||||||
(guix build union))
|
(guix build union))
|
||||||
#:local-build? #t
|
#:local-build? #t
|
||||||
#:substitutable? #f)
|
#:substitutable? #f)
|
||||||
(with-monad %store-monad (return #f))))
|
(return #f))))
|
||||||
|
|
||||||
(define (xdg-mime-database manifest)
|
(define (xdg-mime-database manifest)
|
||||||
"Return a derivation that builds the @file{mime.cache} database from manifest
|
"Return a derivation that builds the @file{mime.cache} database from manifest
|
||||||
entries. It's used to query the MIME type of a given file."
|
entries. It's used to query the MIME type of a given file."
|
||||||
(define shared-mime-info
|
(mlet %store-monad ((shared-mime-info
|
||||||
(module-ref (resolve-interface '(gnu packages gnome))
|
(manifest-lookup-package
|
||||||
'shared-mime-info))
|
manifest "shared-mime-info")))
|
||||||
|
|
||||||
(define build
|
(define build
|
||||||
#~(begin
|
#~(begin
|
||||||
(use-modules (srfi srfi-26)
|
(use-modules (srfi srfi-26)
|
||||||
|
@ -748,14 +746,14 @@ entries. It's used to query the MIME type of a given file."
|
||||||
(setenv "XDG_DATA_HOME" datadir)
|
(setenv "XDG_DATA_HOME" datadir)
|
||||||
(zero? (system* update-mime-database destdir)))))
|
(zero? (system* update-mime-database destdir)))))
|
||||||
|
|
||||||
;; Don't run the hook when 'shared-mime-info' is not installed.
|
;; Don't run the hook when 'shared-mime-info' is referenced.
|
||||||
(if (manifest-lookup manifest (manifest-pattern (name "shared-mime-info")))
|
(if shared-mime-info
|
||||||
(gexp->derivation "xdg-mime-database" build
|
(gexp->derivation "xdg-mime-database" build
|
||||||
#:modules '((guix build utils)
|
#:modules '((guix build utils)
|
||||||
(guix build union))
|
(guix build union))
|
||||||
#:local-build? #t
|
#:local-build? #t
|
||||||
#:substitutable? #f)
|
#:substitutable? #f)
|
||||||
(with-monad %store-monad (return #f))))
|
(return #f))))
|
||||||
|
|
||||||
(define %default-profile-hooks
|
(define %default-profile-hooks
|
||||||
;; This is the list of derivation-returning procedures that are called by
|
;; This is the list of derivation-returning procedures that are called by
|
||||||
|
|
Reference in New Issue