Take advantage of the new (guix platform) module

This means there's less reliance on the hardcoded lists of systems and targets
and mappings between them.
This commit is contained in:
Christopher Baines 2022-05-26 00:24:55 +01:00
parent 786a5fa041
commit fb8353559f

View file

@ -353,9 +353,30 @@ WHERE job_id = $1")
lock time-spent)) lock time-spent))
result))))) result)))))
(define (inferior-guix-systems inf)
(cond
((inferior-eval
'(defined? 'systems
(resolve-module '(guix platform)))
inf)
(remove
(lambda (system)
;; There aren't currently bootstrap binaries for s390x-linux, so this
;; just leads to lots of errors
(string=? system "s390x-linux"))
(inferior-eval
'((@ (guix platform) systems))
inf)))
(else
(inferior-eval
'(@ (guix packages) %supported-systems)
inf))))
(define (all-inferior-system-tests inf store) (define (all-inferior-system-tests inf store)
(define inferior-%supported-systems (define inf-systems
(inferior-eval '(@ (guix packages) %supported-systems) inf)) (inferior-guix-systems inf))
(define extract (define extract
`(lambda (store) `(lambda (store)
@ -387,7 +408,7 @@ WHERE job_id = $1")
system system
key args) key args)
#f))) #f)))
(list ,@inferior-%supported-systems)) (list ,@inf-systems))
(match (system-test-location system-test) (match (system-test-location system-test)
(($ <location> file line column) (($ <location> file line column)
(list file (list file
@ -591,24 +612,37 @@ WHERE job_id = $1")
checkers)))) checkers))))
(define (all-inferior-package-derivations store inf packages) (define (all-inferior-package-derivations store inf packages)
(define inferior-%supported-systems (define inf-systems
(inferior-eval '(@ (guix packages) %supported-systems) inf)) (inferior-guix-systems inf))
(define inf-targets
(cond
((inferior-eval
'(defined? 'targets
(resolve-module '(guix platform)))
inf)
(inferior-eval
'((@ (guix platform) targets))
inf))
(else
'("arm-linux-gnueabihf"
"aarch64-linux-gnu"
"mips64el-linux-gnu"
"powerpc-linux-gnu"
"powerpc64le-linux-gnu"
"riscv64-linux-gnu"
"i586-pc-gnu"
"i686-w64-mingw32"
"x86_64-w64-mingw32"))))
(define cross-derivations (define cross-derivations
`(("x86_64-linux" . ("arm-linux-gnueabihf" `(("x86_64-linux" . ,inf-targets)))
"aarch64-linux-gnu"
"mips64el-linux-gnu"
"powerpc-linux-gnu"
"powerpc64le-linux-gnu"
"riscv64-linux-gnu"
"i586-pc-gnu"
"i686-w64-mingw32"
"x86_64-w64-mingw32"))))
(define supported-system-pairs (define supported-system-pairs
(map (lambda (system) (map (lambda (system)
(cons system #f)) (cons system #f))
inferior-%supported-systems)) inf-systems))
(define supported-system-cross-build-pairs (define supported-system-cross-build-pairs
(append-map (append-map
@ -622,13 +656,22 @@ WHERE job_id = $1")
(define (proc packages system-target-pairs) (define (proc packages system-target-pairs)
`(lambda (store) `(lambda (store)
(define target-system-alist (define target-system-alist
'(("arm-linux-gnueabihf" . "armhf-linux") (if (defined? 'platforms (resolve-module '(guix platform)))
("aarch64-linux-gnu" . "aarch64-linux") (filter-map
("mips64el-linux-gnu" . "mips64el-linux") (lambda (platform)
("powerpc-linux-gnu" . "powerpc-linux") (and
("powerpc64le-linux-gnu" . "powerpc64le-linux") (platform-target platform)
("riscv64-linux-gnu" . "riscv64-linux") (cons (platform-target platform)
("i586-pc-gnu" . "i586-gnu"))) (platform-system platform))))
(platforms))
'(("arm-linux-gnueabihf" . "armhf-linux")
("aarch64-linux-gnu" . "aarch64-linux")
("mips64el-linux-gnu" . "mips64el-linux")
("powerpc-linux-gnu" . "powerpc-linux")
("powerpc64le-linux-gnu" . "powerpc64le-linux")
("riscv64-linux-gnu" . "riscv64-linux")
("i586-pc-gnu" . "i586-gnu"))))
(define package-transitive-supported-systems-supports-multiple-arguments? #t) (define package-transitive-supported-systems-supports-multiple-arguments? #t)
(define (get-supported-systems package system) (define (get-supported-systems package system)
@ -749,6 +792,11 @@ WHERE job_id = $1")
'())))))) '()))))))
(list ,@(map inferior-package-id packages))))) (list ,@(map inferior-package-id packages)))))
(inferior-eval
'(when (defined? 'systems (resolve-module '(guix platform)))
(use-modules (guix platform)))
inf)
(append-map (append-map
(lambda (system-target-pair) (lambda (system-target-pair)
(format (current-error-port) (format (current-error-port)