From patchwork Thu Oct 29 23:09:55 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 24880 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 BBC9B27BBF5; Thu, 29 Oct 2020 23:11:33 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 3B7BF27BBF3 for ; Thu, 29 Oct 2020 23:11:32 +0000 (GMT) Received: from localhost ([::1]:45336 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH4t-0007if-Eg for patchwork@mira.cbaines.net; Thu, 29 Oct 2020 19:11:31 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:54730) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kYH4Q-0007QX-9s for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:43751) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kYH4Q-0006R6-0r for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kYH4P-0000Ou-SX for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#44321] [PATCH 1/6] guix build: 'package-with-source' no longer takes a 'store' parameter. References: <20201029230831.14456-1-ludo@gnu.org> In-Reply-To: <20201029230831.14456-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 29 Oct 2020 23:11:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 44321 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 44321@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 44321-submit@debbugs.gnu.org id=B44321.16040130131422 (code B ref 44321); Thu, 29 Oct 2020 23:11:01 +0000 Received: (at 44321) by debbugs.gnu.org; 29 Oct 2020 23:10:13 +0000 Received: from localhost ([127.0.0.1]:55283 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3d-0000Ms-9V for submit@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:13 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54478) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3c-0000MU-5y for 44321@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:12 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:49472) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH3W-0006A2-V0; Thu, 29 Oct 2020 19:10:06 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=50412 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1kYH3W-0007CN-8p; Thu, 29 Oct 2020 19:10:06 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 30 Oct 2020 00:09:55 +0100 Message-Id: <20201029231000.14568-1-ludo@gnu.org> X-Mailer: git-send-email 2.28.0 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: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/scripts/build.scm (): New record type. (download-to-store*): New variable. (compile-downloaded-file): New procedure. (package-with-source): Remove 'store' parameter. Use 'downloaded-file' instead of 'download-to-store'. (transform-package-source): Adjust accordingly. --- guix/scripts/build.scm | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index f4a8af035b..831ac8f798 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -45,6 +45,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -172,7 +173,25 @@ extensions." (else file-name))) -(define* (package-with-source store p uri #:optional version) + +;; Files to be downloaded. +(define-record-type + (downloaded-file uri recursive?) + downloaded-file? + (uri downloaded-file-uri) + (recursive? downloaded-file-recursive?)) + +(define download-to-store* + (store-lift download-to-store)) + +(define-gexp-compiler (compile-downloaded-file (file ) + system target) + "Download FILE and return the result as a store item." + (match file + (($ uri recursive?) + (download-to-store* uri #:recursive? recursive?)))) + +(define* (package-with-source p uri #:optional version) "Return a package based on P but with its source taken from URI. Extract the new package's version number from URI." (let ((base (tarball-base-name (basename uri)))) @@ -183,8 +202,7 @@ the new package's version number from URI." (package-version p))) ;; Use #:recursive? #t to allow for directories. - (source (download-to-store store uri - #:recursive? #t)) + (source (downloaded-file uri #t)) ;; Override the replacement, otherwise '--with-source' would ;; have no effect. @@ -226,7 +244,7 @@ matching URIs given in SOURCES." ((? package? p) (match (assoc-ref sources (package-name p)) ((version source) - (package-with-source store p source version)) + (package-with-source p source version)) (#f p))) (_ From patchwork Thu Oct 29 23:09:56 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 24877 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 A8FE727BBF2; Thu, 29 Oct 2020 23:11:13 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id F0CC027BBF4 for ; Thu, 29 Oct 2020 23:11:09 +0000 (GMT) Received: from localhost ([::1]:44716 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH4X-0007R6-4l for patchwork@mira.cbaines.net; Thu, 29 Oct 2020 19:11:09 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:54734) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kYH4Q-0007Qf-ND for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:43752) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kYH4Q-0006RD-EC for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kYH4Q-0000P2-9S for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#44321] [PATCH 2/6] guix build: Remove unnecessary (replacement #f). Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 29 Oct 2020 23:11:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 44321 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 44321@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 44321-submit@debbugs.gnu.org id=B44321.16040130181454 (code B ref 44321); Thu, 29 Oct 2020 23:11:02 +0000 Received: (at 44321) by debbugs.gnu.org; 29 Oct 2020 23:10:18 +0000 Received: from localhost ([127.0.0.1]:55289 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3h-0000NI-Ha for submit@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:17 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54484) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3c-0000MV-Ue for 44321@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:13 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:49473) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH3X-0006AC-OY; Thu, 29 Oct 2020 19:10:07 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=50412 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1kYH3X-0007CN-8g; Thu, 29 Oct 2020 19:10:07 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 30 Oct 2020 00:09:56 +0100 Message-Id: <20201029231000.14568-2-ludo@gnu.org> X-Mailer: git-send-email 2.28.0 In-Reply-To: <20201029231000.14568-1-ludo@gnu.org> References: <20201029231000.14568-1-ludo@gnu.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: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/scripts/build.scm (package-with-source): Remove 'replacement' field, which is innate since d5ec5ed7197d121130af6953378bcfd8929a9754. --- guix/scripts/build.scm | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 831ac8f798..65a125263d 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -202,11 +202,7 @@ the new package's version number from URI." (package-version p))) ;; Use #:recursive? #t to allow for directories. - (source (downloaded-file uri #t)) - - ;; Override the replacement, otherwise '--with-source' would - ;; have no effect. - (replacement #f))))) + (source (downloaded-file uri #t)))))) ;;; From patchwork Thu Oct 29 23:09:57 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 24878 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 B531127BBF2; Thu, 29 Oct 2020 23:11:15 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id ED46027BBF5 for ; Thu, 29 Oct 2020 23:11:11 +0000 (GMT) Received: from localhost ([::1]:44720 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH4Y-0007RG-Nd for patchwork@mira.cbaines.net; Thu, 29 Oct 2020 19:11:11 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:54736) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kYH4R-0007Qm-3v for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:43753) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kYH4Q-0006RL-QV for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kYH4Q-0000PA-MQ for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#44321] [PATCH 3/6] guix build: 'options->transformation' no longer takes a 'store' parameter. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 29 Oct 2020 23:11:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 44321 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 44321@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 44321-submit@debbugs.gnu.org id=B44321.16040130191466 (code B ref 44321); Thu, 29 Oct 2020 23:11:02 +0000 Received: (at 44321) by debbugs.gnu.org; 29 Oct 2020 23:10:19 +0000 Received: from localhost ([127.0.0.1]:55291 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3h-0000NP-Rl for submit@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:19 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54488) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3e-0000MZ-3F for 44321@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:15 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:49474) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH3Y-0006AL-TL; Thu, 29 Oct 2020 19:10:08 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=50412 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1kYH3Y-0007CN-29; Thu, 29 Oct 2020 19:10:08 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 30 Oct 2020 00:09:57 +0100 Message-Id: <20201029231000.14568-3-ludo@gnu.org> X-Mailer: git-send-email 2.28.0 In-Reply-To: <20201029231000.14568-1-ludo@gnu.org> References: <20201029231000.14568-1-ludo@gnu.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: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/scripts/build.scm (transform-package-source) (transform-package-inputs, transform-package-inputs/graft) (transform-package-source-branch, transform-package-source-commit) (transform-package-source-git-url, transform-package-toolchain) (transform-package-with-debug-info, transform-package-tests): Remove 'store' parameter. (options->transformation, options->derivations): Adjust accordingly. * guix/scripts/environment.scm (options/resolve-packages): Likewise. * guix/scripts/graph.scm (guix-graph): Likewise. * guix/scripts/pack.scm (guix-pack): Likewise. * guix/scripts/package.scm (transaction-upgrade-entry): Likewise. (process-actions): Likewise. * tests/scripts-build.scm ("options->transformation, no transformations"): Adjust test. ("options->transformation, with-source") ("options->transformation, with-source, replacement") ("options->transformation, with-source, with version") ("options->transformation, with-source, PKG=URI"): Use 'lower-object' to compute the store file name of the source. ("options->transformation, with-source, no matches"): Remove 'with-store' and adjust accordingly. ("options->transformation, with-input"): Likewise. ("options->transformation, with-graft"): Likewise. ("options->transformation, with-branch"): Likewise. ("options->transformation, with-commit"): Likewise. ("options->transformation, with-git-url"): Likewise. ("options->transformation, with-git-url + with-branch"): Likewise. ("options->transformation, with-c-toolchain"): Likewise. ("options->transformation, with-c-toolchain twice"): Likewise. ("options->transformation, with-c-toolchain, no effect"): Likewise. ("options->transformation, with-debug-info"): Likewise. ("options->transformation, without-tests"): Likewise. --- guix/scripts/build.scm | 25 ++-- guix/scripts/environment.scm | 2 +- guix/scripts/graph.scm | 8 +- guix/scripts/pack.scm | 4 +- guix/scripts/package.scm | 4 +- tests/scripts-build.scm | 261 +++++++++++++++++------------------ 6 files changed, 148 insertions(+), 156 deletions(-) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 65a125263d..4b86047587 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -233,7 +233,7 @@ matching URIs given in SOURCES." (string-drop uri (+ 1 index)))))))) sources)) - (lambda (store obj) + (lambda (obj) (let loop ((sources new-sources) (result '())) (match obj @@ -276,7 +276,7 @@ called \"guile\" must be replaced with a dependency on a version 2.1 of (lambda (old new) new))) (rewrite (package-input-rewriting/spec replacements))) - (lambda (store obj) + (lambda (obj) (if (package? obj) (rewrite obj) obj)))) @@ -292,7 +292,7 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (let* ((replacements (evaluate-replacement-specs replacement-specs set-replacement)) (rewrite (package-input-rewriting/spec replacements))) - (lambda (store obj) + (lambda (obj) (if (package? obj) (rewrite obj) obj)))) @@ -349,7 +349,7 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using (let* ((replacements (evaluate-git-replacement-specs replacement-specs replace)) (rewrite (package-input-rewriting/spec replacements))) - (lambda (store obj) + (lambda (obj) (if (package? obj) (rewrite obj) obj)))) @@ -377,7 +377,7 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using (let* ((replacements (evaluate-git-replacement-specs replacement-specs replace)) (rewrite (package-input-rewriting/spec replacements))) - (lambda (store obj) + (lambda (obj) (if (package? obj) (rewrite obj) obj)))) @@ -405,7 +405,7 @@ a checkout of the Git repository at the given URL." (define rewrite (package-input-rewriting/spec replacements)) - (lambda (store obj) + (lambda (obj) (if (package? obj) (rewrite obj) obj))) @@ -478,7 +478,7 @@ the equal sign." spec)))) replacement-specs)) - (lambda (store obj) + (lambda (obj) (if (package? obj) (or (any (match-lambda ((bottom . toolchain) @@ -516,7 +516,7 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field." (cons spec package-with-debug-info)) specs))) - (lambda (store obj) + (lambda (obj) (if (package? obj) (rewrite obj) obj))) @@ -535,7 +535,7 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field." (cons spec package-without-tests)) specs))) - (lambda (store obj) + (lambda (obj) (if (package? obj) (rewrite obj) obj))) @@ -646,7 +646,7 @@ derivation, etc.), applies the transformations specified by OPTS." applicable)) ,@(package-properties p))))) - (lambda (store obj) + (lambda (obj) (define (tagged-object new) (if (and (not (eq? obj new)) (package? new) (not (null? applicable))) @@ -656,7 +656,7 @@ derivation, etc.), applies the transformations specified by OPTS." (tagged-object (fold (match-lambda* (((name value transform) obj) - (let ((new (transform store obj))) + (let ((new (transform obj))) (when (eq? new obj) (warning (G_ "transformation '~a' had no effect on ~a~%") name @@ -1113,8 +1113,7 @@ build." (systems systems))) (define things-to-build - (map (cut transform store <>) - (options->things-to-build opts))) + (map transform (options->things-to-build opts))) (define (compute-derivation obj system) ;; Compute the derivation of OBJ for SYSTEM. diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 91ce2af9bb..4db6c5d2d7 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -320,7 +320,7 @@ for the corresponding packages." (manifest-entry-output e2)))) (define transform - (cut (options->transformation opts) store <>)) + (options->transformation opts)) (define* (package->manifest-entry* package #:optional (output "out")) (package->manifest-entry (transform package) output)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 0d11fc9795..6b2e60d7e2 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -582,11 +582,11 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (('argument . (? store-path? item)) item) (('argument . spec) - (transform store - (specification->package spec))) + (transform + (specification->package spec))) (('expression . exp) - (transform store - (read/eval-package-expression exp))) + (transform + (read/eval-package-expression exp))) (_ #f)) opts))) (run-with-store store diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index a5a70d5162..8a6aa2882b 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1116,9 +1116,9 @@ Create a bundle of PACKAGE.\n")) (let* ((transform (options->transformation opts)) (packages (map (match-lambda (((? package? package) output) - (list (transform store package) output)) + (list (transform package) output)) ((? package? package) - (list (transform store package) "out"))) + (list (transform package) "out"))) (reverse (filter-map maybe-package-argument opts)))) (manifests (filter-map (match-lambda diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ba62d98682..5599e26f5d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -223,7 +223,7 @@ non-zero relevance score." (($ name version output (? string? path)) (match (find-best-packages-by-name name #f) ((pkg . rest) - (let* ((pkg (transform store pkg)) + (let* ((pkg (transform pkg)) (candidate-version (package-version pkg))) (match (package-superseded pkg) ((? package? new) @@ -871,7 +871,7 @@ processed, #f otherwise." (define transform (options->transformation opts)) (define (transform-entry entry) - (let ((item (transform store (manifest-entry-item entry)))) + (let ((item (transform (manifest-entry-item entry)))) (manifest-entry-with-transformations (manifest-entry (inherit entry) diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index 3a49759567..d56e02b452 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -19,6 +19,7 @@ (define-module (test-scripts-build) #:use-module (guix tests) #:use-module (guix store) + #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix git-download) @@ -42,8 +43,7 @@ (test-assert "options->transformation, no transformations" (let ((p (dummy-package "foo")) (t (options->transformation '()))) - (with-store store - (eq? (t store p) p)))) + (eq? (t p) p))) (test-assert "options->transformation, with-source" ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should @@ -52,9 +52,11 @@ (s (search-path %load-path "guix.scm")) (t (options->transformation `((with-source . ,s))))) (with-store store - (let ((new (t store p))) + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) (and (not (eq? new p)) - (string=? (package-source new) + (string=? source (add-to-store store "guix.scm" #t "sha256" s))))))) @@ -64,12 +66,9 @@ (let* ((p (dummy-package "guix.scm" (replacement coreutils))) (s (search-path %load-path "guix.scm")) (t (options->transformation `((with-source . ,s))))) - (with-store store - (let ((new (t store p))) - (and (not (eq? new p)) - (string=? (package-source new) - (add-to-store store "guix.scm" #t "sha256" s)) - (not (package-replacement new))))))) + (let ((new (t p))) + (and (not (eq? new p)) + (not (package-replacement new)))))) (test-assert "options->transformation, with-source, with version" ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source @@ -82,11 +81,13 @@ (t (options->transformation `((with-source . ,f))))) (copy-file s f) (with-store store - (let ((new (t store p))) + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) (and (not (eq? new p)) (string=? (package-name new) (package-name p)) (string=? (package-version new) "42.0") - (string=? (package-source new) + (string=? source (add-to-store store (basename f) #t "sha256" f)))))))))) @@ -95,13 +96,12 @@ (let* ((p (dummy-package "foobar")) (s (search-path %load-path "guix.scm")) (t (options->transformation `((with-source . ,s))))) - (with-store store - (let* ((port (open-output-string)) - (new (parameterize ((guix-warning-port port)) - (t store p)))) - (and (eq? new p) - (string-contains (get-output-string port) - "had no effect")))))) + (let* ((port (open-output-string)) + (new (parameterize ((guix-warning-port port)) + (t p)))) + (and (eq? new p) + (string-contains (get-output-string port) + "had no effect"))))) (test-assert "options->transformation, with-source, PKG=URI" (let* ((p (dummy-package "foo")) @@ -109,12 +109,14 @@ (f (string-append "foo=" s)) (t (options->transformation `((with-source . ,f))))) (with-store store - (let ((new (t store p))) + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) (and (not (eq? new p)) (string=? (package-name new) (package-name p)) (string=? (package-version new) (package-version p)) - (string=? (package-source new) + (string=? source (add-to-store store (basename s) #t "sha256" s))))))) @@ -124,11 +126,13 @@ (f (string-append "foo@42.0=" s)) (t (options->transformation `((with-source . ,f))))) (with-store store - (let ((new (t store p))) + (let* ((new (t p)) + (source (run-with-store store + (lower-object (package-source new))))) (and (not (eq? new p)) (string=? (package-name new) (package-name p)) (string=? (package-version new) "42.0") - (string=? (package-source new) + (string=? source (add-to-store store (basename s) #t "sha256" s))))))) @@ -140,20 +144,19 @@ (native-inputs `(("x" ,grep))))))))) (t (options->transformation '((with-input . "coreutils=busybox") (with-input . "grep=findutils"))))) - (with-store store - (let ((new (t store p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2) ("baz" dep3)) - (and (string=? (package-full-name dep1) - (package-full-name busybox)) - (string=? (package-full-name dep2) - (package-full-name findutils)) - (string=? (package-name dep3) "chbouib") - (match (package-native-inputs dep3) - ((("x" dep)) - (string=? (package-full-name dep) - (package-full-name findutils)))))))))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2) ("baz" dep3)) + (and (string=? (package-full-name dep1) + (package-full-name busybox)) + (string=? (package-full-name dep2) + (package-full-name findutils)) + (string=? (package-name dep3) "chbouib") + (match (package-native-inputs dep3) + ((("x" dep)) + (string=? (package-full-name dep) + (package-full-name findutils))))))))))) (test-assert "options->transformation, with-graft" (let* ((p (dummy-package "guix.scm" @@ -161,23 +164,22 @@ ("bar" ,(dummy-package "chbouib" (native-inputs `(("x" ,grep))))))))) (t (options->transformation '((with-graft . "grep=findutils"))))) - (with-store store - (let ((new (t store p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (string=? (package-full-name (package-replacement dep1)) - (package-full-name findutils)) - (string=? (package-name dep2) "chbouib") - (match (package-native-inputs dep2) - ((("x" dep)) - (with-store store - (string=? (derivation-file-name - (package-derivation store findutils)) - (derivation-file-name - (package-derivation store dep)))))))))))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-full-name (package-replacement dep1)) + (package-full-name findutils)) + (string=? (package-name dep2) "chbouib") + (match (package-native-inputs dep2) + ((("x" dep)) + (with-store store + (string=? (derivation-file-name + (package-derivation store findutils)) + (derivation-file-name + (package-derivation store dep))))))))))))) (test-equal "options->transformation, with-branch" (git-checkout (url "https://example.org") @@ -193,15 +195,14 @@ (commit "cabba9e"))) (sha256 #f))))))))) (t (options->transformation '((with-branch . "chbouib=devel"))))) - (with-store store - (let ((new (t store p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (string=? (package-name dep2) "chbouib") - (package-source dep2))))))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-name dep2) "chbouib") + (package-source dep2)))))))) (test-equal "options->transformation, with-commit" (git-checkout (url "https://example.org") @@ -217,15 +218,14 @@ (commit "cabba9e"))) (sha256 #f))))))))) (t (options->transformation '((with-commit . "chbouib=abcdef"))))) - (with-store store - (let ((new (t store p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (string=? (package-name dep2) "chbouib") - (package-source dep2))))))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-name dep2) "chbouib") + (package-source dep2)))))))) (test-equal "options->transformation, with-git-url" (let ((source (git-checkout (url "https://example.org") @@ -236,17 +236,16 @@ ("bar" ,(dummy-package "chbouib" (native-inputs `(("x" ,grep))))))))) (t (options->transformation '((with-git-url . "grep=https://example.org"))))) - (with-store store - (let ((new (t store p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (string=? (package-name dep2) "chbouib") - (match (package-native-inputs dep2) - ((("x" dep3)) - (map package-source (list dep1 dep3)))))))))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (string=? (package-name dep2) "chbouib") + (match (package-native-inputs dep2) + ((("x" dep3)) + (map package-source (list dep1 dep3))))))))))) (test-equal "options->transformation, with-git-url + with-branch" ;; Combine the two options and make sure the 'with-branch' transformation @@ -263,16 +262,15 @@ (reverse '((with-git-url . "grep=https://example.org") (with-branch . "grep=BRANCH")))))) - (with-store store - (let ((new (t store p))) - (and (not (eq? new p)) - (match (package-inputs new) - ((("foo" dep1) ("bar" dep2)) - (and (string=? (package-name dep1) "grep") - (string=? (package-name dep2) "chbouib") - (match (package-native-inputs dep2) - ((("x" dep3)) - (map package-source (list dep1 dep3)))))))))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-name dep1) "grep") + (string=? (package-name dep2) "chbouib") + (match (package-native-inputs dep2) + ((("x" dep3)) + (map package-source (list dep1 dep3))))))))))) (define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain")) "Return true if P depends on TOOLCHAIN instead of the default tool chain." @@ -302,21 +300,20 @@ ;; Here we check that the transformation applies to DEP0 and all its ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on. - (with-store store - (let ((new (t store p))) - (and (depends-on-toolchain? new "gcc-toolchain") - (match (bag-build-inputs (package->bag new)) - ((("foo" dep0) ("bar" dep1) _ ...) - (and (depends-on-toolchain? dep1 "gcc-toolchain") - (not (depends-on-toolchain? dep0 "gcc-toolchain")) - (string=? (package-full-name dep0) - (package-full-name grep)) - (match (bag-build-inputs (package->bag dep1)) - ((("x" dep) _ ...) - (and (depends-on-toolchain? dep "gcc-toolchain") - (match (bag-build-inputs (package->bag dep)) - ((("y" dep) _ ...) ;this one is unchanged - (eq? dep grep)))))))))))))) + (let ((new (t p))) + (and (depends-on-toolchain? new "gcc-toolchain") + (match (bag-build-inputs (package->bag new)) + ((("foo" dep0) ("bar" dep1) _ ...) + (and (depends-on-toolchain? dep1 "gcc-toolchain") + (not (depends-on-toolchain? dep0 "gcc-toolchain")) + (string=? (package-full-name dep0) + (package-full-name grep)) + (match (bag-build-inputs (package->bag dep1)) + ((("x" dep) _ ...) + (and (depends-on-toolchain? dep "gcc-toolchain") + (match (bag-build-inputs (package->bag dep)) + ((("y" dep) _ ...) ;this one is unchanged + (eq? dep grep))))))))))))) (test-equal "options->transformation, with-c-toolchain twice" (package-full-name grep) @@ -330,23 +327,21 @@ (t (options->transformation '((with-c-toolchain . "chbouib=clang-toolchain") (with-c-toolchain . "stuff=clang-toolchain"))))) - (with-store store - (let ((new (t store p))) - (and (depends-on-toolchain? new "clang-toolchain") - (match (bag-build-inputs (package->bag new)) - ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...) - (and (depends-on-toolchain? dep0 "clang-toolchain") - (depends-on-toolchain? dep1 "clang-toolchain") - (not (depends-on-toolchain? dep2 "clang-toolchain")) - (package-full-name dep2))))))))) + (let ((new (t p))) + (and (depends-on-toolchain? new "clang-toolchain") + (match (bag-build-inputs (package->bag new)) + ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...) + (and (depends-on-toolchain? dep0 "clang-toolchain") + (depends-on-toolchain? dep1 "clang-toolchain") + (not (depends-on-toolchain? dep2 "clang-toolchain")) + (package-full-name dep2)))))))) (test-assert "options->transformation, with-c-toolchain, no effect" (let ((p (dummy-package "thingie")) (t (options->transformation '((with-c-toolchain . "does-not-exist=gcc-toolchain"))))) ;; When it has no effect, '--with-c-toolchain' returns P. - (with-store store - (eq? (t store p) p)))) + (eq? (t p) p))) (test-equal "options->transformation, with-debug-info" '(#:strip-binaries? #f) @@ -357,13 +352,12 @@ ("bar" ,grep))))) (t (options->transformation '((with-debug-info . "chbouib"))))) - (with-store store - (let ((new (t store p))) - (match (package-inputs new) - ((("foo" dep0) ("bar" dep1)) - (and (string=? (package-full-name dep1) - (package-full-name grep)) - (package-arguments (package-replacement dep0))))))))) + (let ((new (t p))) + (match (package-inputs new) + ((("foo" dep0) ("bar" dep1)) + (and (string=? (package-full-name dep1) + (package-full-name grep)) + (package-arguments (package-replacement dep0)))))))) (test-assert "options->transformation, without-tests" (let* ((dep (dummy-package "dep")) @@ -371,14 +365,13 @@ (inputs `(("dep" ,dep))))) (t (options->transformation '((without-tests . "dep") (without-tests . "tar"))))) - (with-store store - (let ((new (t store p))) - (match (bag-direct-inputs (package->bag new)) - ((("dep" dep) ("tar" tar) _ ...) - ;; TODO: Check whether TAR has #:tests? #f when transformations - ;; apply to implicit inputs. - (equal? (package-arguments dep) - '(#:tests? #f)))))))) + (let ((new (t p))) + (match (bag-direct-inputs (package->bag new)) + ((("dep" dep) ("tar" tar) _ ...) + ;; TODO: Check whether TAR has #:tests? #f when transformations + ;; apply to implicit inputs. + (equal? (package-arguments dep) + '(#:tests? #f))))))) (test-end) From patchwork Thu Oct 29 23:09:58 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 24882 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 9C0D927BBF2; Thu, 29 Oct 2020 23:11:38 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id BDF3F27BBF4 for ; Thu, 29 Oct 2020 23:11:29 +0000 (GMT) Received: from localhost ([::1]:44970 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH4q-0007YX-SP for patchwork@mira.cbaines.net; Thu, 29 Oct 2020 19:11:28 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:54742) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kYH4R-0007R0-Tj for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:43755) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kYH4R-0006RT-Ju for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kYH4R-0000PR-FP for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#44321] [PATCH 4/6] guix build: Move transformation options to (guix transformations). Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 29 Oct 2020 23:11:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 44321 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 44321@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 44321-submit@debbugs.gnu.org id=B44321.16040130271491 (code B ref 44321); Thu, 29 Oct 2020 23:11:03 +0000 Received: (at 44321) by debbugs.gnu.org; 29 Oct 2020 23:10:27 +0000 Received: from localhost ([127.0.0.1]:55295 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3p-0000Np-IX for submit@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:27 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54492) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3f-0000Mb-52 for 44321@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:17 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:49475) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH3Z-0006AQ-V5; Thu, 29 Oct 2020 19:10:09 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=50412 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1kYH3Z-0007CN-78; Thu, 29 Oct 2020 19:10:09 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 30 Oct 2020 00:09:58 +0100 Message-Id: <20201029231000.14568-4-ludo@gnu.org> X-Mailer: git-send-email 2.28.0 In-Reply-To: <20201029231000.14568-1-ludo@gnu.org> References: <20201029231000.14568-1-ludo@gnu.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: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/transformations.scm: New file. * tests/scripts-build.scm: Rename to... * tests/transformations.scm: ... this. * Makefile.am (MODULES): Add 'guix/transformations.scm'. (SCM_TESTS): Adjust to rename. * guix/scripts/build.scm (numeric-extension?) (tarball-base-name, , download-to-store*) (compile-downloaded-file, package-with-source) (transform-package-source, evaluate-replacement-specs) (transform-package-inputs, transform-package-inputs/graft) (%not-equal, package-git-url, evaluate-git-replacement-specs) (transform-package-source-branch, transform-package-source-commit) (transform-package-source-git-url, package-dependents/spec) (package-toolchain-rewriting, transform-package-toolchain) (transform-package-with-debug-info, transform-package-tests) (%transformations, transformation-procedure, %transformation-options) (show-transformation-options-help, options->transformation) (package-transformations): Move to (guix transformations). * guix/scripts/environment.scm: Adjust accordingly. * guix/scripts/graph.scm: Likewise. * guix/scripts/install.scm: Likewise. * guix/scripts/pack.scm: Likewise. * guix/scripts/package.scm: Likewise. * guix/scripts/upgrade.scm: Likewise. --- Makefile.am | 3 +- guix/scripts/build.scm | 553 +--------------- guix/scripts/environment.scm | 1 + guix/scripts/graph.scm | 5 +- guix/scripts/install.scm | 1 + guix/scripts/pack.scm | 1 + guix/scripts/package.scm | 1 + guix/scripts/upgrade.scm | 1 + guix/transformations.scm | 610 ++++++++++++++++++ ...{scripts-build.scm => transformations.scm} | 6 +- 10 files changed, 624 insertions(+), 558 deletions(-) create mode 100644 guix/transformations.scm rename tests/{scripts-build.scm => transformations.scm} (99%) diff --git a/Makefile.am b/Makefile.am index f3eb681a2b..e7053ee4f4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -105,6 +105,7 @@ MODULES = \ guix/derivations.scm \ guix/grafts.scm \ guix/repl.scm \ + guix/transformations.scm \ guix/inferior.scm \ guix/describe.scm \ guix/quirks.scm \ @@ -456,7 +457,6 @@ SCM_TESTS = \ tests/pypi.scm \ tests/records.scm \ tests/scripts.scm \ - tests/scripts-build.scm \ tests/search-paths.scm \ tests/services.scm \ tests/services/linux.scm \ @@ -473,6 +473,7 @@ SCM_TESTS = \ tests/syscalls.scm \ tests/system.scm \ tests/texlive.scm \ + tests/transformations.scm \ tests/ui.scm \ tests/union.scm \ tests/upstream.scm \ diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 4b86047587..e9de97c881 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -31,11 +31,6 @@ #:use-module (guix utils) - ;; Use the procedure that destructures "NAME-VERSION" forms. - #:use-module ((guix build utils) - #:select ((package-name->name+version - . hyphen-package-name->name+version))) - #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix profiles) @@ -52,21 +47,15 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (gnu packages) - #:autoload (guix download) (download-to-store) - #:autoload (guix git-download) (git-reference? git-reference-url) - #:autoload (guix git) (git-checkout git-checkout? git-checkout-url) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) + #:use-module (guix transformations) #:export (%standard-build-options set-build-options-from-command-line set-build-options-from-command-line* show-build-options-help - %transformation-options - options->transformation - manifest-entry-with-transformations - guix-build register-root register-root*)) @@ -151,546 +140,6 @@ found. Return #f if no build log was found." (define register-root* (store-lift register-root)) -(define (numeric-extension? file-name) - "Return true if FILE-NAME ends with digits." - (string-every char-set:hex-digit (file-extension file-name))) - -(define (tarball-base-name file-name) - "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar -extensions." - ;; TODO: Factorize. - (cond ((not (file-extension file-name)) - file-name) - ((numeric-extension? file-name) - file-name) - ((string=? (file-extension file-name) "tar") - (file-sans-extension file-name)) - ((file-extension file-name) - => - (match-lambda - ("scm" file-name) - (else (tarball-base-name (file-sans-extension file-name))))) - (else - file-name))) - - -;; Files to be downloaded. -(define-record-type - (downloaded-file uri recursive?) - downloaded-file? - (uri downloaded-file-uri) - (recursive? downloaded-file-recursive?)) - -(define download-to-store* - (store-lift download-to-store)) - -(define-gexp-compiler (compile-downloaded-file (file ) - system target) - "Download FILE and return the result as a store item." - (match file - (($ uri recursive?) - (download-to-store* uri #:recursive? recursive?)))) - -(define* (package-with-source p uri #:optional version) - "Return a package based on P but with its source taken from URI. Extract -the new package's version number from URI." - (let ((base (tarball-base-name (basename uri)))) - (let-values (((_ version*) - (hyphen-package-name->name+version base))) - (package (inherit p) - (version (or version version* - (package-version p))) - - ;; Use #:recursive? #t to allow for directories. - (source (downloaded-file uri #t)))))) - - -;;; -;;; Transformations. -;;; - -(define (transform-package-source sources) - "Return a transformation procedure that replaces package sources with the -matching URIs given in SOURCES." - (define new-sources - (map (lambda (uri) - (match (string-index uri #\=) - (#f - ;; Determine the package name and version from URI. - (call-with-values - (lambda () - (hyphen-package-name->name+version - (tarball-base-name (basename uri)))) - (lambda (name version) - (list name version uri)))) - (index - ;; What's before INDEX is a "PKG@VER" or "PKG" spec. - (call-with-values - (lambda () - (package-name->name+version (string-take uri index))) - (lambda (name version) - (list name version - (string-drop uri (+ 1 index)))))))) - sources)) - - (lambda (obj) - (let loop ((sources new-sources) - (result '())) - (match obj - ((? package? p) - (match (assoc-ref sources (package-name p)) - ((version source) - (package-with-source p source version)) - (#f - p))) - (_ - obj))))) - -(define (evaluate-replacement-specs specs proc) - "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list -of package spec/procedure pairs as expected by 'package-input-rewriting/spec'. -PROC is called with the package to be replaced and its replacement according -to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a -package it refers to could not be found." - (define not-equal - (char-set-complement (char-set #\=))) - - (map (lambda (spec) - (match (string-tokenize spec not-equal) - ((spec new) - (cons spec - (let ((new (specification->package new))) - (lambda (old) - (proc old new))))) - (x - (leave (G_ "invalid replacement specification: ~s~%") spec)))) - specs)) - -(define (transform-package-inputs replacement-specs) - "Return a procedure that, when passed a package, replaces its direct -dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of -strings like \"guile=guile@2.1\" meaning that, any dependency on a package -called \"guile\" must be replaced with a dependency on a version 2.1 of -\"guile\"." - (let* ((replacements (evaluate-replacement-specs replacement-specs - (lambda (old new) - new))) - (rewrite (package-input-rewriting/spec replacements))) - (lambda (obj) - (if (package? obj) - (rewrite obj) - obj)))) - -(define (transform-package-inputs/graft replacement-specs) - "Return a procedure that, when passed a package, replaces its direct -dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of -strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the -current 'gnutls' package, after which version 3.5.4 is grafted onto them." - (define (set-replacement old new) - (package (inherit old) (replacement new))) - - (let* ((replacements (evaluate-replacement-specs replacement-specs - set-replacement)) - (rewrite (package-input-rewriting/spec replacements))) - (lambda (obj) - (if (package? obj) - (rewrite obj) - obj)))) - -(define %not-equal - (char-set-complement (char-set #\=))) - -(define (package-git-url package) - "Return the URL of the Git repository for package, or raise an error if -the source of PACKAGE is not fetched from a Git repository." - (let ((source (package-source package))) - (cond ((and (origin? source) - (git-reference? (origin-uri source))) - (git-reference-url (origin-uri source))) - ((git-checkout? source) - (git-checkout-url source)) - (else - (leave (G_ "the source of ~a is not a Git reference~%") - (package-full-name package)))))) - -(define (evaluate-git-replacement-specs specs proc) - "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list -of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the -replacement package. Raise an error if an element of SPECS uses invalid -syntax, or if a package it refers to could not be found." - (map (lambda (spec) - (match (string-tokenize spec %not-equal) - ((spec branch-or-commit) - (define (replace old) - (let* ((source (package-source old)) - (url (package-git-url old))) - (proc old url branch-or-commit))) - - (cons spec replace)) - (x - (leave (G_ "invalid replacement specification: ~s~%") spec)))) - specs)) - -(define (transform-package-source-branch replacement-specs) - "Return a procedure that, when passed a package, replaces its direct -dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of -strings like \"guile-next=stable-3.0\" meaning that packages are built using -'guile-next' from the latest commit on its 'stable-3.0' branch." - (define (replace old url branch) - (package - (inherit old) - (version (string-append "git." (string-map (match-lambda - (#\/ #\-) - (chr chr)) - branch))) - (source (git-checkout (url url) (branch branch) - (recursive? #t))))) - - (let* ((replacements (evaluate-git-replacement-specs replacement-specs - replace)) - (rewrite (package-input-rewriting/spec replacements))) - (lambda (obj) - (if (package? obj) - (rewrite obj) - obj)))) - -(define (transform-package-source-commit replacement-specs) - "Return a procedure that, when passed a package, replaces its direct -dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of -strings like \"guile-next=cabba9e\" meaning that packages are built using -'guile-next' from commit 'cabba9e'." - (define (replace old url commit) - (package - (inherit old) - (version (if (and (> (string-length commit) 1) - (string-prefix? "v" commit) - (char-set-contains? char-set:digit - (string-ref commit 1))) - (string-drop commit 1) ;looks like a tag like "v1.0" - (string-append "git." - (if (< (string-length commit) 7) - commit - (string-take commit 7))))) - (source (git-checkout (url url) (commit commit) - (recursive? #t))))) - - (let* ((replacements (evaluate-git-replacement-specs replacement-specs - replace)) - (rewrite (package-input-rewriting/spec replacements))) - (lambda (obj) - (if (package? obj) - (rewrite obj) - obj)))) - -(define (transform-package-source-git-url replacement-specs) - "Return a procedure that, when passed a package, replaces its dependencies -according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like -\"guile-json=https://gitthing.com/…\" meaning that packages are built using -a checkout of the Git repository at the given URL." - (define replacements - (map (lambda (spec) - (match (string-tokenize spec %not-equal) - ((spec url) - (cons spec - (lambda (old) - (package - (inherit old) - (source (git-checkout (url url) - (recursive? #t))))))) - (_ - (leave (G_ "~a: invalid Git URL replacement specification~%") - spec)))) - replacement-specs)) - - (define rewrite - (package-input-rewriting/spec replacements)) - - (lambda (obj) - (if (package? obj) - (rewrite obj) - obj))) - -(define (package-dependents/spec top bottom) - "Return the list of dependents of BOTTOM, a spec string, that are also -dependencies of TOP, a package." - (define-values (name version) - (package-name->name+version bottom)) - - (define dependent? - (mlambda (p) - (and (package? p) - (or (and (string=? name (package-name p)) - (or (not version) - (version-prefix? version (package-version p)))) - (match (bag-direct-inputs (package->bag p)) - (((labels dependencies . _) ...) - (any dependent? dependencies))))))) - - (filter dependent? (package-closure (list top)))) - -(define (package-toolchain-rewriting p bottom toolchain) - "Return a procedure that, when passed a package that's either BOTTOM or one -of its dependents up to P so, changes it so it is built with TOOLCHAIN. -TOOLCHAIN must be an input list." - (define rewriting-property - (gensym " package-toolchain-rewriting")) - - (match (package-dependents/spec p bottom) - (() ;P does not depend on BOTTOM - identity) - (set - ;; SET is the list of packages "between" P and BOTTOM (included) whose - ;; toolchain needs to be changed. - (package-mapping (lambda (p) - (if (or (assq rewriting-property - (package-properties p)) - (not (memq p set))) - p - (let ((p (package-with-c-toolchain p toolchain))) - (package/inherit p - (properties `((,rewriting-property . #t) - ,@(package-properties p))))))) - (lambda (p) - (or (assq rewriting-property (package-properties p)) - (not (memq p set)))) - #:deep? #t)))) - -(define (transform-package-toolchain replacement-specs) - "Return a procedure that, when passed a package, changes its toolchain or -that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is -a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to -the left of the equal sign must be built with the toolchain to the right of -the equal sign." - (define split-on-commas - (cute string-tokenize <> (char-set-complement (char-set #\,)))) - - (define (specification->input spec) - (let ((package (specification->package spec))) - (list (package-name package) package))) - - (define replacements - (map (lambda (spec) - (match (string-tokenize spec %not-equal) - ((spec (= split-on-commas toolchain)) - (cons spec (map specification->input toolchain))) - (_ - (leave (G_ "~a: invalid toolchain replacement specification~%") - spec)))) - replacement-specs)) - - (lambda (obj) - (if (package? obj) - (or (any (match-lambda - ((bottom . toolchain) - ((package-toolchain-rewriting obj bottom toolchain) obj))) - replacements) - obj) - obj))) - -(define (transform-package-with-debug-info specs) - "Return a procedure that, when passed a package, set its 'replacement' field -to the same package but with #:strip-binaries? #f in its 'arguments' field." - (define (non-stripped p) - (package - (inherit p) - (arguments - (substitute-keyword-arguments (package-arguments p) - ((#:strip-binaries? _ #f) #f))))) - - (define (package-with-debug-info p) - (if (member "debug" (package-outputs p)) - p - (let loop ((p p)) - (match (package-replacement p) - (#f - (package - (inherit p) - (replacement (non-stripped p)))) - (next - (package - (inherit p) - (replacement (loop next)))))))) - - (define rewrite - (package-input-rewriting/spec (map (lambda (spec) - (cons spec package-with-debug-info)) - specs))) - - (lambda (obj) - (if (package? obj) - (rewrite obj) - obj))) - -(define (transform-package-tests specs) - "Return a procedure that, when passed a package, sets #:tests? #f in its -'arguments' field." - (define (package-without-tests p) - (package/inherit p - (arguments - (substitute-keyword-arguments (package-arguments p) - ((#:tests? _ #f) #f))))) - - (define rewrite - (package-input-rewriting/spec (map (lambda (spec) - (cons spec package-without-tests)) - specs))) - - (lambda (obj) - (if (package? obj) - (rewrite obj) - obj))) - -(define %transformations - ;; Transformations that can be applied to things to build. The car is the - ;; key used in the option alist, and the cdr is the transformation - ;; procedure; it is called with two arguments: the store, and a list of - ;; things to build. - `((with-source . ,transform-package-source) - (with-input . ,transform-package-inputs) - (with-graft . ,transform-package-inputs/graft) - (with-branch . ,transform-package-source-branch) - (with-commit . ,transform-package-source-commit) - (with-git-url . ,transform-package-source-git-url) - (with-c-toolchain . ,transform-package-toolchain) - (with-debug-info . ,transform-package-with-debug-info) - (without-tests . ,transform-package-tests))) - -(define (transformation-procedure key) - "Return the transformation procedure associated with KEY, a symbol such as -'with-source', or #f if there is none." - (any (match-lambda - ((k . proc) - (and (eq? k key) proc))) - %transformations)) - -(define %transformation-options - ;; The command-line interface to the above transformations. - (let ((parser (lambda (symbol) - (lambda (opt name arg result . rest) - (apply values - (alist-cons symbol arg result) - rest))))) - (list (option '("with-source") #t #f - (parser 'with-source)) - (option '("with-input") #t #f - (parser 'with-input)) - (option '("with-graft") #t #f - (parser 'with-graft)) - (option '("with-branch") #t #f - (parser 'with-branch)) - (option '("with-commit") #t #f - (parser 'with-commit)) - (option '("with-git-url") #t #f - (parser 'with-git-url)) - (option '("with-c-toolchain") #t #f - (parser 'with-c-toolchain)) - (option '("with-debug-info") #t #f - (parser 'with-debug-info)) - (option '("without-tests") #t #f - (parser 'without-tests))))) - -(define (show-transformation-options-help) - (display (G_ " - --with-source=[PACKAGE=]SOURCE - use SOURCE when building the corresponding package")) - (display (G_ " - --with-input=PACKAGE=REPLACEMENT - replace dependency PACKAGE by REPLACEMENT")) - (display (G_ " - --with-graft=PACKAGE=REPLACEMENT - graft REPLACEMENT on packages that refer to PACKAGE")) - (display (G_ " - --with-branch=PACKAGE=BRANCH - build PACKAGE from the latest commit of BRANCH")) - (display (G_ " - --with-commit=PACKAGE=COMMIT - build PACKAGE from COMMIT")) - (display (G_ " - --with-git-url=PACKAGE=URL - build PACKAGE from the repository at URL")) - (display (G_ " - --with-c-toolchain=PACKAGE=TOOLCHAIN - build PACKAGE and its dependents with TOOLCHAIN")) - (display (G_ " - --with-debug-info=PACKAGE - build PACKAGE and preserve its debug info")) - (display (G_ " - --without-tests=PACKAGE - build PACKAGE without running its tests"))) - - -(define (options->transformation opts) - "Return a procedure that, when passed an object to build (package, -derivation, etc.), applies the transformations specified by OPTS." - (define applicable - ;; List of applicable transformations as symbol/procedure pairs in the - ;; order in which they appear on the command line. - (filter-map (match-lambda - ((key . value) - (match (transformation-procedure key) - (#f - #f) - (transform - ;; XXX: We used to pass TRANSFORM a list of several - ;; arguments, but we now pass only one, assuming that - ;; transform composes well. - (list key value (transform (list value))))))) - (reverse opts))) - - (define (package-with-transformation-properties p) - (package/inherit p - (properties `((transformations - . ,(map (match-lambda - ((key value _) - (cons key value))) - applicable)) - ,@(package-properties p))))) - - (lambda (obj) - (define (tagged-object new) - (if (and (not (eq? obj new)) - (package? new) (not (null? applicable))) - (package-with-transformation-properties new) - new)) - - (tagged-object - (fold (match-lambda* - (((name value transform) obj) - (let ((new (transform obj))) - (when (eq? new obj) - (warning (G_ "transformation '~a' had no effect on ~a~%") - name - (if (package? obj) - (package-full-name obj) - obj))) - new))) - obj - applicable)))) - -(define (package-transformations package) - "Return the transformations applied to PACKAGE according to its properties." - (match (assq-ref (package-properties package) 'transformations) - (#f '()) - (transformations transformations))) - -(define (manifest-entry-with-transformations entry) - "Return ENTRY with an additional 'transformations' property if it's not -already there." - (let ((properties (manifest-entry-properties entry))) - (if (assq 'transformations properties) - entry - (let ((item (manifest-entry-item entry))) - (manifest-entry - (inherit entry) - (properties - (match (and (package? item) - (package-transformations item)) - ((or #f '()) - properties) - (transformations - `((transformations . ,transformations) - ,@properties))))))))) - ;;; ;;; Standard command-line build options. diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 4db6c5d2d7..2328df98b8 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -32,6 +32,7 @@ #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (gnu build linux-container) #:use-module (gnu build accounts) #:use-module ((guix build syscalls) #:select (set-network-interface-up)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 6b2e60d7e2..6874904deb 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -34,10 +34,11 @@ #:use-module (guix sets) #:use-module ((guix diagnostics) #:select (location-file formatted-message)) - #:use-module ((guix scripts build) + #:use-module ((guix transformations) #:select (options->transformation - %standard-build-options %transformation-options)) + #:use-module ((guix scripts build) + #:select (%standard-build-options)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm index 5aafe3bd6d..82f5875dd1 100644 --- a/guix/scripts/install.scm +++ b/guix/scripts/install.scm @@ -20,6 +20,7 @@ #:use-module (guix ui) #:use-module (guix scripts package) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (guix scripts) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 8a6aa2882b..2e4daa469f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -42,6 +42,7 @@ #:use-module (guix search-paths) #:use-module (guix build-system gnu) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module ((guix self) #:select (make-config.scm)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5599e26f5d..eb2e67a0de 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -41,6 +41,7 @@ #:use-module (guix config) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (guix describe) #:autoload (guix store roots) (gc-roots user-owned?) #:use-module ((guix build utils) diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm index c4527d56d9..1ee8937acf 100644 --- a/guix/scripts/upgrade.scm +++ b/guix/scripts/upgrade.scm @@ -21,6 +21,7 @@ #:use-module (guix ui) #:use-module (guix scripts package) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (guix scripts) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) diff --git a/guix/transformations.scm b/guix/transformations.scm new file mode 100644 index 0000000000..126a9a69d3 --- /dev/null +++ b/guix/transformations.scm @@ -0,0 +1,610 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix transformations) + #:use-module (guix i18n) + #:use-module (guix store) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (guix diagnostics) + #:autoload (guix download) (download-to-store) + #:autoload (guix git-download) (git-reference? git-reference-url) + #:autoload (guix git) (git-checkout git-checkout? git-checkout-url) + #:use-module (guix utils) + #:use-module (guix memoization) + #:use-module (guix gexp) + + ;; Use the procedure that destructures "NAME-VERSION" forms. + #:use-module ((guix build utils) + #:select ((package-name->name+version + . hyphen-package-name->name+version))) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (options->transformation + manifest-entry-with-transformations + + show-transformation-options-help + %transformation-options)) + +;;; Commentary: +;;; +;;; This module implements "package transformation options"---tools for +;;; package graph rewriting. It contains the graph rewriting logic, but also +;;; the tip of its user interface: command-line option handling. +;;; +;;; Code: + +(module-autoload! (current-module) '(gnu packages) + '(specification->package)) + +(define (numeric-extension? file-name) + "Return true if FILE-NAME ends with digits." + (string-every char-set:hex-digit (file-extension file-name))) + +(define (tarball-base-name file-name) + "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar +extensions." + ;; TODO: Factorize. + (cond ((not (file-extension file-name)) + file-name) + ((numeric-extension? file-name) + file-name) + ((string=? (file-extension file-name) "tar") + (file-sans-extension file-name)) + ((file-extension file-name) + => + (match-lambda + ("scm" file-name) + (_ (tarball-base-name (file-sans-extension file-name))))) + (else + file-name))) + + +;; Files to be downloaded. +(define-record-type + (downloaded-file uri recursive?) + downloaded-file? + (uri downloaded-file-uri) + (recursive? downloaded-file-recursive?)) + +(define download-to-store* + (store-lift download-to-store)) + +(define-gexp-compiler (compile-downloaded-file (file ) + system target) + "Download FILE and return the result as a store item." + (match file + (($ uri recursive?) + (download-to-store* uri #:recursive? recursive?)))) + +(define* (package-with-source p uri #:optional version) + "Return a package based on P but with its source taken from URI. Extract +the new package's version number from URI." + (let ((base (tarball-base-name (basename uri)))) + (let-values (((_ version*) + (hyphen-package-name->name+version base))) + (package (inherit p) + (version (or version version* + (package-version p))) + + ;; Use #:recursive? #t to allow for directories. + (source (downloaded-file uri #t)))))) + + +;;; +;;; Transformations. +;;; + +(define (transform-package-source sources) + "Return a transformation procedure that replaces package sources with the +matching URIs given in SOURCES." + (define new-sources + (map (lambda (uri) + (match (string-index uri #\=) + (#f + ;; Determine the package name and version from URI. + (call-with-values + (lambda () + (hyphen-package-name->name+version + (tarball-base-name (basename uri)))) + (lambda (name version) + (list name version uri)))) + (index + ;; What's before INDEX is a "PKG@VER" or "PKG" spec. + (call-with-values + (lambda () + (package-name->name+version (string-take uri index))) + (lambda (name version) + (list name version + (string-drop uri (+ 1 index)))))))) + sources)) + + (lambda (obj) + (let loop ((sources new-sources) + (result '())) + (match obj + ((? package? p) + (match (assoc-ref sources (package-name p)) + ((version source) + (package-with-source p source version)) + (#f + p))) + (_ + obj))))) + +(define (evaluate-replacement-specs specs proc) + "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list +of package spec/procedure pairs as expected by 'package-input-rewriting/spec'. +PROC is called with the package to be replaced and its replacement according +to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a +package it refers to could not be found." + (define not-equal + (char-set-complement (char-set #\=))) + + (map (lambda (spec) + (match (string-tokenize spec not-equal) + ((spec new) + (cons spec + (let ((new (specification->package new))) + (lambda (old) + (proc old new))))) + (x + (leave (G_ "invalid replacement specification: ~s~%") spec)))) + specs)) + +(define (transform-package-inputs replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile=guile@2.1\" meaning that, any dependency on a package +called \"guile\" must be replaced with a dependency on a version 2.1 of +\"guile\"." + (let* ((replacements (evaluate-replacement-specs replacement-specs + (lambda (old new) + new))) + (rewrite (package-input-rewriting/spec replacements))) + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj)))) + +(define (transform-package-inputs/graft replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the +current 'gnutls' package, after which version 3.5.4 is grafted onto them." + (define (set-replacement old new) + (package (inherit old) (replacement new))) + + (let* ((replacements (evaluate-replacement-specs replacement-specs + set-replacement)) + (rewrite (package-input-rewriting/spec replacements))) + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj)))) + +(define %not-equal + (char-set-complement (char-set #\=))) + +(define (package-git-url package) + "Return the URL of the Git repository for package, or raise an error if +the source of PACKAGE is not fetched from a Git repository." + (let ((source (package-source package))) + (cond ((and (origin? source) + (git-reference? (origin-uri source))) + (git-reference-url (origin-uri source))) + ((git-checkout? source) + (git-checkout-url source)) + (else + (leave (G_ "the source of ~a is not a Git reference~%") + (package-full-name package)))))) + +(define (evaluate-git-replacement-specs specs proc) + "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list +of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the +replacement package. Raise an error if an element of SPECS uses invalid +syntax, or if a package it refers to could not be found." + (map (lambda (spec) + (match (string-tokenize spec %not-equal) + ((spec branch-or-commit) + (define (replace old) + (let* ((source (package-source old)) + (url (package-git-url old))) + (proc old url branch-or-commit))) + + (cons spec replace)) + (_ + (leave (G_ "invalid replacement specification: ~s~%") spec)))) + specs)) + +(define (transform-package-source-branch replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=stable-3.0\" meaning that packages are built using +'guile-next' from the latest commit on its 'stable-3.0' branch." + (define (replace old url branch) + (package + (inherit old) + (version (string-append "git." (string-map (match-lambda + (#\/ #\-) + (chr chr)) + branch))) + (source (git-checkout (url url) (branch branch) + (recursive? #t))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) + (rewrite (package-input-rewriting/spec replacements))) + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj)))) + +(define (transform-package-source-commit replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=cabba9e\" meaning that packages are built using +'guile-next' from commit 'cabba9e'." + (define (replace old url commit) + (package + (inherit old) + (version (if (and (> (string-length commit) 1) + (string-prefix? "v" commit) + (char-set-contains? char-set:digit + (string-ref commit 1))) + (string-drop commit 1) ;looks like a tag like "v1.0" + (string-append "git." + (if (< (string-length commit) 7) + commit + (string-take commit 7))))) + (source (git-checkout (url url) (commit commit) + (recursive? #t))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) + (rewrite (package-input-rewriting/spec replacements))) + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj)))) + +(define (transform-package-source-git-url replacement-specs) + "Return a procedure that, when passed a package, replaces its dependencies +according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like +\"guile-json=https://gitthing.com/…\" meaning that packages are built using +a checkout of the Git repository at the given URL." + (define replacements + (map (lambda (spec) + (match (string-tokenize spec %not-equal) + ((spec url) + (cons spec + (lambda (old) + (package + (inherit old) + (source (git-checkout (url url) + (recursive? #t))))))) + (_ + (leave (G_ "~a: invalid Git URL replacement specification~%") + spec)))) + replacement-specs)) + + (define rewrite + (package-input-rewriting/spec replacements)) + + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj))) + +(define (package-dependents/spec top bottom) + "Return the list of dependents of BOTTOM, a spec string, that are also +dependencies of TOP, a package." + (define-values (name version) + (package-name->name+version bottom)) + + (define dependent? + (mlambda (p) + (and (package? p) + (or (and (string=? name (package-name p)) + (or (not version) + (version-prefix? version (package-version p)))) + (match (bag-direct-inputs (package->bag p)) + (((labels dependencies . _) ...) + (any dependent? dependencies))))))) + + (filter dependent? (package-closure (list top)))) + +(define (package-toolchain-rewriting p bottom toolchain) + "Return a procedure that, when passed a package that's either BOTTOM or one +of its dependents up to P so, changes it so it is built with TOOLCHAIN. +TOOLCHAIN must be an input list." + (define rewriting-property + (gensym " package-toolchain-rewriting")) + + (match (package-dependents/spec p bottom) + (() ;P does not depend on BOTTOM + identity) + (set + ;; SET is the list of packages "between" P and BOTTOM (included) whose + ;; toolchain needs to be changed. + (package-mapping (lambda (p) + (if (or (assq rewriting-property + (package-properties p)) + (not (memq p set))) + p + (let ((p (package-with-c-toolchain p toolchain))) + (package/inherit p + (properties `((,rewriting-property . #t) + ,@(package-properties p))))))) + (lambda (p) + (or (assq rewriting-property (package-properties p)) + (not (memq p set)))) + #:deep? #t)))) + +(define (transform-package-toolchain replacement-specs) + "Return a procedure that, when passed a package, changes its toolchain or +that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is +a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to +the left of the equal sign must be built with the toolchain to the right of +the equal sign." + (define split-on-commas + (cute string-tokenize <> (char-set-complement (char-set #\,)))) + + (define (specification->input spec) + (let ((package (specification->package spec))) + (list (package-name package) package))) + + (define replacements + (map (lambda (spec) + (match (string-tokenize spec %not-equal) + ((spec (= split-on-commas toolchain)) + (cons spec (map specification->input toolchain))) + (_ + (leave (G_ "~a: invalid toolchain replacement specification~%") + spec)))) + replacement-specs)) + + (lambda (obj) + (if (package? obj) + (or (any (match-lambda + ((bottom . toolchain) + ((package-toolchain-rewriting obj bottom toolchain) obj))) + replacements) + obj) + obj))) + +(define (transform-package-with-debug-info specs) + "Return a procedure that, when passed a package, set its 'replacement' field +to the same package but with #:strip-binaries? #f in its 'arguments' field." + (define (non-stripped p) + (package + (inherit p) + (arguments + (substitute-keyword-arguments (package-arguments p) + ((#:strip-binaries? _ #f) #f))))) + + (define (package-with-debug-info p) + (if (member "debug" (package-outputs p)) + p + (let loop ((p p)) + (match (package-replacement p) + (#f + (package + (inherit p) + (replacement (non-stripped p)))) + (next + (package + (inherit p) + (replacement (loop next)))))))) + + (define rewrite + (package-input-rewriting/spec (map (lambda (spec) + (cons spec package-with-debug-info)) + specs))) + + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj))) + +(define (transform-package-tests specs) + "Return a procedure that, when passed a package, sets #:tests? #f in its +'arguments' field." + (define (package-without-tests p) + (package/inherit p + (arguments + (substitute-keyword-arguments (package-arguments p) + ((#:tests? _ #f) #f))))) + + (define rewrite + (package-input-rewriting/spec (map (lambda (spec) + (cons spec package-without-tests)) + specs))) + + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj))) + +(define %transformations + ;; Transformations that can be applied to things to build. The car is the + ;; key used in the option alist, and the cdr is the transformation + ;; procedure; it is called with two arguments: the store, and a list of + ;; things to build. + `((with-source . ,transform-package-source) + (with-input . ,transform-package-inputs) + (with-graft . ,transform-package-inputs/graft) + (with-branch . ,transform-package-source-branch) + (with-commit . ,transform-package-source-commit) + (with-git-url . ,transform-package-source-git-url) + (with-c-toolchain . ,transform-package-toolchain) + (with-debug-info . ,transform-package-with-debug-info) + (without-tests . ,transform-package-tests))) + +(define (transformation-procedure key) + "Return the transformation procedure associated with KEY, a symbol such as +'with-source', or #f if there is none." + (any (match-lambda + ((k . proc) + (and (eq? k key) proc))) + %transformations)) + + +;;; +;;; Command-line handling. +;;; + +(define %transformation-options + ;; The command-line interface to the above transformations. + (let ((parser (lambda (symbol) + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest))))) + (list (option '("with-source") #t #f + (parser 'with-source)) + (option '("with-input") #t #f + (parser 'with-input)) + (option '("with-graft") #t #f + (parser 'with-graft)) + (option '("with-branch") #t #f + (parser 'with-branch)) + (option '("with-commit") #t #f + (parser 'with-commit)) + (option '("with-git-url") #t #f + (parser 'with-git-url)) + (option '("with-c-toolchain") #t #f + (parser 'with-c-toolchain)) + (option '("with-debug-info") #t #f + (parser 'with-debug-info)) + (option '("without-tests") #t #f + (parser 'without-tests))))) + +(define (show-transformation-options-help) + (display (G_ " + --with-source=[PACKAGE=]SOURCE + use SOURCE when building the corresponding package")) + (display (G_ " + --with-input=PACKAGE=REPLACEMENT + replace dependency PACKAGE by REPLACEMENT")) + (display (G_ " + --with-graft=PACKAGE=REPLACEMENT + graft REPLACEMENT on packages that refer to PACKAGE")) + (display (G_ " + --with-branch=PACKAGE=BRANCH + build PACKAGE from the latest commit of BRANCH")) + (display (G_ " + --with-commit=PACKAGE=COMMIT + build PACKAGE from COMMIT")) + (display (G_ " + --with-git-url=PACKAGE=URL + build PACKAGE from the repository at URL")) + (display (G_ " + --with-c-toolchain=PACKAGE=TOOLCHAIN + build PACKAGE and its dependents with TOOLCHAIN")) + (display (G_ " + --with-debug-info=PACKAGE + build PACKAGE and preserve its debug info")) + (display (G_ " + --without-tests=PACKAGE + build PACKAGE without running its tests"))) + + +(define (options->transformation opts) + "Return a procedure that, when passed an object to build (package, +derivation, etc.), applies the transformations specified by OPTS and returns +the resulting objects. OPTS must be a list of symbol/string pairs such as: + + ((with-branch . \"guile-gcrypt=master\") + (without-tests . \"libgcrypt\")) + +Each symbol names a transformation and the corresponding string is an argument +to that transformation." + (define applicable + ;; List of applicable transformations as symbol/procedure pairs in the + ;; order in which they appear on the command line. + (filter-map (match-lambda + ((key . value) + (match (transformation-procedure key) + (#f + #f) + (transform + ;; XXX: We used to pass TRANSFORM a list of several + ;; arguments, but we now pass only one, assuming that + ;; transform composes well. + (list key value (transform (list value))))))) + (reverse opts))) + + (define (package-with-transformation-properties p) + (package/inherit p + (properties `((transformations + . ,(map (match-lambda + ((key value _) + (cons key value))) + applicable)) + ,@(package-properties p))))) + + (lambda (obj) + (define (tagged-object new) + (if (and (not (eq? obj new)) + (package? new) (not (null? applicable))) + (package-with-transformation-properties new) + new)) + + (tagged-object + (fold (match-lambda* + (((name value transform) obj) + (let ((new (transform obj))) + (when (eq? new obj) + (warning (G_ "transformation '~a' had no effect on ~a~%") + name + (if (package? obj) + (package-full-name obj) + obj))) + new))) + obj + applicable)))) + +(define (package-transformations package) + "Return the transformations applied to PACKAGE according to its properties." + (match (assq-ref (package-properties package) 'transformations) + (#f '()) + (transformations transformations))) + +(define (manifest-entry-with-transformations entry) + "Return ENTRY with an additional 'transformations' property if it's not +already there." + (let ((properties (manifest-entry-properties entry))) + (if (assq 'transformations properties) + entry + (let ((item (manifest-entry-item entry))) + (manifest-entry + (inherit entry) + (properties + (match (and (package? item) + (package-transformations item)) + ((or #f '()) + properties) + (transformations + `((transformations . ,transformations) + ,@properties))))))))) diff --git a/tests/scripts-build.scm b/tests/transformations.scm similarity index 99% rename from tests/scripts-build.scm rename to tests/transformations.scm index d56e02b452..07ed8b1234 100644 --- a/tests/scripts-build.scm +++ b/tests/transformations.scm @@ -16,7 +16,7 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . -(define-module (test-scripts-build) +(define-module (test-transformations) #:use-module (guix tests) #:use-module (guix store) #:use-module ((guix gexp) #:select (lower-object)) @@ -25,7 +25,7 @@ #:use-module (guix git-download) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix git) @@ -38,7 +38,7 @@ #:use-module (srfi srfi-64)) -(test-begin "scripts-build") +(test-begin "transformations") (test-assert "options->transformation, no transformations" (let ((p (dummy-package "foo")) From patchwork Thu Oct 29 23:09:59 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 24881 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 5AC9427BBF3; Thu, 29 Oct 2020 23:11:38 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 9498D27BBF2 for ; Thu, 29 Oct 2020 23:11:37 +0000 (GMT) Received: from localhost ([::1]:45790 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH4y-0007va-Pi for patchwork@mira.cbaines.net; Thu, 29 Oct 2020 19:11:36 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:54738) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kYH4R-0007Qt-GB for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:43754) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kYH4R-0006RP-6m for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kYH4R-0000PK-2O for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#44321] [PATCH 5/6] transformations: Raise '&formatted-message' exceptions instead of 'leave'. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 29 Oct 2020 23:11:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 44321 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 44321@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 44321-submit@debbugs.gnu.org id=B44321.16040130251480 (code B ref 44321); Thu, 29 Oct 2020 23:11:03 +0000 Received: (at 44321) by debbugs.gnu.org; 29 Oct 2020 23:10:25 +0000 Received: from localhost ([127.0.0.1]:55293 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3p-0000Nn-9h for submit@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:25 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54496) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3f-0000Md-Ui for 44321@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:16 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:49476) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH3a-0006AV-OJ; Thu, 29 Oct 2020 19:10:10 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=50412 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1kYH3a-0007CN-7a; Thu, 29 Oct 2020 19:10:10 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 30 Oct 2020 00:09:59 +0100 Message-Id: <20201029231000.14568-5-ludo@gnu.org> X-Mailer: git-send-email 2.28.0 In-Reply-To: <20201029231000.14568-1-ludo@gnu.org> References: <20201029231000.14568-1-ludo@gnu.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: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/transformations.scm (evaluate-replacement-specs) (package-git-url, evaluate-git-replacement-specs) (transform-package-source-git-url) (transform-package-toolchain): Use 'raise' and 'formatted-message' instead of 'leave'. --- guix/transformations.scm | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/guix/transformations.scm b/guix/transformations.scm index 126a9a69d3..30142dd059 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -38,6 +38,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (options->transformation @@ -169,7 +170,9 @@ package it refers to could not be found." (lambda (old) (proc old new))))) (x - (leave (G_ "invalid replacement specification: ~s~%") spec)))) + (raise (formatted-message + (G_ "invalid replacement specification: ~s") + spec))))) specs)) (define (transform-package-inputs replacement-specs) @@ -216,8 +219,9 @@ the source of PACKAGE is not fetched from a Git repository." ((git-checkout? source) (git-checkout-url source)) (else - (leave (G_ "the source of ~a is not a Git reference~%") - (package-full-name package)))))) + (raise + (formatted-message (G_ "the source of ~a is not a Git reference") + (package-full-name package))))))) (define (evaluate-git-replacement-specs specs proc) "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list @@ -234,7 +238,9 @@ syntax, or if a package it refers to could not be found." (cons spec replace)) (_ - (leave (G_ "invalid replacement specification: ~s~%") spec)))) + (raise + (formatted-message (G_ "invalid replacement specification: ~s") + spec))))) specs)) (define (transform-package-source-branch replacement-specs) @@ -304,8 +310,10 @@ a checkout of the Git repository at the given URL." (source (git-checkout (url url) (recursive? #t))))))) (_ - (leave (G_ "~a: invalid Git URL replacement specification~%") - spec)))) + (raise + (formatted-message + (G_ "~a: invalid Git URL replacement specification") + spec))))) replacement-specs)) (define rewrite @@ -380,8 +388,10 @@ the equal sign." ((spec (= split-on-commas toolchain)) (cons spec (map specification->input toolchain))) (_ - (leave (G_ "~a: invalid toolchain replacement specification~%") - spec)))) + (raise + (formatted-message + (G_ "~a: invalid toolchain replacement specification") + spec))))) replacement-specs)) (lambda (obj) From patchwork Thu Oct 29 23:10:00 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 24879 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 2BCB727BBF5; Thu, 29 Oct 2020 23:11:31 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id DA79427BBF3 for ; Thu, 29 Oct 2020 23:11:28 +0000 (GMT) Received: from localhost ([::1]:44954 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH4q-0007Xr-19 for patchwork@mira.cbaines.net; Thu, 29 Oct 2020 19:11:28 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:54750) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kYH4S-0007RD-Ai for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:43756) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kYH4S-0006RX-1F for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kYH4R-0000PZ-Sg for guix-patches@gnu.org; Thu, 29 Oct 2020 19:11:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#44321] [PATCH 6/6] doc: Add "Defining Package Variants" section. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 29 Oct 2020 23:11:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 44321 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 44321@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 44321-submit@debbugs.gnu.org id=B44321.16040130281498 (code B ref 44321); Thu, 29 Oct 2020 23:11:03 +0000 Received: (at 44321) by debbugs.gnu.org; 29 Oct 2020 23:10:28 +0000 Received: from localhost ([127.0.0.1]:55297 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3r-0000O0-NB for submit@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:28 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54500) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kYH3g-0000Mg-Rm for 44321@debbugs.gnu.org; Thu, 29 Oct 2020 19:10:17 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:49477) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYH3b-0006Aa-Lb; Thu, 29 Oct 2020 19:10:11 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=50412 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1kYH3b-0007CN-21; Thu, 29 Oct 2020 19:10:11 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 30 Oct 2020 00:10:00 +0100 Message-Id: <20201029231000.14568-6-ludo@gnu.org> X-Mailer: git-send-email 2.28.0 In-Reply-To: <20201029231000.14568-1-ludo@gnu.org> References: <20201029231000.14568-1-ludo@gnu.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: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * doc/guix.texi (Defining Packages): Move documentation of 'package-input-rewriting' & co. to... (Defining Package Variants): ... here. New node. Also document 'inherit' and 'options->transformation'. --- doc/guix.texi | 278 ++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 204 insertions(+), 74 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 22bddf10e3..831ee3f881 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -253,6 +253,7 @@ Programming Interface * Package Modules:: Packages from the programmer's viewpoint. * Defining Packages:: Defining new packages. +* Defining Package Variants:: Customizing packages. * Build Systems:: Specifying how packages are built. * Build Phases:: Phases of the build process of a package. * Build Utilities:: Helpers for your package definitions and more. @@ -260,7 +261,7 @@ Programming Interface * Derivations:: Low-level interface to package derivations. * The Store Monad:: Purely functional interface to the store. * G-Expressions:: Manipulating build expressions. -* Invoking guix repl:: Programming Guix in Guile. +* Invoking guix repl:: Programming Guix in Guile Defining Packages @@ -6204,6 +6205,7 @@ package definitions. @menu * Package Modules:: Packages from the programmer's viewpoint. * Defining Packages:: Defining new packages. +* Defining Package Variants:: Customizing packages. * Build Systems:: Specifying how packages are built. * Build Phases:: Phases of the build process of a package. * Build Utilities:: Helpers for your package definitions and more. @@ -6473,79 +6475,8 @@ and operating system, such as @code{"aarch64-linux-gnu"} (@pxref{Specifying Target Triplets,,, autoconf, Autoconf}). @end deffn -@cindex package transformations -@cindex input rewriting -@cindex dependency tree rewriting -Packages can be manipulated in arbitrary ways. An example of a useful -transformation is @dfn{input rewriting}, whereby the dependency tree of -a package is rewritten by replacing specific inputs by others: - -@deffn {Scheme Procedure} package-input-rewriting @var{replacements} @ - [@var{rewrite-name}] [#:deep? #t] -Return a procedure that, when passed a package, replaces its direct and -indirect dependencies, including implicit inputs when @var{deep?} is -true, according to @var{replacements}. @var{replacements} is a list of -package pairs; the first element of each pair is the package to replace, -and the second one is the replacement. - -Optionally, @var{rewrite-name} is a one-argument procedure that takes -the name of a package and returns its new name after rewrite. -@end deffn - -@noindent -Consider this example: - -@lisp -(define libressl-instead-of-openssl - ;; This is a procedure to replace OPENSSL by LIBRESSL, - ;; recursively. - (package-input-rewriting `((,openssl . ,libressl)))) - -(define git-with-libressl - (libressl-instead-of-openssl git)) -@end lisp - -@noindent -Here we first define a rewriting procedure that replaces @var{openssl} -with @var{libressl}. Then we use it to define a @dfn{variant} of the -@var{git} package that uses @var{libressl} instead of @var{openssl}. -This is exactly what the @option{--with-input} command-line option does -(@pxref{Package Transformation Options, @option{--with-input}}). - -The following variant of @code{package-input-rewriting} can match packages to -be replaced by name rather than by identity. - -@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} [#:deep? #t] -Return a procedure that, given a package, applies the given -@var{replacements} to all the package graph, including implicit inputs -unless @var{deep?} is false. @var{replacements} is a list of -spec/procedures pair; each spec is a package specification such as -@code{"gcc"} or @code{"guile@@2"}, and each procedure takes a matching -package and returns a replacement for that package. -@end deffn - -The example above could be rewritten this way: - -@lisp -(define libressl-instead-of-openssl - ;; Replace all the packages called "openssl" with LibreSSL. - (package-input-rewriting/spec `(("openssl" . ,(const libressl))))) -@end lisp - -The key difference here is that, this time, packages are matched by spec and -not by identity. In other words, any package in the graph that is called -@code{openssl} will be replaced. - -A more generic procedure to rewrite a package dependency graph is -@code{package-mapping}: it supports arbitrary changes to nodes in the -graph. - -@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}] [#:deep? #f] -Return a procedure that, given a package, applies @var{proc} to all the packages -depended on and returns the resulting package. The procedure stops recursion -when @var{cut?} returns true for a given package. When @var{deep?} is true, @var{proc} is -applied to implicit inputs as well. -@end deffn +Once you have package definitions, you can easily define @emph{variants} +of those packages. @xref{Defining Package Variants}, for more on that. @menu * package Reference:: The package data type. @@ -6903,6 +6834,200 @@ commit: @end lisp @end deftp +@node Defining Package Variants +@section Defining Package Variants + +@cindex customizing packages +@cindex variants, of packages +One of the nice things with Guix is that, given a package definition, +you can easily @emph{derive} variants of that package---for a different +upstream version, with different dependencies, different compilation +options, and so on. Some of these custom packages can be defined +straight from the command line (@pxref{Package Transformation Options}). +This section describes how to define package variants in code. This can +be useful in ``manifests'' (@pxref{profile-manifest, +@option{--manifest}}) and in your own package collection +(@pxref{Creating a Channel}), among others! + +@cindex inherit, for package definitions +As discussed earlier, packages are first-class objects in the Scheme +language. The @code{(guix packages)} module provides the @code{package} +construct to define new package objects (@pxref{package Reference}). +The easiest way to define a package variant is using the @code{inherit} +keyword together with @code{package}. This allows you to inherit from a +package definition while overriding the fields you want. + +For example, given the @code{hello} variable, which contains a +definition for the current version of GNU@tie{}Hello, here's how you +would define a variant for version 2.2 (released in 2006, it's +vintage!): + +@lisp +(use-modules (gnu packages base)) ;for 'hello' + +(define hello-2.2 + (package + (inherit hello) + (version "2.2") + (source (origin + (method url-fetch) + (uri (string-append "mirror://gnu/hello/hello-" version + ".tar.gz")) + (sha256 + (base32 + "0lappv4slgb5spyqbh6yl5r013zv72yqg2pcl30mginf3wdqd8k9")))))) +@end lisp + +The example above corresponds to what the @option{--with-source} package +transformation option does. Essentially @code{hello-2.2} preserves all +the fields of @code{hello}, except @code{version} and @code{source}, +which it overrides. Note that the original @code{hello} variable is +still there, in the @code{(gnu packages base)} module, unchanged. When +you define a custom package like this, you are really @emph{adding} a +new package definition; the original one remains available. + +You can just as well define variants with a different set of +dependencies than the original package. For example, the default +@code{gdb} package depends on @code{guile}, but since that is an +optional dependency, you can define a variant that removes that +dependency like so: + +@lisp +(use-modules (gnu packages gdb) ;for 'gdb' + (srfi srfi-1)) ;for 'alist-delete' + +(define gdb-sans-guile + (package + (inherit gdb) + (inputs (alist-delete "guile" + (package-inputs gdb))))) +@end lisp + +@cindex package transformations +These are pretty simple package variants. As a convenience, the +@code{(guix transformations)} module provides a high-level interface +that directly maps to package transformation options (@pxref{Package +Transformation Options}): + +@deffn {Scheme Procedure} options->transformation @var{opts} +Return a procedure that, when passed an object to build (package, +derivation, etc.), applies the transformations specified by @var{opts} and returns +the resulting objects. @var{opts} must be a list of symbol/string pairs such as: + +@example +((with-branch . "guile-gcrypt=master") + (without-tests . "libgcrypt")) +@end example + +Each symbol names a transformation and the corresponding string is an argument +to that transformation. +@end deffn + +For instance, a manifest equivalent to this command: + +@example +guix build guix \ + --with-branch=guile-gcrypt=master \ + --with-debug-info=zlib +@end example + +@noindent +... would look like this: + +@lisp +(use-modules (guix transformations)) + +(define transform + ;; The package transformation procedure. + (options->transformation + '((with-branch . "guile-gcrypt=master") + (with-debug-info . "zlib")))) + +(packages->manifest + (list (transform (specification->package "guix")))) +@end lisp + +@cindex input rewriting +@cindex dependency graph rewriting +The @code{options->transformation} procedure is convenient, but it's +perhaps also not as flexible as you may like. How is it implemented? +The astute reader probably noticed that most package transformation +options go beyond the superficial changes shown in the first examples of +this section: they involve @dfn{input rewriting}, whereby the dependency +graph of a package is rewritten by replacing specific inputs by others. + +Dependency graph rewriting, for the purposes of swapping packages in the +graph, is what the @code{package-input-rewriting} procedure in +@code{(guix packages)} implements. + +@deffn {Scheme Procedure} package-input-rewriting @var{replacements} @ + [@var{rewrite-name}] [#:deep? #t] +Return a procedure that, when passed a package, replaces its direct and +indirect dependencies, including implicit inputs when @var{deep?} is +true, according to @var{replacements}. @var{replacements} is a list of +package pairs; the first element of each pair is the package to replace, +and the second one is the replacement. + +Optionally, @var{rewrite-name} is a one-argument procedure that takes +the name of a package and returns its new name after rewrite. +@end deffn + +@noindent +Consider this example: + +@lisp +(define libressl-instead-of-openssl + ;; This is a procedure to replace OPENSSL by LIBRESSL, + ;; recursively. + (package-input-rewriting `((,openssl . ,libressl)))) + +(define git-with-libressl + (libressl-instead-of-openssl git)) +@end lisp + +@noindent +Here we first define a rewriting procedure that replaces @var{openssl} +with @var{libressl}. Then we use it to define a @dfn{variant} of the +@var{git} package that uses @var{libressl} instead of @var{openssl}. +This is exactly what the @option{--with-input} command-line option does +(@pxref{Package Transformation Options, @option{--with-input}}). + +The following variant of @code{package-input-rewriting} can match packages to +be replaced by name rather than by identity. + +@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} [#:deep? #t] +Return a procedure that, given a package, applies the given +@var{replacements} to all the package graph, including implicit inputs +unless @var{deep?} is false. @var{replacements} is a list of +spec/procedures pair; each spec is a package specification such as +@code{"gcc"} or @code{"guile@@2"}, and each procedure takes a matching +package and returns a replacement for that package. +@end deffn + +The example above could be rewritten this way: + +@lisp +(define libressl-instead-of-openssl + ;; Replace all the packages called "openssl" with LibreSSL. + (package-input-rewriting/spec `(("openssl" . ,(const libressl))))) +@end lisp + +The key difference here is that, this time, packages are matched by spec and +not by identity. In other words, any package in the graph that is called +@code{openssl} will be replaced. + +A more generic procedure to rewrite a package dependency graph is +@code{package-mapping}: it supports arbitrary changes to nodes in the +graph. + +@deffn {Scheme Procedure} package-mapping @var{proc} [@var{cut?}] [#:deep? #f] +Return a procedure that, given a package, applies @var{proc} to all the packages +depended on and returns the resulting package. The procedure stops recursion +when @var{cut?} returns true for a given package. When @var{deep?} is true, @var{proc} is +applied to implicit inputs as well. +@end deffn + + @node Build Systems @section Build Systems @@ -10155,6 +10280,11 @@ that does not respect a @code{#:tests? #f} setting. Therefore, @end table +Wondering how to achieve the same effect using Scheme code, for example +in your manifest, or how to write your own package transformation? +@xref{Defining Package Variants}, for an overview of the programming +interfaces available. + @node Additional Build Options @subsection Additional Build Options