(address . guix-patches@gnu.org)(name . ???)(address . iyzsong@member.fsf.org)
20180101103336.8613-5-iyzsong@member.fsf.org
* guix/profiles.scm (manual-database, fonts-dir-file, ghc-package-cache-file)
(ca-certificate-bundle, gtk-icon-themes, gtk-im-modules)
(xdg-desktop-database, xdg-mime-database): Use 'eval-gexp' to filter out
unwanted manifest inputs.
---
guix/profiles.scm | 164 ++++++++++++++++++++++++++++++++++++------------------
1 file changed, 111 insertions(+), 53 deletions(-)
Toggle diff (330 lines)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index f6e455c96..7d69d1a53 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -733,7 +733,15 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
(define ghc ;lazy reference
(module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
- (define build
+ (define interested
+ (eval-gexp
+ #~(filter
+ (lambda (input)
+ (file-exists? (string-append input "/lib/ghc-"
+ #$(package-version ghc))))
+ '#$(manifest-inputs manifest))))
+
+ (define (build inputs)
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
@@ -763,9 +771,7 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
(system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
(for-each copy-conf-file
- (append-map conf-files
- (delete-duplicates
- '#$(manifest-inputs manifest))))
+ (append-map conf-files '#$inputs))
(let ((success
(zero?
(system* (string-append #+ghc "/bin/ghc-pkg") "recache"
@@ -773,11 +779,10 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
(for-each delete-file (find-files db-dir "\\.conf$"))
(exit success)))))
- (with-monad %store-monad
+ (mlet* %store-monad ((inputs interested))
;; Don't depend on GHC when there's nothing to do.
- (if (any (cut string-prefix? "ghc" <>)
- (map manifest-entry-name (manifest-entries manifest)))
- (gexp->derivation "ghc-package-cache" build
+ (if (not (null? inputs))
+ (gexp->derivation "ghc-package-cache" (build inputs)
#:local-build? #t
#:substitutable? #f)
(return #f))))
@@ -789,10 +794,17 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html>
;; for a discussion.
+ (define interested
+ (eval-gexp
+ #~(filter
+ (lambda (input)
+ (file-exists? (string-append input "/etc/ssl/certs")))
+ '#$(manifest-inputs manifest))))
+
(define glibc-utf8-locales ;lazy reference
(module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
- (define build
+ (define (build inputs)
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
@@ -828,7 +840,7 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
#+(package-version glibc-utf8-locales)))
(setlocale LC_ALL "en_US.utf8")
- (match (append-map ca-files '#$(manifest-inputs manifest))
+ (match (append-map ca-files '#$inputs)
(()
;; Since there are no CA files, just create an empty directory. Do
;; not create the etc/ssl/certs sub-directory, since that would
@@ -844,9 +856,10 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
"/ca-certificates.crt"))
#t))))))
- (gexp->derivation "ca-certificate-bundle" build
- #:local-build? #t
- #:substitutable? #f))
+ (mlet* %store-monad ((inputs interested))
+ (gexp->derivation "ca-certificate-bundle" (build inputs)
+ #:local-build? #t
+ #:substitutable? #f)))
(define (gtk-icon-themes manifest)
"Return a derivation that unions all icon themes from manifest entries and
@@ -854,7 +867,15 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
(define gtk+ ; lazy reference
(module-ref (resolve-interface '(gnu packages gtk)) 'gtk+))
- (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+"))
+ (define interested
+ (eval-gexp
+ #~(filter
+ (lambda (input)
+ (file-exists? (string-append input "/share/icons")))
+ '#$(manifest-inputs manifest))))
+
+ (mlet %store-monad ((inputs interested)
+ (%gtk+ (manifest-lookup-package manifest "gtk+"))
;; XXX: Can't use gtk-update-icon-cache corresponding
;; to the gtk+ referenced by 'manifest'. Because
;; '%gtk+' can be either a package or store path, and
@@ -877,9 +898,8 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
(ice-9 ftw))
(let* ((destdir (string-append #$output "/share/icons"))
- (icondirs (filter file-exists?
- (map (cut string-append <> "/share/icons")
- '#$(manifest-inputs manifest)))))
+ (icondirs (map (cut string-append <> "/share/icons")
+ '#$inputs)))
;; Union all the icons.
(mkdir-p (string-append #$output "/share"))
@@ -907,8 +927,18 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
(define (gtk-im-modules manifest)
"Return a derivation that builds the cache files for input method modules
for both major versions of GTK+."
-
- (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+" "3"))
+ (define interested
+ (eval-gexp
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (filter
+ (lambda (input)
+ (not (null? (find-files input "^immodules$" #:directories? #t))))
+ '#$(manifest-inputs manifest))))))
+
+ (mlet %store-monad ((inputs interested)
+ (gtk+ (manifest-lookup-package manifest "gtk+" "3"))
(gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
(define (build gtk gtk-version query)
@@ -932,7 +962,7 @@ for both major versions of GTK+."
(moddirs (cons (string-append #$gtk prefix "/immodules")
(filter file-exists?
(map (cut string-append <> prefix "/immodules")
- '#$(manifest-inputs manifest)))))
+ '#$inputs))))
(modules (append-map (cut find-files <> "\\.so$")
moddirs)))
@@ -980,11 +1010,19 @@ for both major versions of GTK+."
"Return a derivation that builds the @file{mimeinfo.cache} database from
desktop files. It's used to query what applications can handle a given
MIME type."
+ (define interested
+ (eval-gexp
+ #~(filter
+ (lambda (input)
+ (file-exists? (string-append input "/share/applications")))
+ '#$(manifest-inputs manifest))))
+
(define desktop-file-utils ; lazy reference
(module-ref (resolve-interface '(gnu packages freedesktop))
'desktop-file-utils))
- (mlet %store-monad ((glib
+ (mlet %store-monad ((inputs interested)
+ (glib
(manifest-lookup-package
manifest "glib")))
(define build
@@ -995,10 +1033,9 @@ MIME type."
(guix build utils)
(guix build union))
(let* ((destdir (string-append #$output "/share/applications"))
- (appdirs (filter file-exists?
- (map (cut string-append <>
- "/share/applications")
- '#$(manifest-inputs manifest))))
+ (appdirs (map (cut string-append <>
+ "/share/applications")
+ '#$inputs))
(update-desktop-database (string-append
#+desktop-file-utils
"/bin/update-desktop-database")))
@@ -1017,10 +1054,18 @@ MIME type."
(define (xdg-mime-database 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."
+ (define interested
+ (eval-gexp
+ #~(filter
+ (lambda (input)
+ (file-exists? (string-append input "/share/mime/packages")))
+ '#$(manifest-inputs manifest))))
+
(define shared-mime-info ; lazy reference
(module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
- (mlet %store-monad ((glib
+ (mlet %store-monad ((inputs interested)
+ (glib
(manifest-lookup-package
manifest "glib")))
(define build
@@ -1032,11 +1077,10 @@ entries. It's used to query the MIME type of a given file."
(guix build union))
(let* ((datadir (string-append #$output "/share"))
(destdir (string-append datadir "/mime"))
- (pkgdirs (filter file-exists?
- (map (cut string-append <>
- "/share/mime/packages")
- (cons #+shared-mime-info
- '#$(manifest-inputs manifest)))))
+ (pkgdirs (map (cut string-append <>
+ "/share/mime/packages")
+ (cons #+shared-mime-info
+ '#$inputs)))
(update-mime-database (string-append
#+shared-mime-info
"/bin/update-mime-database")))
@@ -1059,21 +1103,27 @@ entries. It's used to query the MIME type of a given file."
(define (fonts-dir-file manifest)
"Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
files for the fonts of the @var{manifest} entries."
+ (define interested
+ (eval-gexp
+ #~(filter
+ (lambda (input)
+ (file-exists? (string-append input "/share/fonts")))
+ '#$(manifest-inputs manifest))))
+
(define mkfontscale
(module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale))
(define mkfontdir
(module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir))
- (define build
+ (define (build inputs)
#~(begin
(use-modules (srfi srfi-26)
(guix build utils)
(guix build union))
- (let ((fonts-dirs (filter file-exists?
- (map (cut string-append <>
- "/share/fonts")
- '#$(manifest-inputs manifest)))))
+ (let ((fonts-dirs (map (cut string-append <>
+ "/share/fonts")
+ '#$inputs)))
(mkdir #$output)
(if (null? fonts-dirs)
(exit #t)
@@ -1116,16 +1166,24 @@ files for the fonts of the @var{manifest} entries."
(delete-file fonts-dir-file))))
directories)))))))
- (gexp->derivation "fonts-dir" build
- #:modules '((guix build utils)
- (guix build union)
- (srfi srfi-26))
- #:local-build? #t
- #:substitutable? #f))
+ (mlet* %store-monad ((inputs interested))
+ (gexp->derivation "fonts-dir" (build inputs)
+ #:modules '((guix build utils)
+ (guix build union)
+ (srfi srfi-26))
+ #:local-build? #t
+ #:substitutable? #f)))
(define (manual-database manifest)
"Return a derivation that builds the manual page database (\"mandb\") for
the entries in MANIFEST."
+ (define interested
+ (eval-gexp
+ #~(filter
+ (lambda (input)
+ (file-exists? (string-append input "/share/man")))
+ '#$(manifest-inputs manifest))))
+
(define gdbm-ffi
(module-ref (resolve-interface '(gnu packages guile))
'guile-gdbm-ffi))
@@ -1148,7 +1206,7 @@ the entries in MANIFEST."
(source-module-closure `((guix build utils)
(guix man-db))))))
- (define build
+ (define (build inputs)
(with-imported-modules modules
#~(begin
(add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/"
@@ -1162,10 +1220,8 @@ the entries in MANIFEST."
(define (compute-entries)
(append-map (lambda (directory)
(let ((man (string-append directory "/share/man")))
- (if (directory-exists? man)
- (mandb-entries man)
- '())))
- '#$(manifest-inputs manifest)))
+ (mandb-entries man)))
+ '#$inputs))
(define man-directory
(string-append #$output "/share/man"))
@@ -1186,14 +1242,16 @@ the entries in MANIFEST."
(* (time-nanosecond duration) (expt 10 -9))))
(force-output)))))
- (gexp->derivation "manual-database" build
+ (mlet* %store-monad ((inputs interested))
+ (gexp->derivation
+ "manual-databased" (build inputs)
- ;; Work around GDBM 1.13 issue whereby uninitialized bytes
- ;; get written to disk:
- ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
- #:env-vars `(("MALLOC_PERTURB_" . "1"))
+ ;; Work around GDBM 1.13 issue whereby uninitialized bytes get written to
+ ;; disk:
+ ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
+ #:env-vars `(("MALLOC_PERTURB_" . "1"))
- #:local-build? #t))
+ #:local-build? #t)))
(define %default-profile-hooks
;; This is the list of derivation-returning procedures that are called by
--
2.13.3