summaryrefslogtreecommitdiff
path: root/guix/grafts.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/grafts.scm')
-rw-r--r--guix/grafts.scm104
1 files changed, 98 insertions, 6 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm
index ea53959b37..9bcc5e2ef8 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -17,11 +17,14 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix grafts)
+ #:use-module (guix store)
+ #:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module ((guix utils) #:select (%current-system))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (graft?
@@ -32,6 +35,7 @@
graft-replacement-output
graft-derivation
+ graft-derivation/shallow
%graft?
set-grafting))
@@ -61,13 +65,22 @@
(set-record-type-printer! <graft> write-graft)
-(define* (graft-derivation store drv grafts
- #:key
- (name (derivation-name drv))
- (guile (%guile-for-build))
- (system (%current-system)))
+(define (graft-origin-file-name graft)
+ "Return the output file name of the origin of GRAFT."
+ (match graft
+ (($ <graft> (? derivation? origin) output)
+ (derivation->output-path origin output))
+ (($ <graft> (? string? item))
+ item)))
+
+(define* (graft-derivation/shallow store drv grafts
+ #:key
+ (name (derivation-name drv))
+ (guile (%guile-for-build))
+ (system (%current-system)))
"Return a derivation called NAME, based on DRV but with all the GRAFTS
-applied."
+applied. This procedure performs \"shallow\" grafting in that GRAFTS are not
+recursively applied to dependencies of DRV."
;; XXX: Someday rewrite using gexps.
(define mapping
;; List of store item pairs.
@@ -133,6 +146,85 @@ applied."
(map add-label targets)))
#:outputs output-names
#:local-build? #t)))))
+(define (item->deriver store item)
+ "Return two values: the derivation that led to ITEM (a store item), and the
+name of the output of that derivation ITEM corresponds to (for example
+\"out\"). When ITEM has no deriver, for instance because it is a plain file,
+#f and #f are returned."
+ (match (valid-derivers store item)
+ (() ;ITEM is a plain file
+ (values #f #f))
+ ((drv-file _ ...)
+ (let ((drv (call-with-input-file drv-file read-derivation)))
+ (values drv
+ (any (match-lambda
+ ((name . path)
+ (and (string=? item path) name)))
+ (derivation->output-paths drv)))))))
+
+(define (non-self-references store drv outputs)
+ "Return the list of references of the OUTPUTS of DRV, excluding self
+references."
+ (let ((refs (append-map (lambda (output)
+ (references store
+ (derivation->output-path drv output)))
+ outputs))
+ (self (match (derivation->output-paths drv)
+ (((names . items) ...)
+ items))))
+ (remove (cut member <> self) refs)))
+
+(define* (cumulative-grafts store drv grafts
+ #:key
+ (outputs (derivation-output-names drv))
+ (guile (%guile-for-build))
+ (system (%current-system)))
+ "Augment GRAFTS with additional grafts resulting from the application of
+GRAFTS to the dependencies of DRV. Return the resulting list of grafts."
+ (define (dependency-grafts item)
+ (let-values (((drv output) (item->deriver store item)))
+ (if drv
+ (cumulative-grafts store drv grafts
+ #:outputs (list output)
+ #:guile guile
+ #:system system)
+ grafts)))
+
+ ;; TODO: Memoize.
+ (match (non-self-references store drv outputs)
+ (() ;no dependencies
+ grafts)
+ (deps ;one or more dependencies
+ (let* ((grafts (delete-duplicates (append-map dependency-grafts deps)
+ eq?))
+ (origins (map graft-origin-file-name grafts)))
+ (if (find (cut member <> deps) origins)
+ (let ((new (graft-derivation/shallow store drv grafts
+ #:guile guile
+ #:system system)))
+ (cons (graft (origin drv) (replacement new))
+ grafts))
+ grafts)))))
+
+(define* (graft-derivation store drv grafts
+ #:key (guile (%guile-for-build))
+ (system (%current-system)))
+ "Applied GRAFTS to DRV and all its dependencies, recursively. That is, if
+GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft
+DRV itself to refer to those grafted dependencies."
+
+ ;; First, we need to build the ungrafted DRV so we can query its run-time
+ ;; dependencies in 'cumulative-grafts'.
+ (build-derivations store (list drv))
+
+ (match (cumulative-grafts store drv grafts
+ #:guile guile #:system system)
+ ((first . rest)
+ ;; If FIRST is not a graft for DRV, it means that GRAFTS are not
+ ;; applicable to DRV and nothing needs to be done.
+ (if (equal? drv (graft-origin first))
+ (graft-replacement first)
+ drv))))
;; The following might feel more at home in (guix packages) but since (guix