02/02: PRELIMINARY: Attempt to eliminate duplicate grafts.

[Mark H. Weaver]

mhw pushed a commit to branch wip-graft-improvements
in repository guix.

commit 152788f85f23aa96f0a1363b6c4937961dbe1a7e
Author: Mark H Weaver <address@hidden>
Date:   Sun Mar 27 16:58:32 2016 -0400

    PRELIMINARY: Attempt to eliminate duplicate grafts.
---
 guix/grafts.scm |   82 ++++++++++++++++++++++++++++++++++++++++++++-----------
 1 files changed, 66 insertions(+), 16 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 6bec999..6547db5 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016 Mark H Weaver <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -86,15 +87,60 @@ recursively applied to dependencies of DRV."
   ;; XXX: Someday rewrite using gexps.
   (define mapping
     ;; List of store item pairs.
-    (map (match-lambda
-          (($ <graft> source source-output target target-output)
-           (cons (if (derivation? source)
-                     (derivation->output-path source source-output)
-                     source)
-                 (if (derivation? target)
-                     (derivation->output-path target target-output)
-                     target))))
-         grafts))
+    (delete-adjacent-duplicates
+     (sort (map (match-lambda
+                  (($ <graft> source source-output target target-output)
+                   (cons (if (derivation? source)
+                             (derivation->output-path source source-output)
+                             source)
+                         (if (derivation? target)
+                             (derivation->output-path target target-output)
+                             target))))
+                grafts)
+           string-pair-less?)))
+
+  (define string-pair-less?
+    (match-lambda*
+      (((x-origin . x-replacement) (y-origin . y-replacement))
+       (or (string<? x-origin y-origin)
+           (and (string=? x-origin y-origin)
+                (string<? x-replacement y-replacement))))))
+
+  (define (get-output-path drv sub)
+    (cond ((derivation? drv)
+           (derivation->output-path drv sub))
+          ((derivation-path? drv)
+           (derivation-path->output-path drv sub))
+          (else (error "get-output-path failed" drv sub))))
+
+  (define input-less?
+    (match-lambda*
+      (((x-name x-drv x-sub) (y-name y-drv y-sub))
+       (or (string<? x-name y-name)
+           (and (string=? x-name y-name)
+                (let ((x-path (get-output-path x-drv x-sub))
+                      (y-path (get-output-path y-drv y-sub)))
+                  (string<? x-path y-path)))))))
+
+  (define input=?
+    (match-lambda*
+      (((x-name x-drv x-sub) (y-name y-drv y-sub))
+       (and (string=? x-name y-name)
+            (let ((x-path (get-output-path x-drv x-sub))
+                  (y-path (get-output-path y-drv y-sub)))
+              (string=? x-path y-path))))))
+
+  (define* (delete-adjacent-duplicates ls #:optional (item=? equal?))
+    (match ls
+      (() '())
+      ((x . rest)
+       (let loop ((in rest) (x x) (out '()))
+         (match in
+           (() (reverse (cons x out)))
+           ((y . rest)
+            (if (item=? x y)
+                (loop rest x out)
+                (loop rest y (cons x out)))))))))
 
   (define outputs
     (map (match-lambda
@@ -134,18 +180,22 @@ recursively applied to dependencies of DRV."
 
   (match grafts
     ((($ <graft> 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 (delete-adjacent-duplicates
+                     (sort `(,@(map (lambda (out)
+                                      `("x" ,drv ,out))
+                                    output-names)
+                             ,@(append (map add-label sources)
+                                       (map add-label targets)))
+                           input-less?)
+                     input=?)))
        (build-expression->derivation store name build
                                      #:system system
                                      #:guile-for-build guile
                                      #:modules '((guix build graft)
                                                  (guix build utils))
-                                     #:inputs `(,@(map (lambda (out)
-                                                         `("x" ,drv ,out))
-                                                       output-names)
-                                                ,@(append (map add-label 
sources)
-                                                          (map add-label 
targets)))
+                                     #:inputs inputs
                                      #:outputs output-names
                                      #:local-build? #t)))))
 (define (item->deriver store item)