01/06: packages: Factorize computation of the replacement graft.

[Ludovic Courtès]

civodul pushed a commit to branch wip-gexp-grafts
in repository guix.

commit 2c13d74181123fac02189807ecfb36b36cdad024
Author: Ludovic Courtès <address@hidden>
Date:   Sat Jan 7 12:25:10 2017 +0100

    packages: Factorize computation of the replacement graft.
    
    * guix/packages.scm (replacement-graft, replacement-cross-graft): New
    procedures.
    (input-graft): Use 'replacement-graft'.
    (input-cross-graft): Use 'replacement-cross-graft'.
---
 guix/packages.scm |   44 +++++++++++++++++++++++++++-----------------
 1 file changed, 27 insertions(+), 17 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index beb958f..efa1623 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2014, 2015 Mark H Weaver <address@hidden>
 ;;; Copyright © 2015 Eric Bavier <address@hidden>
 ;;; Copyright © 2016 Alex Kost <address@hidden>
@@ -909,6 +909,30 @@ and return it."
   ;; replacement package.
   (make-weak-key-hash-table 200))
 
+(define (replacement-graft store package system)
+  "Return the graft for SYSTEM to replace PACKAGE by its 'replacement'."
+  (cached (=> %graft-cache) package system
+          (let ((orig (package-derivation store package system
+                                          #:graft? #f))
+                (new  (package-derivation store (package-replacement package)
+                                          system
+                                          #:graft? #t)))
+            (graft
+              (origin orig)
+              (replacement new)))))
+
+(define* (replacement-cross-graft store package system target)
+  "Return the graft to replace PACKAGE by its 'replacement' when
+cross-compiling from SYSTEM to TARGET."
+  (let ((orig (package-cross-derivation store package target system
+                                        #:graft? #f))
+        (new  (package-cross-derivation store (package-replacement package)
+                                        target system
+                                        #:graft? #t)))
+    (graft
+      (origin orig)
+      (replacement new))))
+
 (define (input-graft store system)
   "Return a procedure that, given a package with a graft, returns a graft, and
 #f otherwise."
@@ -916,14 +940,7 @@ and return it."
     ((? package? package)
      (let ((replacement (package-replacement package)))
        (and replacement
-            (cached (=> %graft-cache) package system
-                    (let ((orig (package-derivation store package system
-                                                    #:graft? #f))
-                          (new  (package-derivation store replacement system
-                                                    #:graft? #t)))
-                      (graft
-                        (origin orig)
-                        (replacement new)))))))
+            (replacement-graft store package system))))
     (x
      #f)))
 
@@ -933,14 +950,7 @@ and return it."
     ((? package? package)
     (let ((replacement (package-replacement package)))
       (and replacement
-           (let ((orig (package-cross-derivation store package target system
-                                                 #:graft? #f))
-                 (new  (package-cross-derivation store replacement
-                                                 target system
-                                                 #:graft? #t)))
-             (graft
-               (origin orig)
-               (replacement new))))))
+           (replacement-cross-graft store package system target))))
    (_
     #f)))