guix: packages: Add package-direct-sources and package-transitive-sources.

* guix/tests.scm (dummy-origin): New syntax.
* guix/packages.scm (package-direct-sources)
  (package-transitive-sources): New procedures.
* tests/packages.scm ("package-direct-sources, no source")
  ("package-direct-sources, #f source")
  ("package-direct-sources, not input source", "package-direct-sources")
  ("package-transitive-sources"): Test them.

guix/packages.scm

@@ -83,6 +83,8 @@ (define-module (guix packages)
             package-location
             package-field-location
 
+            package-direct-sources
+            package-transitive-sources
             package-direct-inputs
             package-transitive-inputs
             package-transitive-target-inputs
@@ -540,6 +542,28 @@ (define (transitive-inputs inputs)
       ((input rest ...)
        (loop rest (cons input result))))))
 
+(define (package-direct-sources 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-sources package)
+  "Return PACKAGE's direct sources, and their direct sources, recursively."
+  (delete-duplicates
+   (concatenate (filter-map (match-lambda
+                             ((_ (? origin? orig) _ ...)
+                              (list orig))
+                             ((_ (? package? p) _ ...)
+                              (package-direct-sources p))
+                             (_ #f))
+                            (bag-transitive-inputs
+                             (package->bag package))))))
+
 (define (package-direct-inputs package)
   "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
 with their propagated inputs."

guix/tests.scm

@@ -37,7 +37,8 @@ (define-module (guix tests)
             %substitute-directory
             with-derivation-narinfo
             with-derivation-substitute
-            dummy-package))
+            dummy-package
+            dummy-origin))
 
 ;;; Commentary:
 ;;;
@@ -219,6 +220,13 @@ (define-syntax-rule (dummy-package name* extra-fields ...)
            (synopsis #f) (description #f)
            (home-page #f) (license #f)))
 
+(define-syntax-rule (dummy-origin extra-fields ...)
+  "Return a \"dummy\" origin, with all its compulsory fields initialized with
+default values, and with EXTRA-FIELDS set as specified."
+  (origin extra-fields ...
+          (method #f) (uri "http://www.example.com")
+          (sha256 (base32 (make-string 52 #\x)))))
+
 ;; Local Variables:
 ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
 ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)

tests/packages.scm

@@ -155,6 +155,36 @@ (define read-at
           (package-transitive-supported-systems d)
           (package-transitive-supported-systems e))))
 
+(let* ((o (dummy-origin))
+       (u (dummy-origin))
+       (i (dummy-origin))
+       (a (dummy-package "a"))
+       (b (dummy-package "b"
+            (inputs `(("a" ,a) ("i" ,i)))))
+       (c (package (inherit b) (source o)))
+       (d (dummy-package "d"
+            (build-system trivial-build-system)
+            (source u) (inputs `(("c" ,c))))))
+  (test-assert "package-direct-sources, no source"
+    (null? (package-direct-sources a)))
+  (test-equal "package-direct-sources, #f source"
+    (list i)
+    (package-direct-sources b))
+  (test-equal "package-direct-sources, not input source"
+    (list u)
+    (package-direct-sources d))
+  (test-assert "package-direct-sources"
+    (let ((s (package-direct-sources c)))
+      (and (= (length (pk 's-sources s)) 2)
+           (member o s)
+           (member i s))))
+  (test-assert "package-transitive-sources"
+    (let ((s (package-transitive-sources d)))
+      (and (= (length (pk 'd-sources s)) 3)
+           (member o s)
+           (member i s)
+           (member u s)))))
+
 (test-equal "package-transitive-supported-systems, implicit inputs"
   %supported-systems