guix build: Add '--with-source'.

* guix/scripts/build.scm (package-with-source): New procedure.
  (show-help): Add '--with-source'.
  (%options): Likewise.
  (options->derivations): Call 'options/with-source' and
  'options/resolve-packages'.
  (options/resolve-packages, options/with-source): New procedures.
* doc/guix.texi (Invoking guix build): Document '--with-source'.

1 files changed, 94 insertions, 14 deletions

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 618015e9ba..8f6ba192c2 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -33,6 +33,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:autoload   (gnu packages) (find-best-packages-by-name)
+  #:autoload   (guix download) (download-to-store)
   #:export (derivation-from-expression
 
             %standard-build-options
@@ -104,6 +105,31 @@ present, return the preferred newest version."
         (leave (_ "failed to create GC root `~a': ~a~%")
                root (strerror (system-error-errno args)))))))
 
+(define (package-with-source store p uri)
+  "Return a package based on P but with its source taken from URI.  Extract
+the new package's version number from URI."
+  (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 ((numeric-extension? file-name)
+           file-name)
+          ((string=? (file-extension file-name) "tar")
+           (file-sans-extension file-name))
+          (else
+           (tarball-base-name (file-sans-extension file-name)))))
+
+  (let ((base (tarball-base-name (basename uri))))
+    (let-values (((name version)
+                  (package-name->name+version base)))
+      (package (inherit p)
+               (version (or version (package-version p)))
+               (source (download-to-store store uri))))))
+
 
 ;;;
 ;;; Standard command-line build options.
@@ -222,6 +248,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (display (_ "
       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
   (display (_ "
+      --with-source=SOURCE
+                         use SOURCE when building the corresponding package"))
+  (display (_ "
   -d, --derivations      return the derivation paths of the given packages"))
   (display (_ "
   -r, --root=FILE        make FILE a symlink to the result, and register it
@@ -274,6 +303,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
          (option '("log-file") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'log-file? #t result)))
+         (option '("with-source") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'with-source arg result)))
 
          %standard-build-options))
 
@@ -289,23 +321,71 @@ build."
   (define src? (assoc-ref opts 'source?))
   (define sys  (assoc-ref opts 'system))
 
-  (filter-map (match-lambda
-               (('expression . str)
-                (derivation-from-expression store str package->derivation
-                                            sys src?))
-               (('argument . (? derivation-path? drv))
-                (call-with-input-file drv read-derivation))
-               (('argument . (? store-path?))
-                ;; Nothing to do; maybe for --log-file.
-                #f)
-               (('argument . (? string? x))
-                (let ((p (specification->package x)))
+  (let ((opts (options/with-source store
+                                   (options/resolve-packages opts))))
+    (filter-map (match-lambda
+                 (('expression . str)
+                  (derivation-from-expression store str package->derivation
+                                              sys src?))
+                 (('argument . (? package? p))
                   (if src?
                       (let ((s (package-source p)))
                         (package-source-derivation store s))
-                      (package->derivation store p sys))))
-               (_ #f))
-              opts))
+                      (package->derivation store p sys)))
+                 (('argument . (? derivation-path? drv))
+                  (call-with-input-file drv read-derivation))
+                 (('argument . (? store-path?))
+                  ;; Nothing to do; maybe for --log-file.
+                  #f)
+                 (_ #f))
+                opts)))
+
+(define (options/resolve-packages opts)
+  "Return OPTS with package specification strings replaced by actual
+packages."
+  (map (match-lambda
+        (('argument . (? string? spec))
+         (if (store-path? spec)
+             `(argument . ,spec)
+             `(argument . ,(specification->package spec))))
+        (opt opt))
+       opts))
+
+(define (options/with-source store opts)
+  "Process with 'with-source' options in OPTS, replacing the relevant package
+arguments with packages that use the specified source."
+  (define new-sources
+    (filter-map (match-lambda
+                 (('with-source . uri)
+                  (cons (package-name->name+version (basename uri))
+                        uri))
+                 (_ #f))
+                opts))
+
+  (let loop ((opts    opts)
+             (sources new-sources)
+             (result  '()))
+    (match opts
+      (()
+       (unless (null? sources)
+         (warning (_ "sources do not match any package:~{ ~a~}~%")
+                  (match sources
+                    (((name . uri) ...)
+                     uri))))
+       (reverse result))
+      ((('argument . (? package? p)) tail ...)
+       (let ((source (assoc-ref sources (package-name p))))
+         (loop tail
+               (alist-delete (package-name p) sources)
+               (alist-cons 'argument
+                           (if source
+                               (package-with-source store p source)
+                               p)
+                           result))))
+      ((('with-source . _) tail ...)
+       (loop tail sources result))
+      ((head tail ...)
+       (loop tail sources (cons head result))))))
 
 
 ;;;