From 47c0f92c37dc7d50d9d4598ce5b91c4cdfec6ed1 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 31 Jan 2016 23:22:18 +0100
Subject: guix build: Add '--with-input'.

* guix/scripts/build.scm (transform-package-inputs): New procedure.
(%transformations): Add it.
(%transformation-options, show-transformation-options-help): Add
--with-input.
* tests/scripts-build.scm ("options->transformation, with-input"):
("options->transformation, with-input, no matches"): New tests.
* tests/guix-build.sh: Add tests.
* doc/guix.texi (Package Transformation Options): Document it.
---
 guix/scripts/build.scm | 55 ++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 53 insertions(+), 2 deletions(-)

(limited to 'guix/scripts/build.scm')

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index b37d923b3a..aa9c105f58 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -169,12 +169,55 @@ (define new-sources
         (_
          obj)))))
 
+(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 direct dependency on a
+package called \"guile\" must be replaced with a dependency on a version 2.1
+of \"guile\"."
+  (define not-equal
+    (char-set-complement (char-set #\=)))
+
+  (define replacements
+    ;; List of name/package pairs.
+    (map (lambda (spec)
+           (match (string-tokenize spec not-equal)
+             ((old new)
+              (cons old (specification->package new)))
+             (_
+              (leave (_ "invalid replacement specification: ~s~%") spec))))
+         replacement-specs))
+
+  (define (rewrite input)
+    (match input
+      ((label (? package? package) outputs ...)
+       (match (assoc-ref replacements (package-name package))
+         (#f  (cons* label (replace package) outputs))
+         (new (cons* label new outputs))))
+      (_
+       input)))
+
+  (define replace
+    (memoize                                      ;XXX: use eq?
+     (lambda (p)
+       (package
+         (inherit p)
+         (inputs (map rewrite (package-inputs p)))
+         (native-inputs (map rewrite (package-native-inputs p)))
+         (propagated-inputs (map rewrite (package-propagated-inputs p)))))))
+
+  (lambda (store obj)
+    (if (package? obj)
+        (replace 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-source . ,transform-package-source)
+    (with-input  . ,transform-package-inputs)))
 
 (define %transformation-options
   ;; The command-line interface to the above transformations.
@@ -182,12 +225,20 @@ (define %transformation-options
                 (lambda (opt name arg result . rest)
                   (apply values
                          (cons (alist-cons 'with-source arg result)
+                               rest))))
+        (option '("with-input") #t #f
+                (lambda (opt name arg result . rest)
+                  (apply values
+                         (cons (alist-cons 'with-input arg result)
                                rest))))))
 
 (define (show-transformation-options-help)
   (display (_ "
       --with-source=SOURCE
-                         use SOURCE when building the corresponding package")))
+                         use SOURCE when building the corresponding package"))
+  (display (_ "
+      --with-input=PACKAGE=REPLACEMENT
+                         replace dependency PACKAGE by REPLACEMENT")))
 
 
 (define (options->transformation opts)
-- 
cgit v1.2.3