derivations: Add 'map-derivation'.

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

2 files changed, 127 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.
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 273db22765..09cf81972c 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -26,6 +26,7 @@
   #:use-module ((guix packages) #:select (package-derivation))
   #:use-module ((gnu packages) #:select (search-bootstrap-binary))
   #:use-module (gnu packages bootstrap)
+  #:use-module ((gnu packages guile) #:select (guile-1.8))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -690,6 +691,35 @@ Deriver: ~a~%"
                                     ((p2 . _)
                                      (string<? p1 p2)))))))))))))
 
+
+(test-equal "map-derivation"
+  "hello"
+  (let* ((joke (package-derivation %store guile-1.8))
+         (good (package-derivation %store %bootstrap-guile))
+         (drv1 (build-expression->derivation %store "original-drv1"
+                                             (%current-system)
+                                             #f   ; systematically fail
+                                             '()
+                                             #:guile-for-build joke))
+         (drv2 (build-expression->derivation %store "original-drv2"
+                                             (%current-system)
+                                             '(call-with-output-file %output
+                                                (lambda (p)
+                                                  (display "hello" p)))
+                                             '()))
+         (drv3 (build-expression->derivation %store "drv-to-remap"
+                                             (%current-system)
+                                             '(let ((in (assoc-ref
+                                                         %build-inputs "in")))
+                                                (copy-file in %output))
+                                             `(("in" ,drv1))
+                                             #:guile-for-build joke))
+         (drv4 (map-derivation %store drv3 `((,drv1 . ,drv2)
+                                             (,joke . ,good))))
+         (out  (derivation->output-path drv4)))
+    (and (build-derivations %store (list (pk 'remapped drv4)))
+         (call-with-input-file out get-string-all))))
+
 (test-end)