From a63062b55a6592467816571fd7983f4e88903c0a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 20 May 2013 23:00:47 +0200
Subject: packages: Factorize things common to `package-{,cross-}derivation'.

* guix/packages.scm (expand-input): New procedure, moved out of...
  (package-derivation): ... here.  Adjust accordingly.
  (package-cross-derivation): Add `cross-system' and `system'
  parameters.
---
 guix/packages.scm | 72 +++++++++++++++++++++++++++++++------------------------
 1 file changed, 41 insertions(+), 31 deletions(-)

(limited to 'guix')

diff --git a/guix/packages.scm b/guix/packages.scm
index 0549771cea..242b912d5d 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -27,6 +27,7 @@ (define-module (guix packages)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:re-export (%current-system)
@@ -305,41 +306,47 @@ (define-syntax-rule (cached package system body ...)
       (#f
        (cache package system thunk)))))
 
-(define* (package-derivation store package
-                             #:optional (system (%current-system)))
-  "Return the derivation path and corresponding <derivation> object of
-PACKAGE for SYSTEM."
+(define* (expand-input store package input system #:optional cross-system)
+  "Expand INPUT, an input tuple, such that it contains only references to
+derivation paths or store paths.  PACKAGE is only used to provide contextual
+information in exceptions."
   (define (intern file)
     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
     ;; file permissions are preserved.
     (add-to-store store (basename file) #t "sha256" file))
 
-  (define expand-input
-    ;; Expand the given input tuple such that it contains only
-    ;; references to derivation paths or store paths.
-    (match-lambda
-     (((? string? name) (? package? package))
-      (list name (package-derivation store package system)))
-     (((? string? name) (? package? package)
-       (? string? sub-drv))
-      (list name (package-derivation store package system)
-            sub-drv))
-     (((? string? name)
-       (and (? string?) (? derivation-path?) drv))
-      (list name drv))
-     (((? string? name)
-       (and (? string?) (? file-exists? file)))
-      ;; Add FILE to the store.  When FILE is in the sub-directory of a
-      ;; store path, it needs to be added anyway, so it can be used as a
-      ;; source.
-      (list name (intern file)))
-     (((? string? name) (? origin? source))
-      (list name (package-source-derivation store source system)))
-     (x
-      (raise (condition (&package-input-error
-                         (package package)
-                         (input   x)))))))
+  (define derivation
+    (if cross-system
+        (cut package-cross-derivation store <> cross-system system)
+        (cut package-derivation store <> system)))
+
+  (match input
+    (((? string? name) (? package? package))
+     (list name (derivation package)))
+    (((? string? name) (? package? package)
+      (? string? sub-drv))
+     (list name (derivation package)
+           sub-drv))
+    (((? string? name)
+      (and (? string?) (? derivation-path?) drv))
+     (list name drv))
+    (((? string? name)
+      (and (? string?) (? file-exists? file)))
+     ;; Add FILE to the store.  When FILE is in the sub-directory of a
+     ;; store path, it needs to be added anyway, so it can be used as a
+     ;; source.
+     (list name (intern file)))
+    (((? string? name) (? origin? source))
+     (list name (package-source-derivation store source system)))
+    (x
+     (raise (condition (&package-input-error
+                        (package package)
+                        (input   x)))))))
 
+(define* (package-derivation store package
+                             #:optional (system (%current-system)))
+  "Return the derivation path and corresponding <derivation> object of
+PACKAGE for SYSTEM."
   ;; Compute the derivation and cache the result.  Caching is important
   ;; because some derivations, such as the implicit inputs of the GNU build
   ;; system, will be queried many, many times in a row.
@@ -353,7 +360,9 @@ (define expand-input
                   args inputs propagated-inputs native-inputs self-native-input?
                   outputs)
                (let* ((inputs     (package-transitive-inputs package))
-                      (input-drvs (map expand-input inputs))
+                      (input-drvs (map (cut expand-input
+                                            store package <> system)
+                                       inputs))
                       (paths      (delete-duplicates
                                    (append-map (match-lambda
                                                 ((_ (? package? p) _ ...)
@@ -371,7 +380,8 @@ (define expand-input
                         #:outputs outputs #:system system
                         (args))))))))
 
-(define* (package-cross-derivation store package)
+(define* (package-cross-derivation store package cross-system
+                                   #:optional (system (%current-system)))
   ;; TODO
   #f)
 
-- 
cgit v1.2.3