From abd7a474615353149a44f4504f0b4b248dcc0716 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludovic.courtes@inria.fr>
Date: Mon, 28 Sep 2020 18:56:00 +0200
Subject: guix build: Add '--with-c-toolchain'.

* guix/scripts/build.scm (package-dependents/spec)
(package-toolchain-rewriting, transform-package-toolchain): New procedures.
(%transformations): Add it.
(%transformation-options, show-transformation-options-help): Add
'--with-c-toolchain'.
* tests/scripts-build.scm (depends-on-toolchain?): New procedure.
("options->transformation, with-c-toolchain")
("options->transformation, with-c-toolchain twice")
New test.
("options->transformation, with-c-toolchain, no effect"): New tests.
* doc/guix.texi (Package Transformation Options): Document it.
---
 guix/scripts/build.scm | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 84 insertions(+)

(limited to 'guix/scripts')

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 72a5d46347..e59e0ee67f 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -26,6 +26,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix memoization)
   #:use-module (guix grafts)
 
   #:use-module (guix utils)
@@ -396,6 +397,83 @@ a checkout of the Git repository at the given URL."
         (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 (store obj)
+    (if (package? obj)
+        (or (any (match-lambda
+                   ((bottom . toolchain)
+                    ((package-toolchain-rewriting obj bottom toolchain) obj)))
+                 replacements)
+            obj)
+        obj)))
+
 (define (transform-package-tests specs)
   "Return a procedure that, when passed a package, sets #:tests? #f in its
 'arguments' field."
@@ -426,6 +504,7 @@ a checkout of the Git repository at the given URL."
     (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)
     (without-tests . ,transform-package-tests)))
 
 (define (transformation-procedure key)
@@ -455,6 +534,8 @@ a checkout of the Git repository at the given URL."
                   (parser 'with-commit))
           (option '("with-git-url") #t #f
                   (parser 'with-git-url))
+          (option '("with-c-toolchain") #t #f
+                  (parser 'with-c-toolchain))
           (option '("without-tests") #t #f
                   (parser 'without-tests)))))
 
@@ -477,6 +558,9 @@ a checkout of the Git repository at the given URL."
   (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_ "
       --without-tests=PACKAGE
                          build PACKAGE without running its tests")))
-- 
cgit v1.2.3