derivations: Add 'map-derivation'.

* guix/derivations.scm (map-derivation): New procedure.
* tests/derivations.scm ("map-derivation"): New test.

1 files changed, 97 insertions, 0 deletions

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 48e9d5ec05..011f4b778b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -25,6 +25,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 vlist)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix hash)
@@ -63,6 +64,7 @@
             derivation-path->output-path
             derivation-path->output-paths
             derivation
+            map-derivation
 
             %guile-for-build
             imported-modules
@@ -655,6 +657,101 @@ the build environment in the corresponding file, in a simple text format."
                                         inputs))))
       (set-file-name drv file))))
 
+(define* (map-derivation store drv mapping
+                         #:key (system (%current-system)))
+  "Given MAPPING, a list of pairs of derivations, return a derivation based on
+DRV where all the 'car's of MAPPING have been replaced by its 'cdr's,
+recursively."
+  (define (substitute str initial replacements)
+    (fold (lambda (path replacement result)
+            (string-replace-substring result path
+                                      replacement))
+          str
+          initial replacements))
+
+  (define (substitute-file file initial replacements)
+    (define contents
+      (with-fluids ((%default-port-encoding #f))
+        (call-with-input-file file get-string-all)))
+
+    (let ((updated (substitute contents initial replacements)))
+      (if (string=? updated contents)
+          file
+          ;; XXX: permissions aren't preserved.
+          (add-text-to-store store (store-path-package-name file)
+                             updated))))
+
+  (define input->output-paths
+    (match-lambda
+     ((drv)
+      (list (derivation->output-path drv)))
+     ((drv sub-drvs ...)
+      (map (cut derivation->output-path drv <>)
+           sub-drvs))))
+
+  (let ((mapping (fold (lambda (pair result)
+                         (match pair
+                           ((orig . replacement)
+                            (vhash-cons (derivation-file-name orig)
+                                        replacement result))))
+                       vlist-null
+                       mapping)))
+    (define rewritten-input
+      ;; Rewrite the given input according to MAPPING, and return an input
+      ;; in the format used in 'derivation' calls.
+      (memoize
+       (lambda (input loop)
+         (match input
+           (($ <derivation-input> path (sub-drvs ...))
+            (match (vhash-assoc path mapping)
+              ((_ . replacement)
+               (cons replacement sub-drvs))
+              (#f
+               (let* ((drv (loop (call-with-input-file path read-derivation))))
+                 (cons drv sub-drvs)))))))))
+
+    (let loop ((drv drv))
+      (let* ((inputs       (map (cut rewritten-input <> loop)
+                                (derivation-inputs drv)))
+             (initial      (append-map derivation-input-output-paths
+                                       (derivation-inputs drv)))
+             (replacements (append-map input->output-paths inputs))
+
+             ;; Sources typically refer to the output directories of the
+             ;; original inputs, INITIAL.  Rewrite them by substituting
+             ;; REPLACEMENTS.
+             (sources      (map (cut substitute-file <> initial replacements)
+                                (derivation-sources drv)))
+
+             ;; Now augment the lists of initials and replacements.
+             (initial      (append (derivation-sources drv) initial))
+             (replacements (append sources replacements))
+             (name         (store-path-package-name
+                            (string-drop-right (derivation-file-name drv)
+                                               4))))
+        (derivation store name
+                    (substitute (derivation-builder drv)
+                                initial replacements)
+                    (map (cut substitute <> initial replacements)
+                         (derivation-builder-arguments drv))
+                    #:system system
+                    #:env-vars (map (match-lambda
+                                     ((var . value)
+                                      `(,var
+                                        . ,(substitute value initial
+                                                       replacements))))
+                                    (derivation-builder-environment-vars drv))
+                    #:inputs (append (map list sources) inputs)
+                    #:outputs (map car (derivation-outputs drv))
+                    #:hash (match (derivation-outputs drv)
+                             ((($ <derivation-output> _ algo hash))
+                              hash)
+                             (_ #f))
+                    #:hash-algo (match (derivation-outputs drv)
+                                  ((($ <derivation-output> _ algo hash))
+                                   algo)
+                                  (_ #f)))))))
+
 
 ;;;
 ;;; Store compatibility layer.