gexp: Add #:target parameter to 'gexp->derivation'.

* guix/gexp.scm (lower-inputs): Add #:system and #:target.  Use
  'package->cross-derivation' when TARGET is true.  Honor SYSTEM.
  (gexp->derivation): Add #:target argument.  Pass SYSTEM and TARGET to
  'lower-inputs' and 'gexp->sexp'.
  (gexp->sexp): Add #:system and #:target.  Pass them in recursive call
  and to 'package-file'.
* tests/gexp.scm (gexp->sexp*): Add 'system' and 'target' parameters.
  ("gexp->derivation, cross-compilation"): New test.

3 files changed, 58 insertions, 15 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index a7803a4aee..8381b388cc 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2218,13 +2218,15 @@ below allow you to do that (@pxref{The Store Monad}, for more
 information about monads.)
 
 @deffn {Monadic Procedure} gexp->derivation @var{name} @var{exp} @
-       [#:system (%current-system)] [#:inputs '()] @
+       [#:system (%current-system)] [#:target #f] [#:inputs '()] @
        [#:hash #f] [#:hash-algo #f] @
        [#:recursive? #f] [#:env-vars '()] [#:modules '()] @
        [#:references-graphs #f] [#:local-build? #f] @
        [#:guile-for-build #f]
 Return a derivation @var{name} that runs @var{exp} (a gexp) with
-@var{guile-for-build} (a derivation) on @var{system}.
+@var{guile-for-build} (a derivation) on @var{system}.  When @var{target}
+is true, it is used as the cross-compilation target triplet for packages
+referred to by @var{exp}.
 
 Make @var{modules} available in the evaluation context of @var{EXP};
 @var{MODULES} is a list of names of Guile modules from the current
diff --git a/guix/gexp.scm b/guix/gexp.scm
index c9f6cbe99a..f54221feab 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -81,14 +81,20 @@
 (define raw-derivation
   (store-lift derivation))
 
-(define (lower-inputs inputs)
-  "Turn any package from INPUTS into a derivation; return the corresponding
-input list as a monadic value."
+(define* (lower-inputs inputs
+                       #:key system target)
+  "Turn any package from INPUTS into a derivation for SYSTEM; return the
+corresponding input list as a monadic value.  When TARGET is true, use it as
+the cross-compilation target triplet."
   (with-monad %store-monad
     (sequence %store-monad
               (map (match-lambda
                     (((? package? package) sub-drv ...)
-                     (mlet %store-monad ((drv (package->derivation package)))
+                     (mlet %store-monad
+                         ((drv (if target
+                                   (package->cross-derivation package target
+                                                              system)
+                                   (package->derivation package system))))
                        (return `(,drv ,@sub-drv))))
                     (((? origin? origin) sub-drv ...)
                      (mlet %store-monad ((drv (origin->derivation origin)))
@@ -99,7 +105,7 @@ input list as a monadic value."
 
 (define* (gexp->derivation name exp
                            #:key
-                           system
+                           system (target 'current)
                            hash hash-algo recursive?
                            (env-vars '())
                            (modules '())
@@ -107,7 +113,8 @@ input list as a monadic value."
                            references-graphs
                            local-build?)
   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
-derivation) on SYSTEM.
+derivation) on SYSTEM.  When TARGET is true, it is used as the
+cross-compilation target triplet for packages referred to by EXP.
 
 Make MODULES available in the evaluation context of EXP; MODULES is a list of
 names of Guile modules from the current search path to be copied in the store,
@@ -118,9 +125,21 @@ The other arguments are as for 'derivation'."
   (define %modules modules)
   (define outputs (gexp-outputs exp))
 
-  (mlet* %store-monad ((inputs   (lower-inputs (gexp-inputs exp)))
+  (mlet* %store-monad (;; The following binding is here to force
+                       ;; '%current-system' and '%current-target-system' to be
+                       ;; looked up at >>= time.
+                       (unused    (return #f))
+
                        (system -> (or system (%current-system)))
-                       (sexp     (gexp->sexp exp))
+                       (target -> (if (eq? target 'current)
+                                      (%current-target-system)
+                                      target))
+                       (inputs   (lower-inputs (gexp-inputs exp)
+                                               #:system system
+                                               #:target target))
+                       (sexp     (gexp->sexp exp
+                                             #:system system
+                                             #:target target))
                        (builder  (text-file (string-append name "-builder")
                                             (object->string sexp)))
                        (modules  (if (pair? %modules)
@@ -199,7 +218,9 @@ The other arguments are as for 'derivation'."
               '()
               (gexp-references exp)))
 
-(define* (gexp->sexp exp)
+(define* (gexp->sexp exp #:key
+                     (system (%current-system))
+                     (target (%current-target-system)))
   "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
 and in the current monad setting (system type, etc.)"
   (define (reference->sexp ref)
@@ -208,7 +229,10 @@ and in the current monad setting (system type, etc.)"
         (((? derivation? drv) (? string? output))
          (return (derivation->output-path drv output)))
         (((? package? p) (? string? output))
-         (package-file p #:output output))
+         (package-file p
+                       #:output output
+                       #:system system
+                       #:target target))
         (((? origin? o) (? string? output))
          (mlet %store-monad ((drv (origin->derivation o)))
            (return (derivation->output-path drv output))))
@@ -218,7 +242,7 @@ and in the current monad setting (system type, etc.)"
          ;; that trick.
          (return `((@ (guile) getenv) ,output)))
         ((? gexp? exp)
-         (gexp->sexp exp))
+         (gexp->sexp exp #:system system #:target target))
         (((? string? str))
          (return (if (direct-store-path? str) str ref)))
         ((refs ...)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index bdea4b8563..9cc7d41547 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -47,8 +47,11 @@
 ;; Make it the default.
 (%guile-for-build guile-for-build)
 
-(define (gexp->sexp* exp)
-  (run-with-store %store (gexp->sexp exp)
+(define* (gexp->sexp* exp #:optional
+                      (system (%current-system)) target)
+  (run-with-store %store (gexp->sexp exp
+                                     #:system system
+                                     #:target target)
                   #:guile-for-build guile-for-build))
 
 (define-syntax-rule (test-assertm name exp)
@@ -223,6 +226,20 @@
     (mlet %store-monad ((drv mdrv))
       (return (string=? system (derivation-system drv))))))
 
+(test-assertm "gexp->derivation, cross-compilation"
+  (mlet* %store-monad ((target -> "mips64el-linux")
+                       (exp    -> (gexp (list (ungexp coreutils)
+                                              (ungexp output))))
+                       (xdrv      (gexp->derivation "foo" exp
+                                                    #:target target))
+                       (refs      ((store-lift references)
+                                   (derivation-file-name xdrv)))
+                       (xcu       (package->cross-derivation coreutils
+                                                             target))
+                       (cu        (package->derivation coreutils)))
+    (return (and (member (derivation-file-name xcu) refs)
+                 (not (member (derivation-file-name cu) refs))))))
+
 (define shebang
   (string-append "#!" (derivation->output-path guile-for-build)
                  "/bin/guile --no-auto-compile"))