05/11: DRAFT gexp: Add 'object-sources'.

[guix-commits]

civodul pushed a commit to branch wip-system-bootstrap
in repository guix.

commit b806538821b171dc2be620153d256319e817302e
Author: Ludovic Courtès <address@hidden>
Date:   Fri Dec 6 23:20:00 2019 +0100

    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 | 47 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 47 insertions(+)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 8c05a39..494f094 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -84,6 +84,9 @@
             raw-derivation-closure
             raw-derivation-closure?
 
+            object-sources
+            object-sources?
+
             load-path-expression
             gexp-modules
 
@@ -316,6 +319,50 @@ The expander specifies how an object is converted to its 
sexp representation."
           (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)))
+
+  (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.