Modified guix/derivations.scm diff --git a/guix/derivations.scm b/guix/derivations.scm index 17c83e9..632bf8e 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1007,40 +1009,51 @@ applied." target)))) grafts)) - (define outputs - (match (derivation-outputs drv) - (((names . outputs) ...) - (map derivation-output-path outputs)))) - - (define output-names - (match (derivation-outputs drv) - (((names . outputs) ...) - names))) - - (define build - `(begin - (use-modules (guix build graft) - (guix build utils) - (ice-9 match)) - - (let ((mapping ',mapping)) - (for-each (lambda (input output) - (format #t "rewriting '~a' to '~a'...~%" input output) - (rewrite-directory input output - `((,input . ,output) - ,@mapping))) - ',outputs - (match %outputs - (((names . files) ...) - files)))))) + (define input-mapping + (match-lambda + (($ path sub-drv) + (let ((orig (call-with-input-file path read-derivation))) + (cons orig + (graft-derivation store (derivation-name orig) orig grafts + #:guile guile + #:system system)))))) (define add-label (cut cons "x" <>)) (match grafts ((($ sources source-outputs targets target-outputs) ...) - (let ((sources (zip sources source-outputs)) - (targets (zip targets target-outputs))) + (let* ((sources (zip sources source-outputs)) + (targets (zip targets target-outputs)) + (inputs (map input-mapping (derivation-inputs drv))) + (drv (pk 'm (map-derivation store drv inputs)))) + (define outputs + (match (derivation-outputs drv) + (((names . outputs) ...) + (map derivation-output-path outputs)))) + + (define output-names + (match (derivation-outputs drv) + (((names . outputs) ...) + names))) + + (define build + `(begin + (use-modules (guix build graft) + (guix build utils) + (ice-9 match)) + + (let ((mapping ',mapping)) + (for-each (lambda (input output) + (format #t "rewriting '~a' to '~a'...~%" input output) + (rewrite-directory input output + `((,input . ,output) + ,@mapping))) + ',outputs + (match %outputs + (((names . files) ...) + files)))))) + (build-expression->derivation store name build #:system system #:guile-for-build guile Modified tests/derivations.scm diff --git a/tests/derivations.scm b/tests/derivations.scm index a69114a..608a7f6 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -851,6 +851,42 @@ Deriver: ~a~%" (string=? (readlink (string-append graft "/sh")) one) (string=? (readlink (string-append graft "/self")) graft)))))) +(test-assert "graft-derivation, recursive" + (let* ((build `(begin + (mkdir %output) + (chdir %output) + (call-with-output-file "text" + (lambda (output) + (format output "foo/~a/bar" ,%mkdir))) + (symlink ,%bash "sh"))) + (dep (build-expression->derivation %store "dep" build + #:inputs `(("a" ,%bash) + ("b" ,%mkdir)))) + (orig (build-expression->derivation %store "graft" + `(symlink + (assoc-ref %build-inputs "dep") + %output) + #:inputs `(("dep" ,dep)))) + (one (add-text-to-store %store "bash" "fake bash")) + (two (build-expression->derivation %store "mkdir" + '(call-with-output-file %output + (lambda (port) + (display "fake mkdir" port))))) + (graft (graft-derivation %store "graft" orig + (list (graft + (origin %bash) + (replacement one)) + (graft + (origin %mkdir) + (replacement two)))))) + (and (build-derivations %store (list graft)) + (let ((two (derivation->output-path two)) + (graft (derivation->output-path graft))) + (and (string=? (format #f "foo/~a/bar" two) + (call-with-input-file (string-append graft "/text") + get-string-all)) + (string=? (readlink (string-append graft "/sh")) one)))))) + (test-equal "map-derivation" "hello" (let* ((joke (package-derivation %store guile-1.8))