ci: Don't cross build bootstrap tarballs to MinGW.

[jackhill/guix/guix.git] / gnu / ci.scm

diff --git a/gnu/ci.scm b/gnu/ci.scm
index 5d5a826..33c2e84 100644 (file)
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
-;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -54,7 +54,8 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
-  #:export (hydra-jobs))
+  #:export (channel-instance->package
+            hydra-jobs))
 
 ;;; Commentary:
 ;;;
@@ -120,8 +121,12 @@ SYSTEM."
         %guile-bootstrap-tarball
         %bootstrap-tarballs))
 
-(define %packages-to-cross-build
-  %core-packages)
+(define (packages-to-cross-build target)
+  "Return the list of packages to cross-build for TARGET."
+  ;; Don't cross-build the bootstrap tarballs for MinGW.
+  (if (string-contains target "mingw")
+      (drop-right %core-packages 6)
+      %core-packages))
 
 (define %cross-targets
   '("mips64el-linux-gnu"
@@ -129,6 +134,7 @@ SYSTEM."
     "arm-linux-gnueabihf"
     "aarch64-linux-gnu"
     "powerpc-linux-gnu"
+    "riscv64-linux-gnu"
     "i586-pc-gnu"                                 ;aka. GNU/Hurd
     "i686-w64-mingw32"
     "x86_64-w64-mingw32"))
@@ -373,6 +379,17 @@ valid."
                              load-manifest)
                     manifests))))
 
+(define (find-current-checkout arguments)
+  "Find the first checkout of ARGUMENTS that provided the current file.
+Return #f if no such checkout is found."
+  (let ((current-root
+         (canonicalize-path
+          (string-append (dirname (current-filename)) "/.."))))
+    (find (lambda (argument)
+            (and=> (assq-ref argument 'file-name)
+                   (lambda (name)
+                     (string=? name current-root)))) arguments)))
+
 \f
 ;;;
 ;;; Hydra entry point.
@@ -395,13 +412,8 @@ valid."
       ((? string? str) (call-with-input-string str read))))
 
   (define checkout
-    ;; Extract metadata about the 'guix' checkout.  Its key in ARGUMENTS may
-    ;; vary, so pick up the first one that's neither 'subset' nor 'systems'.
-    (any (match-lambda
-           ((key . value)
-            (and (not (memq key '(systems subset)))
-                 value)))
-         arguments))
+    (or (find-current-checkout arguments)
+        (assq-ref arguments 'superior-guix-checkout)))
 
   (define commit
     (assq-ref checkout 'revision))
@@ -447,7 +459,7 @@ valid."
                   (map (lambda (package)
                          (package-cross-job store (job-name package)
                                             package target system))
-                       %packages-to-cross-build))
+                       (packages-to-cross-build target)))
                 (remove (either from-32-to-64? same? pointless?)
                         %cross-targets)))