all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: "Ludovic Courtès" <ludo@gnu.org>
To: 43578@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#43578] [PATCH 1/4] packages: 'package-mapping' can recurse on implicit inputs.
Date: Wed, 23 Sep 2020 18:23:15 +0200	[thread overview]
Message-ID: <20200923162318.2800-1-ludo@gnu.org> (raw)
In-Reply-To: <20200923161253.2378-1-ludo@gnu.org>

* guix/packages.scm (build-system-with-package-mapping): New procedure.
(package-mapping): Add #:deep? and honor it.
* tests/packages.scm ("package-mapping"): Compare the direct inputs of
the bag of P0 and that of P1.
("package-mapping, deep"): New test.
---
 doc/guix.texi      |  5 ++--
 guix/packages.scm  | 65 +++++++++++++++++++++++++++++++++++-----------
 tests/packages.scm | 36 ++++++++++++++++++++++++-
 3 files changed, 88 insertions(+), 18 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index f7e2204b53..4595008c4f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6294,10 +6294,11 @@ 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?}]
+@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{cut?} returns true for a given package.  When @var{deep?} is true, @var{proc} is
+applied to implicit inputs as well.
 @end deffn
 
 @menu
diff --git a/guix/packages.scm b/guix/packages.scm
index 6598bd3149..171fd048ef 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -968,10 +968,31 @@ packages they depend on, recursively."
                    (vhash-consq package #t visited)
                    (fold set-insert closure dependencies))))))))
 
