Toggle diff (405 lines)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 0f47268541..eeec76bf22 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -958,55 +958,18 @@ (define (manifest-inputs manifest)
(append-map entry->input (manifest-entries manifest)))
-(define* (manifest-lookup-package manifest name #:optional version)
- "Return as a monadic value the first package or store path referenced by
-MANIFEST that is named NAME and optionally has the given VERSION prefix, 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))
- (if version
- (string-prefix? version (package-version input))
- #t)))
- inputs))
- (define (find-among-store-items items)
- (find (lambda (item)
- (let-values (((name* version*)
- (package-name->name+version
- (store-path-package-name item))))
- (and (string=? name name*)
- (if version
- (string-prefix? version version*)
- #t))))
- items))
-
- (with-monad %store-monad
- (match (manifest-entry-item entry)
- ((? package? package)
- (match (cons (list (package-name package) package)
- (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))))
- (item
- ;; XXX: ITEM might be a 'computed-file' or anything like that, in
- ;; which case we don't know what to do. The fix may be to check
- ;; references once ITEM is compiled, as proposed at
- ;; <https://bugs.gnu.org/29927>.
- (return #f)))))
-
- (anym %store-monad
- entry-lookup-package (manifest-entries manifest)))
-
-(define* (info-dir-file manifest #:optional system)
- "Return a derivation that builds the 'dir' file for all the entries of
-MANIFEST."
+(define* (find-entry entries name #:optional version)
+ "Return the first manifest entry from ENTRIES that is named NAME and
+optionally has the given VERSION prefix, or #f if not found."
+ (find (lambda (entry)
+ (and (equal? name (manifest-entry-name entry))
+ (if version
+ (string-prefix? version (manifest-entry-version entry))
+ #t)))
+ entries))
+
+(define* (info-dir-file entries #:optional system)
+ "Return a derivation that builds the 'dir' file for all the manifest ENTRIES."
(define texinfo ;lazy reference
(module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
(define gzip ;lazy reference
@@ -1015,7 +978,7 @@ (define* (info-dir-file manifest #:optional system)
(module-ref (resolve-interface '(gnu packages base))
'libc-utf8-locales-for-target))
- (define build
+ (define (build items)
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
@@ -1060,24 +1023,33 @@ (define* (info-dir-file manifest #:optional system)
(mkdir-p (string-append #$output "/share/info"))
(exit (every install-info
- (append-map info-files
- '#$(manifest-inputs manifest)))))))
-
- (gexp->derivation "info-dir" build
- #:system system
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . info-dir))))
+ (append-map info-files '#$items))))))
+
+ (mlet %store-monad
+ ;; Only run this hook for entries which contains info files.
+ ((interested -> (filter (lambda (entry)
+ (file-exists?
+ (string-append (manifest-entry-item entry)
+ "/share/info")))
+ entries)))
+ (if (null? interested)
+ (return #f)
+ (gexp->derivation "info-dir"
+ (build (map manifest-entry-item interested))
+ #:system system
+ #:local-build? #t
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . info-dir))))))
-(define* (ghc-package-cache-file manifest #:optional system)
+(define* (ghc-package-cache-file entries #:optional system)
"Return a derivation that builds the GHC 'package.cache' file for all the
-entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
+ENTRIES of manifest, or #f if ENTRIES does not have any GHC packages."
(define ghc ;lazy reference
(module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
- (define build
+ (define (build items)
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
@@ -1108,8 +1080,7 @@ (define* (ghc-package-cache-file manifest #:optional system)
(system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
(for-each copy-conf-file
(append-map conf-files
- (delete-duplicates
- '#$(manifest-inputs manifest))))
+ (delete-duplicates '#$items)))
(let ((success
(zero?
(system* (string-append #+ghc "/bin/ghc-pkg") "recache"
@@ -1117,26 +1088,32 @@ (define* (ghc-package-cache-file manifest #:optional system)
(for-each delete-file (find-files db-dir "\\.conf$"))
(exit success)))))
- (with-monad %store-monad
- ;; 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
+ (mlet %store-monad
+ ;; Don't depend on GHC when there's nothing to do.
+ ((interested -> (filter (lambda (entry)
+ (file-exists?
+ (string-append (manifest-entry-item entry)
+ "/lib/ghc-"
+ (package-version ghc))))
+ entries)))
+ (if (null? interested)
+ (return #f)
+ (gexp->derivation "ghc-package-cache"
+ (build (map manifest-entry-item interested))
#:system system
#:local-build? #t
#:substitutable? #f
#:properties
`((type . profile-hook)
- (hook . ghc-package-cache)))
- (return #f))))
+ (hook . ghc-package-cache))))))
-(define* (ca-certificate-bundle manifest #:optional system)
+(define* (ca-certificate-bundle entries #:optional system)
"Return a derivation that builds a single-file bundle containing the CA
-certificates in the /etc/ssl/certs sub-directories of the packages in
-MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
+certificates in the /etc/ssl/certs sub-directories of the packages for manifest
+ENTRIES. 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 build
+ (define (build items)
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
@@ -1169,7 +1146,7 @@ (define* (ca-certificate-bundle manifest #:optional system)
;; install a UTF-8 locale.
(setlocale LC_ALL "C.UTF-8")
- (match (append-map ca-files '#$(manifest-inputs manifest))
+ (match (append-map ca-files '#$items)
(()
;; Since there are no CA files, just create an empty directory. Do
;; not create the etc/ssl/certs sub-directory, since that would
@@ -1185,16 +1162,26 @@ (define* (ca-certificate-bundle manifest #:optional system)
"/ca-certificates.crt"))
#t))))))
- (gexp->derivation "ca-certificate-bundle" build
+ (mlet %store-monad
+ ((interested -> (filter
+ (lambda (entry)
+ (file-exists?
+ (string-append (manifest-entry-item entry)
+ "/etc/ssl/certs")))
+ entries)))
+ (if (null? interested)
+ (return #f)
+ (gexp->derivation "ca-certificate-bundle"
+ (build (map manifest-entry-item interested))
#:system system
#:local-build? #t
#:substitutable? #f
#:properties
`((type . profile-hook)
- (hook . ca-certificate-bundle))))
+ (hook . ca-certificate-bundle))))))
-(define* (emacs-subdirs manifest #:optional system)
- (define build
+(define* (emacs-subdirs entries #:optional system)
+ (define (build items)
(with-imported-modules (source-module-closure
'((guix build profiles)
(guix build utils)))
@@ -1213,9 +1200,8 @@ (define* (emacs-subdirs manifest #:optional system)
file-is-directory?
(map (cute string-append dir "/" <>)
(scandir dir (negate (cute member <> '("." "..")))))))
- (filter file-exists?
- (map (cute string-append <> "/share/emacs/site-lisp")
- '#$(manifest-inputs manifest))))))
+ (map (cute string-append <> "/share/emacs/site-lisp")
+ '#$items))))
(mkdir-p destdir)
(with-directory-excursion destdir
(call-with-output-file "subdirs.el"
@@ -1226,77 +1212,82 @@ (define* (emacs-subdirs manifest #:optional system)
port)
(newline port)
#t)))))))
- (gexp->derivation "emacs-subdirs" build
- #:system system
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . emacs-subdirs))))
-(define* (gdk-pixbuf-loaders-cache-file manifest #:optional system)
+ (mlet %store-monad
+ ((interested -> (filter
+ (lambda (entry)
+ (file-exists?
+ (string-append (manifest-entry-item entry)
+ "/share/emacs/site-lisp")))
+ entries)))
+ (if (null? interested)
+ (return #f)
+ (gexp->derivation "emacs-subdirs"
+ (build (map manifest-entry-item interested))
+ #:system system
+ #:local-build? #t
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . emacs-subdirs))))))
+
+(define* (gdk-pixbuf-loaders-cache-file entries #:optional system)
"Return a derivation that produces a loaders cache file for every gdk-pixbuf
-loaders discovered in MANIFEST."
+loaders discovered in manifest ENTRIES."
(define gdk-pixbuf ;lazy reference
(module-ref (resolve-interface '(gnu packages gtk)) 'gdk-pixbuf))
(mlet* %store-monad
- ((gdk-pixbuf (manifest-lookup-package manifest "gdk-pixbuf"))
- (librsvg (manifest-lookup-package manifest "librsvg"))
- (gdk-pixbuf-bin -> (if (string? gdk-pixbuf)
- (string-append gdk-pixbuf "/bin")
- (file-append gdk-pixbuf "/bin"))))
-
- (define build
+ ((interested -> (filter
+ (lambda (entry)
+ (file-exists?
+ (string-append (manifest-entry-item entry)
+ "/lib/gdk-pixbuf-2.0")))
+ entries))
+ (gdk-pixbuf -> (or (and=> (find-entry entries "gdk-pixbuf")
+ manifest-entry-item)
+ (file-append gdk-pixbuf))))
+
+ (define (build items)
(with-imported-modules (source-module-closure
'((guix build glib-or-gtk-build-system)))
#~(begin
(use-modules (guix build glib-or-gtk-build-system))
- (setenv "PATH" (string-append #$gdk-pixbuf-bin ":" (getenv "PATH")))
+ (setenv "PATH" (string-append #$gdk-pixbuf "/bin:" (getenv "PATH")))
(generate-gdk-pixbuf-loaders-cache
- ;; XXX: MANIFEST-LOOKUP-PACKAGE transitively searches through
- ;; every input referenced by the manifest, while MANIFEST-INPUTS
- ;; only retrieves the immediate inputs as well as their
- ;; propagated inputs; to avoid causing an empty output derivation
- ;; we must ensure that the inputs contain at least one
- ;; loaders.cache file. This is why we include gdk-pixbuf or
- ;; librsvg when they are transitively found.
- (list #$@(if gdk-pixbuf
- (list gdk-pixbuf)
- '())
- #$@(if librsvg
- (list librsvg)
- '())
- #$@(manifest-inputs manifest))
+ (list #$gdk-pixbuf #$@items)
(list #$output)))))
- (if gdk-pixbuf
- (gexp->derivation "gdk-pixbuf-loaders-cache-file" build
+ (if (null? interested)
+ (return #f)
+ (gexp->derivation "gdk-pixbuf-loaders-cache-file"
+ (build (map manifest-entry-item interested))
#:system system
#:local-build? #t
#:substitutable? #f
#:properties
'((type . profile-hook)
- (hook . gdk-pixbuf-loaders-cache-file)))
- (return #f))))
+ (hook . gdk-pixbuf-loaders-cache-file))))))
-(define* (glib-schemas manifest #:optional system)
- "Return a derivation that unions all schemas from manifest entries and
+(define* (glib-schemas entries #:optional system)
+ "Return a derivation that unions all schemas from manifest ENTRIES and
creates the Glib 'gschemas.compiled' file."
(define glib ; lazy reference
(module-ref (resolve-interface '(gnu packages glib)) 'glib))
- (mlet %store-monad ((%glib (manifest-lookup-package manifest "glib"))
- ;; XXX: Can't use glib-compile-schemas corresponding
- ;; to the glib referenced by 'manifest'. Because
- ;; '%glib' can be either a package or store path, and
- ;; there's no way to get the "bin" output for the later.
- (glib-compile-schemas
+ (mlet %store-monad ((glib-compile-schemas
-> #~(string-append #+glib:bin
- "/bin/glib-compile-schemas")))
-
- (define build
+ "/bin/glib-compile-schemas"))
+ (interested
+ -> (filter
+ (lambda (entry)
+ (file-exists?
+ (string-append (manifest-entry-item entry)
+ "/share/glib-2.0/schemas")))
+ entries)))
+
+ (define (build items)
(with-imported-modules '((guix build utils)
(guix build union)
(guix build profiles)
@@ -1309,9 +1300,8 @@ (define* (glib-schemas manifest #:optional system)
(srfi srfi-26))
(let* ((destdir (string-append #$output "/share/glib-2.0/schemas"))
- (schemadirs (filter file-exists?
- (map (cut string-append <> "/share/glib-2.0/schemas")
- '#$(manifest-inputs manifest)))))
+ (schemadirs (map (cut string-append <> "/share/glib-2.0/schemas")
+ '#$items)))
;; Union all the schemas.
(mkdir-p (string-append #$output "/share/glib-2.0"))
@@ -1326,32 +1316,35 @@ (define* (glib-schemas manifest #:optional system)
dir)))))))
;; Don't run the hook when there's nothing to do.
- (if %glib
- (gexp->derivation "glib-schemas" build
+ (if (null? interested)
+ (return #f)
+ (gexp->derivation "glib-schemas"
+ (build (map manifest-entry-item interested))
#:system system
#:local-build? #t
#:substitutable? #f
#:properties
`((type . profile-hook)
- (hook . glib-schemas)))
- (return #f))))
+ (hook . glib-schemas))))))
-(define* (gtk-icon-themes manifest #:optional system)
- "Return a derivation that unions all icon themes from manifest entries and
+(define* (gtk-icon-themes entries #:optional system)
+ "Return a derivation that unions all icon themes from manifest ENTRIES and
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+"))
- ;; XXX: Can't use gtk-update-icon-cache corresponding
- ;; to the gtk+ referenced by 'manifest'. Beca
