From 81d161e418753ce2d136ea901cc28b11cee26314 Mon Sep 17 00:00:00 2001
From: Eric Bavier <bavier@member.fsf.org>
Date: Wed, 28 Jan 2015 13:33:28 -0600
Subject: [PATCH] guix: build: Add transitive source building.

* guix/scripts/build.scm [--source]: Add optional arguments 'package',
  'all', and 'transitive'.
  (package-source*, package-direct-source, package-transitive-source):
  New procedures.
  (options->derivations)[--source]: Use them.
---
 guix/scripts/build.scm |   78 ++++++++++++++++++++++++++++++++++++------------
 1 file changed, 59 insertions(+), 19 deletions(-)

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 07ced30..8a422fe 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -262,10 +262,21 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
          (option '(#\V "version") #f #f
                  (lambda args
                    (show-version-and-exit "guix build")))
-
-         (option '(#\S "source") #f #f
+         (option '(#\S "source") #f #t
                  (lambda (opt name arg result)
-                   (alist-cons 'source? #t result)))
+                   (match arg
+                     ("package"
+                      (alist-cons 'source package-source* result))
+                     ("all"
+                      (alist-cons 'source package-direct-source result))
+                     ("transitive"
+                      (alist-cons 'source package-transitive-source result))
+                     (#f
+                      (alist-cons 'source package-source* result))
+                     (else
+                      (leave (_ "invalid argument: '~a' option argument: ~a, ~
+must be one of 'package', 'all', or 'transitive'~%")
+                             name arg)))))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
@@ -299,6 +310,32 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
 
          %standard-build-options))
 
+(define (package-source* package)
+  "List package-source but returns its results as a list"
+  (list (package-source package)))
+
+(define (package-direct-source package)
+  "Return all source origins associated with PACKAGE; including origins in
+PACKAGE's inputs."
+  `(,@(or (and=> (package-source package) list) '())
+    ,@(filter-map (match-lambda
+                   ((_ (? origin? orig) _ ...)
+                    orig)
+                   (_ #f))
+                  (package-direct-inputs package))))
+
+(define (package-transitive-source package)
+  "Return PACKAGE's direct sources, and its input sources, recursively."
+  (delete-duplicates
+   (concatenate (filter-map (match-lambda
+                             ((_ (? origin? orig) _ ...)
+                              (list orig))
+                             ((_ (? package? p) _ ...)
+                              (package-direct-source p))
+                             (_ #f))
+                            (bag-transitive-inputs
+                             (package->bag package))))))
+
 (define (options->derivations store opts)
   "Given OPTS, the result of 'args-fold', return a list of derivations to
 build."
@@ -308,28 +345,31 @@ build."
       (triplet
        (cut package-cross-derivation <> <> triplet <>))))
 
-  (define src?   (assoc-ref opts 'source?))
+  (define src    (assoc-ref opts 'source))
   (define sys    (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
 
   (parameterize ((%graft? graft?))
     (let ((opts (options/with-source store
                                      (options/resolve-packages store opts))))
-      (filter-map (match-lambda
-                   (('argument . (? package? p))
-                    (if src?
-                        (let ((s (package-source p)))
-                          (package-source-derivation store s))
-                        (package->derivation store p sys)))
-                   (('argument . (? derivation? drv))
-                    drv)
-                   (('argument . (? derivation-path? drv))
-                    (call-with-input-file drv read-derivation))
-                   (('argument . (? store-path?))
-                    ;; Nothing to do; maybe for --log-file.
-                    #f)
-                   (_ #f))
-                  opts))))
+      (concatenate
+       (filter-map (match-lambda
+                    (('argument . (? package? p))
+                     (match src
+                       (#f
+                        (list (package->derivation store p sys)))
+                       (proc
+                        (map (cut package-source-derivation store <>)
+                             (proc p)))))
+                    (('argument . (? derivation? drv))
+                     (list drv))
+                    (('argument . (? derivation-path? drv))
+                     (list (call-with-input-file drv read-derivation)))
+                    (('argument . (? store-path?))
+                     ;; Nothing to do; maybe for --log-file.
+                     #f)
+                    (_ #f))
+                   opts)))))
 
 (define (options/resolve-packages store opts)
   "Return OPTS with package specification strings replaced by actual
-- 
1.7.9.5