From patchwork Sat Jan 18 12:07:00 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: iyzsong--- via Guix-patches via X-Patchwork-Id: 37144 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id E6FDD27BBEA; Sat, 18 Jan 2025 12:04:24 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.4 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED, RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id EF43827BBE2 for ; Sat, 18 Jan 2025 12:04:21 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tZ7Yf-0001na-Rs; Sat, 18 Jan 2025 07:04:09 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tZ7Yd-0001mq-Kp for guix-patches@gnu.org; Sat, 18 Jan 2025 07:04:07 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tZ7Yc-0006Z8-V7; Sat, 18 Jan 2025 07:04:07 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:From:To:In-Reply-To:References:Subject; bh=ZmsgbtiB6x1jEdkSIH2N9aU0y1Fs67ts9rum6zi4D28=; b=t8QaDde+bLhpV90pfJdMG+0jQjvSp8E2ojhsLL/PoamspEAz/8g3TxN9woqrgKkS/jvAo9X1JTbgZNmQB5O0Zq0H77OE+Clf2YbRmmvyMT3slScpDOV6DigwbbHKm7mnisSjtnLao8R9YEG3iw/6/LhANhxTWiGooCDjLkYuKNoWIbWBchEOTYgQylmjeRY8+yJNn+aIdgvmA3UVn2dVjhwq1ZG3QfmQXjeefqlXA09nLNLegkMtqAlJ+w3dCnWLyZHJA5MN3k9hBZK+WSQPl40y+2UQTrnpbCNGDuSDskLwSPsL2AP+1zYn9Sbapq/LVRKoU69aJhYZxXeN6Mq7Ug==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tZ7YY-0001IU-B0; Sat, 18 Jan 2025 07:04:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#75647] [PATCH v2 1/2] profiles: Add #:build? argument to lower-manifest-entry. References: In-Reply-To: Resent-From: iyzsong@envs.net Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Sat, 18 Jan 2025 12:04:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 75647 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 75647@debbugs.gnu.org Cc: =?utf-8?b?5a6L5paH5q2m?= , Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-Xcc: Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by 75647-submit@debbugs.gnu.org id=B75647.17372018264947 (code B ref 75647); Sat, 18 Jan 2025 12:04:02 +0000 Received: (at 75647) by debbugs.gnu.org; 18 Jan 2025 12:03:46 +0000 Received: from localhost ([127.0.0.1]:40573 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tZ7YI-0001Hi-16 for submit@debbugs.gnu.org; Sat, 18 Jan 2025 07:03:46 -0500 Received: from mail.envs.net ([5.199.136.28]:45480) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1tZ7YE-0001HU-27 for 75647@debbugs.gnu.org; Sat, 18 Jan 2025 07:03:43 -0500 Received: from localhost (mail.envs.net [127.0.0.1]) by mail.envs.net (Postfix) with ESMTP id BC05E38A2BDE; Sat, 18 Jan 2025 12:03:40 +0000 (UTC) X-Virus-Scanned: Debian amavisd-new at mail.envs.net Received: from mail.envs.net ([127.0.0.1]) by localhost (mail.envs.net [127.0.0.1]) (amavisd-new, port 10026) with ESMTP id TpzRECg69z8J; Sat, 18 Jan 2025 12:03:37 +0000 (UTC) Received: from localhost (unknown [112.44.106.6]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange ECDHE (P-256) server-signature RSA-PSS (2048 bits) server-digest SHA256) (No client certificate requested) by mail.envs.net (Postfix) with ESMTPSA; Sat, 18 Jan 2025 12:03:37 +0000 (UTC) Received: from localhost.localdomain (localhost.lan [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 178dc350; Sat, 18 Jan 2025 12:07:06 +0000 (UTC) Date: Sat, 18 Jan 2025 20:07:00 +0800 Message-ID: <367d0f5cffef102e3e4cdbaabcc093e94a74b180.1737201981.git.iyzsong@member.fsf.org> X-Mailer: git-send-email 2.47.1 MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Reply-to: iyzsong@envs.net X-ACL-Warn: , iyzsong--- via Guix-patches X-Patchwork-Original-From: iyzsong--- via Guix-patches via From: iyzsong--- via Guix-patches via Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches From: 宋文武 * guix/profiles.scm (lower-manifest-entry): Add #:build? keyword argument. Change-Id: Ifb86d581156034897377f3614fac67b7748e0ec3 --- guix/profiles.scm | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) base-commit: 87045f0982bd7aebb07b380cbf322651227546f4 diff --git a/guix/profiles.scm b/guix/profiles.scm index a28cf872cf..0f47268541 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver -;;; Copyright © 2015 Sou Bunnbu +;;; Copyright © 2015, 2025 宋文武 ;;; Copyright © 2016, 2017, 2018, 2019, 2021, 2022 Ricardo Wurmus ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Huang Ying @@ -308,9 +308,10 @@ (define (manifest-entry-lookup manifest) ((_ . entry) entry) (#f #f)))) -(define* (lower-manifest-entry entry system #:key target) +(define* (lower-manifest-entry entry system #:key target + (build? #f)) "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store -file name." +file name. When BUILD? is true, build the entry before returning." (define (recurse entry) (mapm/accumulate-builds (lambda (entry) (lower-manifest-entry entry system @@ -319,12 +320,20 @@ (define* (lower-manifest-entry entry system #:key target) (let ((item (manifest-entry-item entry))) (if (string? item) - (with-monad %store-monad + (mbegin %store-monad + (build (list item)) + (if build? + (build (list item)) + (return #t)) (return entry)) - (mlet %store-monad ((drv (lower-object item system + (mlet* %store-monad ((drv (lower-object item system #:target target)) + (dependencies (recurse entry)) - (output -> (manifest-entry-output entry))) + (output -> (manifest-entry-output entry)) + (built (if build? + (built-derivations (list (cons drv output))) + (return #t)))) (return (manifest-entry (inherit entry) (item (derivation->output-path drv output)) From patchwork Sat Jan 18 12:07:01 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: iyzsong--- via Guix-patches via X-Patchwork-Id: 37145 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 5396C27BBEA; Sat, 18 Jan 2025 12:04:29 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.4 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED, RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 8EEBB27BBE2 for ; Sat, 18 Jan 2025 12:04:27 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tZ7Yd-0001mp-KC; Sat, 18 Jan 2025 07:04:07 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tZ7Yb-0001mX-O4 for guix-patches@gnu.org; Sat, 18 Jan 2025 07:04:05 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tZ7Yb-0006Yj-EV; Sat, 18 Jan 2025 07:04:05 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:References:In-Reply-To:Date:From:To:Subject; bh=QUab0x4WzymD76wxo3GIFcW2Ywx/OacrwJV8ZCV6bNo=; b=tcO7C3UcdwId4Nw83btYziAFqODkbV38bJAAr9Myf0hOI5PtRLj3+rYC/OWVx8q9QOnMwYFxBNoAXMmYkv6v3iZMWLuZ8qBRMlgqn1Cs9Xh5zJGJGCsnfRNK8KwxupfMs5pM+gDJ/vCoxPdi0vyAGIrXY0c7VHX9qam0uq+m4WrfKe8krYbuF+BZoR5KWILPEpmg55lxLYe89jl8X1lukOm4ZTD2yvfYPASOFjTtyRaSrimssxNh1E57MKV6pMtfJo6VR1c20v/8IxEljI9ONkPyotGVna8UUrOtB3pT5wk9Ia98YBopVQToyh8zD22J6lxQ1rnLgEtZaDr6lXulAA==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tZ7YY-0001Ia-Qo; Sat, 18 Jan 2025 07:04:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#75647] [PATCH v2 2/2] rofiles: Filter out unwanted manifest entries for profile hooks. Resent-From: iyzsong@envs.net Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Sat, 18 Jan 2025 12:04:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 75647 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 75647@debbugs.gnu.org Cc: =?utf-8?b?5a6L5paH5q2m?= , Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-Xcc: Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by 75647-submit@debbugs.gnu.org id=B75647.17372018324966 (code B ref 75647); Sat, 18 Jan 2025 12:04:02 +0000 Received: (at 75647) by debbugs.gnu.org; 18 Jan 2025 12:03:52 +0000 Received: from localhost ([127.0.0.1]:40576 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tZ7YM-0001I0-Jf for submit@debbugs.gnu.org; Sat, 18 Jan 2025 07:03:52 -0500 Received: from mail.envs.net ([5.199.136.28]:60704) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1tZ7YH-0001Hf-OY for 75647@debbugs.gnu.org; Sat, 18 Jan 2025 07:03:47 -0500 Received: from localhost (mail.envs.net [127.0.0.1]) by mail.envs.net (Postfix) with ESMTP id F0E0F38A2BDE; Sat, 18 Jan 2025 12:03:44 +0000 (UTC) X-Virus-Scanned: Debian amavisd-new at mail.envs.net Received: from mail.envs.net ([127.0.0.1]) by localhost (mail.envs.net [127.0.0.1]) (amavisd-new, port 10026) with ESMTP id ncqCSAb4_Ilf; Sat, 18 Jan 2025 12:03:40 +0000 (UTC) Received: from localhost (unknown [112.44.106.6]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange ECDHE (P-256) server-signature RSA-PSS (2048 bits) server-digest SHA256) (No client certificate requested) by mail.envs.net (Postfix) with ESMTPSA; Sat, 18 Jan 2025 12:03:40 +0000 (UTC) Received: from localhost.localdomain (localhost.lan [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 5f2aaab4; Sat, 18 Jan 2025 12:07:06 +0000 (UTC) Date: Sat, 18 Jan 2025 20:07:01 +0800 Message-ID: X-Mailer: git-send-email 2.47.1 In-Reply-To: <367d0f5cffef102e3e4cdbaabcc093e94a74b180.1737201981.git.iyzsong@member.fsf.org> References: <367d0f5cffef102e3e4cdbaabcc093e94a74b180.1737201981.git.iyzsong@member.fsf.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Reply-to: iyzsong@envs.net X-ACL-Warn: , iyzsong--- via Guix-patches X-Patchwork-Original-From: iyzsong--- via Guix-patches via From: iyzsong--- via Guix-patches via Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches From: 宋文武 Before we run profile hooks for all manifest inputs, so if you install a new package to your profile, all profile hooks will be run again, even if the new package doesn't provide info manuals, man pages, etc. After this commit every profile hook will be run with its hook related inputs, avoid unneccessary reruns. * guix/profiles.scm (manifest-lookup-package): Remove procedure. (find-entry): New procedure. (profile-derivation): Build manifest entries before running hooks. (manual-database/optional): Remove procedure. (%default-profile-hooks): Replace 'manual-database/optional' with 'manual-database'. (info-dir-file, manual-database, fonts-dir-file, ghc-package-cache-file) (ca-certificate-bundle, emacs-subdir, gdk-pixbuf-loaders-cache-file) (glib-schemas, gtk-icon-themes, gtk-im-modules, texlive-font-maps) (xdg-desktop-database, xdg-mime-database): Only run the hook with entries that contains hook related files. Change-Id: I6ee8c44cb1e625ced711cd0fc75d1762daa0dc72 --- guix/profiles.scm | 543 +++++++++++++++++++++++++--------------------- 1 file changed, 295 insertions(+), 248 deletions(-) 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 - ;; . - (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 ;; 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'. Because - ;; '%gtk+' can be either a package or store path, and - ;; there's no way to get the "bin" output for the later. - (gtk-update-icon-cache + (mlet %store-monad ((gtk-update-icon-cache -> #~(string-append #+gtk+:bin - "/bin/gtk-update-icon-cache"))) - - (define build + "/bin/gtk-update-icon-cache")) + (interested + -> (filter + (lambda (entry) + (file-exists? + (string-append (manifest-entry-item entry) + "/share/icons"))) + entries))) + + (define (build items) (with-imported-modules '((guix build utils) (guix build union) (guix build profiles) @@ -1365,9 +1358,8 @@ (define* (gtk-icon-themes manifest #:optional system) (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") + '#$items))) ;; Union all the icons. (mkdir-p (string-append #$output "/share")) @@ -1386,24 +1378,49 @@ (define* (gtk-icon-themes manifest #:optional system) (scandir destdir (negate (cut member <> '("." ".."))))))))) ;; Don't run the hook when there's nothing to do. - (if %gtk+ - (gexp->derivation "gtk-icon-themes" build + (if (null? interested) + (return #f) + (gexp->derivation "gtk-icon-themes" + (build (map manifest-entry-item interested)) #:system system #:local-build? #t #:substitutable? #f #:properties `((type . profile-hook) - (hook . gtk-icon-themes))) - (return #f)))) + (hook . gtk-icon-themes)))))) -(define* (gtk-im-modules manifest #:optional system) +(define* (gtk-im-modules entries #:optional system) "Return a derivation that builds the cache files for input method modules for both major versions of GTK+." + (define pkg-gtk2 ; lazy reference + (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+-2)) + (define pkg-gtk3 ; lazy reference + (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+)) - (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+" "3")) - (gtk+-2 (manifest-lookup-package manifest "gtk+" "2"))) - - (define (build gtk gtk-version query) + (mlet %store-monad ((gtk2 + -> (or (and=> (find-entry entries "gtk+" "2") + manifest-entry-item) + pkg-gtk2)) + (gtk3 + -> (or (and=> (find-entry entries "gtk+" "3") + manifest-entry-item) + pkg-gtk3)) + (gtk2-entries + -> (filter + (lambda (entry) + (file-exists? + (string-append (manifest-entry-item entry) + "/lib/gtk-2.0/2.10.0/immodules"))) + entries)) + (gtk3-entries + -> (filter + (lambda (entry) + (file-exists? + (string-append (manifest-entry-item entry) + "/lib/gtk-3.0/3.0.0/immodules"))) + entries))) + + (define (build gtk gtk-version query items) (let ((major (string-take gtk-version 1))) (with-imported-modules '((guix build utils) (guix build union) @@ -1424,10 +1441,12 @@ (define* (gtk-im-modules manifest #:optional system) (moddirs (cons (string-append #$gtk prefix "/immodules") (filter file-exists? (map (cut string-append <> prefix "/immodules") - '#$(manifest-inputs manifest))))) + '#$items)))) (modules (append-map (cut find-files <> "\\.so$") moddirs))) + + ;; Generate a new immodules cache file. (mkdir-p (string-append #$output prefix)) (let ((pipe (apply open-pipe* OPEN_READ #$query modules)) @@ -1445,34 +1464,32 @@ (define* (gtk-im-modules manifest #:optional system) (close-pipe pipe))))))))) ;; Don't run the hook when there's nothing to do. - (let* ((pkg-gtk+ (module-ref ; lazy reference - (resolve-interface '(gnu packages gtk)) 'gtk+)) - (pkg-gtk+2 (module-ref ; lazy reference - (resolve-interface '(gnu packages gtk)) 'gtk+-2)) - (gexp #~(begin - #$(if gtk+ + (let* ((gexp #~(begin + #$(if (not (null? gtk3-entries)) (build - gtk+ "3.0.0" + gtk3 "3.0.0" ;; Use 'gtk-query-immodules-3.0' from the 'bin' ;; output of latest gtk+ package. #~(string-append - #$pkg-gtk+:bin "/bin/gtk-query-immodules-3.0")) + #$pkg-gtk3:bin "/bin/gtk-query-immodules-3.0") + (map manifest-entry-item gtk3-entries)) #t) - #$(if gtk+-2 + #$(if (not (null? gtk2-entries)) (build - gtk+-2 "2.10.0" + gtk2 "2.10.0" #~(string-append - #$pkg-gtk+2:bin "/bin/gtk-query-immodules-2.0")) + #$pkg-gtk2:bin "/bin/gtk-query-immodules-2.0") + (map manifest-entry-item gtk2-entries)) #t)))) - (if (or gtk+ gtk+-2) + (if (and (null? gtk2-entries) (null? gtk3-entries)) + (return #f) (gexp->derivation "gtk-im-modules" gexp #:system system #:local-build? #t #:substitutable? #f #:properties `((type . profile-hook) - (hook . gtk-im-modules))) - (return #f))))) + (hook . gtk-im-modules))))))) (define* (linux-module-database manifest #:optional system) "Return a derivation that unites all the kernel modules of the manifest @@ -1534,7 +1551,7 @@ (define* (linux-module-database manifest #:optional system) `((type . profile-hook) (hook . linux-module-database)))) -(define* (xdg-desktop-database manifest #:optional system) +(define* (xdg-desktop-database entries #:optional system) "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." @@ -1542,10 +1559,14 @@ (define* (xdg-desktop-database manifest #:optional system) (module-ref (resolve-interface '(gnu packages freedesktop)) 'desktop-file-utils)) - (mlet %store-monad ((glib - (manifest-lookup-package - manifest "glib"))) - (define build + (mlet %store-monad ((interested + -> (filter + (lambda (entry) + (file-exists? + (string-append (manifest-entry-item entry) + "/share/applications"))) + entries))) + (define (build items) (with-imported-modules '((guix build utils) (guix build union)) #~(begin @@ -1553,10 +1574,9 @@ (define* (xdg-desktop-database manifest #:optional system) (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") + '#$items)) (update-desktop-database (string-append #+desktop-file-utils "/bin/update-desktop-database"))) @@ -1565,25 +1585,32 @@ (define* (xdg-desktop-database manifest #:optional system) #:log-port (%make-void-port "w")) (exit (zero? (system* update-desktop-database destdir))))))) - ;; Don't run the hook when 'glib' is not referenced. - (if glib - (gexp->derivation "xdg-desktop-database" build + ;; Don't run the hook when there's nothing to do. + (if (null? interested) + (return #f) + (gexp->derivation "xdg-desktop-database" + (build (map manifest-entry-item interested)) #:system system #:local-build? #t #:substitutable? #f #:properties `((type . profile-hook) - (hook . xdg-desktop-database))) - (return #f)))) + (hook . xdg-desktop-database)))))) -(define* (xdg-mime-database manifest #:optional system) +(define* (xdg-mime-database entries #:optional system) "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 ; lazy reference (module-ref (resolve-interface '(gnu packages freedesktop)) 'shared-mime-info)) - (mlet %store-monad ((glib (manifest-lookup-package manifest "glib"))) - (define build + (mlet %store-monad + ((interested -> (filter + (lambda (entry) + (file-exists? + (string-append (manifest-entry-item entry) + "/share/mime/packages"))) + entries))) + (define (build items) (with-imported-modules '((guix build utils) (guix build union)) #~(begin @@ -1594,11 +1621,10 @@ (define* (xdg-mime-database manifest #:optional system) (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 + '#$items)))) (match pkgdirs ((shared-mime-info) @@ -1620,38 +1646,38 @@ (define* (xdg-mime-database manifest #:optional system) "/bin/update-mime-database") destdir))))))) - ;; Don't run the hook when there are no GLib based applications. - (if glib - (gexp->derivation "xdg-mime-database" build + ;; Don't run the hook when there's nothing to do. + (if (null? interested) + (return #f) + (gexp->derivation "xdg-mime-database" + (build (map manifest-entry-item interested)) #:system system #:local-build? #t #:substitutable? #f #:properties `((type . profile-hook) - (hook . xdg-mime-database))) - (return #f)))) + (hook . xdg-mime-database)))))) ;; Several font packages may install font files into same directory, so ;; fonts.dir and fonts.scale file should be generated here, instead of in ;; packages. -(define* (fonts-dir-file manifest #:optional system) +(define* (fonts-dir-file entries #:optional system) "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale} -files for the fonts of the @var{manifest} entries." +files for the fonts of the manifest @var{entries}." (define mkfontscale (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale)) (define mkfontdir (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir)) - (define build + (define (build items) #~(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") + '#$items))) (mkdir #$output) (if (null? fonts-dirs) (exit #t) @@ -1694,20 +1720,31 @@ (define* (fonts-dir-file manifest #:optional system) (delete-file fonts-dir-file)))) directories))))))) - (gexp->derivation "fonts-dir" build - #:system system - #:modules '((guix build utils) - (guix build union) - (srfi srfi-26)) - #:local-build? #t - #:substitutable? #f - #:properties - `((type . profile-hook) - (hook . fonts-dir)))) + (mlet %store-monad + ;; Only run this hook for entries which contains fonts. + ((interested -> (filter (lambda (entry) + (file-exists? + (string-append (manifest-entry-item entry) + "/share/fonts"))) + entries))) + (if (null? interested) + (return #f) + (gexp->derivation "fonts-dir" + (build (map manifest-entry-item interested)) + #:system system + #:modules '((guix build utils) + (guix build union) + (srfi srfi-26)) + #:local-build? #t + #:substitutable? #f + #:properties + `((type . profile-hook) + (hook . fonts-dir)))))) -(define* (manual-database manifest #:optional system) - "Return a derivation that builds the manual page database (\"mandb\") for -the entries in MANIFEST." +(define* (manual-database entries #:optional system) + "Return a derivation that builds the manual page database (\"mandb\") for the +manifest ENTRIES, but only if entries contains the \"man-db\" package. +Otherwise, return #f." (define gdbm-ffi (module-ref (resolve-interface '(gnu packages guile)) 'guile-gdbm-ffi)) @@ -1723,7 +1760,7 @@ (define* (manual-database manifest #:optional system) (source-module-closure `((guix build utils) (guix man-db))))) - (define build + (define (build items) (with-imported-modules modules (with-extensions (list gdbm-ffi ;for (guix man-db) guile-zlib @@ -1756,7 +1793,7 @@ (define* (manual-database manifest #:optional system) ;; decompression), so report progress as we traverse INPUTS. ;; Cap at 4 threads because we don't see any speedup beyond that ;; on an SSD laptop. - (let* ((inputs '#$(manifest-inputs manifest)) + (let* ((inputs '#$items) (total (length inputs)) (threads (min (parallel-job-count) 4))) (concatenate @@ -1784,27 +1821,27 @@ (define* (manual-database manifest #:optional system) (* (time-nanosecond duration) (expt 10 -9)))) (force-output)))))) - (gexp->derivation "manual-database" build - #:system system - #:substitutable? #f - #:local-build? #t - #:properties - `((type . profile-hook) - (hook . manual-database)))) - -(define* (manual-database/optional manifest #:optional system) - "Return a derivation to build the manual database of MANIFEST, but only if -MANIFEST contains the \"man-db\" package. Otherwise, return #f." - ;; Building the man database (for "man -k") is expensive and rarely used. - ;; Build it only if the profile also contains "man-db". - (mlet %store-monad ((man-db (manifest-lookup-package manifest "man-db"))) - (if man-db - (manual-database manifest system) + (mlet %store-monad + ;; Only run this hook for entries which contains manual pages. + ((interested -> (filter (lambda (entry) + (file-exists? + (string-append (manifest-entry-item entry) + "/share/man"))) + entries))) + (if (and (find-entry entries "man-db") (not (null? interested))) + (gexp->derivation "manual-database" + (build (map manifest-entry-item interested)) + #:system system + #:substitutable? #f + #:local-build? #t + #:properties + `((type . profile-hook) + (hook . manual-database))) (return #f)))) -(define* (texlive-font-maps manifest #:optional system) - "Return a derivation that builds the TeX Live font maps for the entries in -MANIFEST." +(define* (texlive-font-maps entries #:optional system) + "Return a derivation that builds the TeX Live font maps for the manifest +ENTRIES." (define entry->texlive-input (match-lambda (($ name version output thing deps) @@ -1818,7 +1855,7 @@ (define* (texlive-font-maps manifest #:optional system) (or (string=? "texlive-scripts" name) (any texlive-scripts-entry? deps))))) (define texlive-inputs - (append-map entry->texlive-input (manifest-entries manifest))) + (append-map entry->texlive-input entries)) (define texlive-scripts (module-ref (resolve-interface '(gnu packages tex)) 'texlive-scripts)) (define texlive-libkpathsea @@ -1921,7 +1958,7 @@ (define* (texlive-font-maps manifest #:optional system) ;; `texlive-scripts' brings essential files to generate font maps. ;; Therefore, it must be present in the profile. This check prevents ;; incomplete modular TeX Live installations to generate errors. - (if (any texlive-scripts-entry? (manifest-entries manifest)) + (if (any texlive-scripts-entry? entries) (gexp->derivation "texlive-font-maps" build #:system system #:substitutable? #f @@ -1935,7 +1972,7 @@ (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 - manual-database/optional + manual-database fonts-dir-file ghc-package-cache-file ca-certificate-bundle @@ -1999,10 +2036,20 @@ (define* (profile-derivation manifest (return #t) (check-for-collisions manifest system #:target target))) + ;; Build all the entries before running hooks. + (entries (mapm/accumulate-builds + (lambda (entry) + (lower-manifest-entry entry system #:target target + #:build? #t)) + (manifest-transitive-entries manifest))) + (entries -> (sort entries ;order can cause hook reruns + (lambda (e1 e2) + (string< (manifest-entry-item e1) + (manifest-entry-item e2))))) (extras (if (null? (manifest-entries manifest)) (return '()) (mapm/accumulate-builds (lambda (hook) - (hook manifest + (hook entries system)) hooks)))) (define extra-inputs