From 18c10b055e7b12cb33f69fabea04dc96c5b95906 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 6 Dec 2019 23:20:00 +0100
Subject: DRAFT gexp: Add 'object-sources'.

DRAFT: Add tests.

* guix/gexp.scm (<object-sources>): New record type.
(object-sources-compiler): New gexp compiler.
---
 guix/gexp.scm | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 54 insertions(+)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 7bfff07766..ebde9eb7db 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -85,6 +85,9 @@ (define-module (guix gexp)
             raw-derivation-closure
             raw-derivation-closure?
 
+            object-sources
+            object-sources?
+
             load-path-expression
             gexp-modules
 
@@ -323,6 +326,57 @@ (define-gexp-compiler (raw-derivation-closure-compiler
           (text-file "graph" (object->string refs)))
         (return obj))))
 
+;; Representation of all the sources and fixed-output derivations OBJ refers
+;; to, directly or indirectly.
+(define-record-type <object-sources>
+  (object-sources obj)
+  object-sources?
+  (obj   object-sources-object))
+
+(define-gexp-compiler (object-sources-compiler (obj <object-sources>)
+                                               system target)
+  (define (derivation-fixed-output-requirements drv)
+    (derivation-input-fold (lambda (input result)
+                             (let ((drv (derivation-input-derivation input)))
+                               (if (fixed-output-derivation? drv)
+                                   (cons drv result)
+                                   result)))
+                           '()
+                           (derivation-inputs drv)
+
+                           ;; Skip the dependencies of fixed-output
+                           ;; derivations (e.g., 'git' for a 'git-fetch'
+                           ;; derivation.)
+                           #:skip-dependencies?
+                           (compose fixed-output-derivation?
+                                    derivation-input-derivation)))
+
+  (define (derivation-recursive-sources drv)
+    (delete-duplicates
+     (derivation-input-fold (lambda (input result)
+                              (let ((drv (derivation-input-derivation input)))
+                                (append (derivation-sources drv)
+                                        result)))
+                            '()
+                            (derivation-inputs drv))))
+
+  (mlet %store-monad ((obj (lower-object (object-sources-object obj)
+                                         system #:target target)))
+    (if (derivation? obj)
+        (let* ((drvs    (derivation-fixed-output-requirements obj))
+               (sources (derivation-recursive-sources obj))
+               (pairs   (append (map (lambda (drv)
+                                       `(,(store-path-package-name
+                                           (derivation-file-name drv))
+                                         ,drv))
+                                     drvs)
+                                (map (lambda (file)
+                                       `(,(basename file) ,file))
+                                     sources)))
+               (union   (file-union "sources" pairs)))
+          (lower-object union system #:target target))
+        (return obj))))
+
 
 ;;;
 ;;; File declarations.
-- 
cgit v1.2.3