-(define* (package-mapping proc #:optional (cut? (const #f)))
+(define (build-system-with-package-mapping bs rewrite)
+  "Return a variant of BS, a build system, that rewrites a bag's inputs by
+passing them through REWRITE, a procedure that takes an input tuplet and
+returns a \"rewritten\" input tuplet."
+  (define lower
+    (build-system-lower bs))
+
+  (define (lower* . args)
+    (let ((lowered (apply lower args)))
+      (bag
+        (inherit lowered)
+        (build-inputs (map rewrite (bag-build-inputs lowered)))
+        (host-inputs (map rewrite (bag-host-inputs lowered)))
+        (target-inputs (map rewrite (bag-target-inputs lowered))))))
+
+  (build-system
+    (inherit bs)
+    (lower lower*)))
+
+(define* (package-mapping proc #:optional (cut? (const #f))
+                          #:key deep?)
   "Return a procedure that, given a package, applies PROC to all the packages
 depended on and returns the resulting package.  The procedure stops recursion
-when CUT? returns true for a given package."
+when CUT? returns true for a given package.  When DEEP? is true, PROC is
+applied to implicit inputs as well."
   (define (rewrite input)
     (match input
       ((label (? package? package) outputs ...)
@@ -980,21 +1001,35 @@ when CUT? returns true for a given package."
       (_
        input)))
 
+  (define mapping-property
+    ;; Property indicating whether the package has already been processed.
+    (gensym " package-mapping-done"))
+
   (define replace
     (mlambdaq (p)
-      ;; Return a variant of P with PROC applied to P and its explicit
-      ;; dependencies, recursively.  Memoize the transformations.  Failing to
-      ;; do that, we would build a huge object graph with lots of duplicates,
-      ;; which in turns prevents us from benefiting from memoization in
-      ;; 'package-derivation'.
-      (let ((p (proc p)))
-        (package
-          (inherit p)
-          (location (package-location p))
-          (inputs (map rewrite (package-inputs p)))
-          (native-inputs (map rewrite (package-native-inputs p)))
-          (propagated-inputs (map rewrite (package-propagated-inputs p)))
-          (replacement (and=> (package-replacement p) proc))))))
+      ;; If P is the result of a previous call, return it.
+      (if (assq-ref (package-properties p) mapping-property)
+          p
+
+          ;; Return a variant of P with PROC applied to P and its explicit
+          ;; dependencies, recursively.  Memoize the transformations.  Failing
+          ;; to do that, we would build a huge object graph with lots of
+          ;; duplicates, which in turns prevents us from benefiting from
+          ;; memoization in 'package-derivation'.
+          (let ((p (proc p)))
+            (package
+              (inherit p)
+              (location (package-location p))
+              (build-system (if deep?
+                                (build-system-with-package-mapping
+                                 (package-build-system p) rewrite)
+                                (package-build-system p)))
+              (inputs (map rewrite (package-inputs p)))
+              (native-inputs (map rewrite (package-native-inputs p)))
+              (propagated-inputs (map rewrite (package-propagated-inputs p)))
+              (replacement (and=> (package-replacement p) proc))
+              (properties `((,mapping-property . #t)
+                            ,@(package-properties p))))))))
 
   replace)
 
diff --git a/tests/packages.scm b/tests/packages.scm
index cbd0503733..f33332a461 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1172,15 +1172,24 @@
   (let* ((dep       (dummy-package "chbouib"
                       (native-inputs `(("x" ,grep)))))
          (p0        (dummy-package "example"
+                      (source 77)
                       (inputs `(("foo" ,coreutils)
                                 ("bar" ,grep)
                                 ("baz" ,dep)))))
          (transform (lambda (p)
                       (package (inherit p) (source 42))))
          (rewrite   (package-mapping transform))
-         (p1        (rewrite p0)))
+         (p1        (rewrite p0))
+         (bag0      (package->bag p0))
+         (bag1      (package->bag p1)))
     (and (eq? p1 (rewrite p0))
          (eqv? 42 (package-source p1))
+
+         ;; Implicit inputs should be left unchanged (skip "source", "foo",
+         ;; "bar", and "baz" in this comparison).
+         (equal? (drop (bag-direct-inputs bag0) 4)
+                 (drop (bag-direct-inputs bag1) 4))
+
          (match (package-inputs p1)
            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
             (and (eq? dep1 (rewrite coreutils))   ;memoization
@@ -1194,6 +1203,31 @@
                     (and (eq? dep (rewrite grep))
                          (package-source dep))))))))))
 
+(test-equal "package-mapping, deep"
+  '(42)
+  (let* ((p0        (dummy-package "example"
+                      (inputs `(("foo" ,coreutils)
+                                ("bar" ,grep)))))
+         (transform (lambda (p)
+                      (package (inherit p) (source 42))))
+         (rewrite   (package-mapping transform #:deep? #t))
+         (p1        (rewrite p0))
+         (bag       (package->bag p1)))
+    (and (eq? p1 (rewrite p0))
+         (match (bag-direct-inputs bag)
+           ((("source" 42) ("foo" dep1) ("bar" dep2) rest ..1)
+            (and (eq? dep1 (rewrite coreutils))   ;memoization
+                 (eq? dep2 (rewrite grep))
+                 (= 42 (package-source dep1))
+                 (= 42 (package-source dep2))
+
+                 ;; Check that implicit inputs of P0 also got rewritten.
+                 (delete-duplicates
+                  (map (match-lambda
+                         ((_ package . _)
+                          (package-source package)))
+                       rest))))))))
+
 (test-assert "package-input-rewriting"
   (let* ((dep     (dummy-package "chbouib"
                     (native-inputs `(("x" ,grep)))))
-- 
2.28.0





  reply	other threads:[~2020-09-23 16:27 UTC|newest]

Thread overview: 14+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2020-09-23 16:12 [bug#43578] [PATCH 0/4] Rewriting implicit inputs with 'package-input-rewriting' & co Ludovic Courtès
2020-09-23 16:23 ` Ludovic Courtès [this message]
2020-09-23 16:23   ` [bug#43578] [PATCH 2/4] packages: 'package-input-rewriting/spec' can rewrite implicit dependencies Ludovic Courtès
2020-09-23 16:23   ` [bug#43578] [PATCH 3/4] packages: 'package-mapping' correctly recurses into 'replacement' Ludovic Courtès
2020-09-23 16:23   ` [bug#43578] [PATCH 4/4] packages: 'package-input-rewriting' has a #:deep? parameter Ludovic Courtès
2020-09-23 17:17 ` [bug#43578] [PATCH 0/4] Rewriting implicit inputs with 'package-input-rewriting' & co zimoun
2020-09-23 20:51   ` Ludovic Courtès
2020-09-24  6:28     ` Efraim Flashner
2020-09-25 22:38 ` zimoun
2020-09-26 13:53   ` Ludovic Courtès
2020-09-26 16:04     ` zimoun
2020-09-28 19:39 ` Rewriting inputs and ’arguments’ after patch #43578 zimoun
2020-10-05 13:46   ` Ludovic Courtès
2020-10-05 14:17     ` zimoun

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20200923162318.2800-1-ludo@gnu.org \
    --to=ludo@gnu.org \
    --cc=43578@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.