guix build: Add '--with-branch' transformation option.

* guix/scripts/build.scm (evaluate-git-replacement-specs)
(transform-package-source-branch): New procedures.
(%transformations, %transformation-options): Add 'with-branch'.
(show-transformation-options-help): Likewise.
* tests/guix-build-branch.sh: New file.
* Makefile.am (SH_TESTS): Add it.
* doc/guix.texi (Package Transformation Options): Document it.

1 files changed, 53 insertions, 3 deletions

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 13978abb77..e8f2fe973d 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -45,6 +45,8 @@
   #:use-module (srfi srfi-37)
   #:autoload   (gnu packages) (specification->package %package-module-path)
   #:autoload   (guix download) (download-to-store)
+  #:autoload   (guix git-download) (git-reference?)
+  #:autoload   (guix git) (git-checkout?)
   #:use-module (guix status)
   #:use-module ((guix progress) #:select (current-terminal-columns))
   #:use-module ((guix build syscalls) #:select (terminal-columns))
@@ -270,6 +272,48 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them."
           (rewrite obj)
           obj))))
 
+(define (evaluate-git-replacement-specs specs)
+  "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list
+of package pairs.  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)
+           ((name branch)
+            (let* ((old    (specification->package name))
+                   (source (package-source old))
+                   (url    (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 old))))))
+              (cons old
+                    (package
+                      (inherit old)
+                      (version (string-append "git." branch))
+                      (source (git-checkout (url url) (branch branch)))))))
+           (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."
+  (let* ((replacements (evaluate-git-replacement-specs replacement-specs))
+         (rewrite      (package-input-rewriting replacements)))
+    (lambda (store 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
@@ -277,7 +321,8 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them."
   ;; things to build.
   `((with-source . ,transform-package-source)
     (with-input  . ,transform-package-inputs)
-    (with-graft  . ,transform-package-inputs/graft)))
+    (with-graft  . ,transform-package-inputs/graft)
+    (with-branch . ,transform-package-source-branch)))
 
 (define %transformation-options
   ;; The command-line interface to the above transformations.
@@ -291,7 +336,9 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them."
           (option '("with-input") #t #f
                   (parser 'with-input))
           (option '("with-graft") #t #f
-                  (parser 'with-graft)))))
+                  (parser 'with-graft))
+          (option '("with-branch") #t #f
+                  (parser 'with-branch)))))
 
 (define (show-transformation-options-help)
   (display (G_ "
@@ -302,7 +349,10 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them."
                          replace dependency PACKAGE by REPLACEMENT"))
   (display (G_ "
       --with-graft=PACKAGE=REPLACEMENT
-                         graft REPLACEMENT on packages that refer to PACKAGE")))
+                         graft REPLACEMENT on packages that refer to PACKAGE"))
+    (display (G_ "
+      --with-branch=PACKAGE=BRANCH
+                         build PACKAGE from the latest commit of BRANCH")))
 
 
 (define (options->transformation opts)