From 8fe7504a0935de7f0c8cba1236f3114d4e368093 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 13 May 2020 14:35:20 +0200 Subject: [PATCH 2/2] gexp: Add 'let-system'. * guix/gexp.scm (): New record type. (let-system): New macro. (system-binding-compiler): New procedure. (default-expander): Add catch-all case. * tests/gexp.scm ("let-system", "let-system, target") ("let-system, ungexp-native, target") ("let-system, nested"): New tests. * doc/guix.texi (G-Expressions): Document it. --- doc/guix.texi | 26 +++++++++++++++++++++++++ guix/gexp.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++- tests/gexp.scm | 50 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 126 insertions(+), 1 deletion(-) diff --git a/doc/guix.texi b/doc/guix.texi index d6fbd85fde..0281a4be45 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7811,6 +7811,32 @@ are also added to the load path of the gexp returned by Return @code{#t} if @var{obj} is a G-expression. @end deffn +@deffn {Scheme Syntax} let-system @var{system} +@deffnx {Scheme Syntax} let-system (@var{system} @var{target}) +Bind @var{system} to the currently targeted system---e.g., +@code{"x86_64-linux"}---within @var{body}. + +In the second case, additionally bind @var{target} to the current +cross-compilation target---a GNU triplet such as +@code{"arm-linux-gnueabihf"}---or @code{#f} if we are not +cross-compiling. + +@code{let-system} is useful in the occasional case where the object +spliced into the gexp depends on the target system, as in this example: + +@example +#~(system* + #+(let-system system + (cond ((string-prefix? "armhf-" system) + (file-append qemu "/bin/qemu-system-arm")) + ((string-prefix? "x86_64-" system) + (file-append qemu "/bin/qemu-system-x86_64")) + (else + (error "dunno!")))) + "-net" "user" #$image) +@end example +@end deffn + G-expressions are meant to be written to disk, either as code building some derivation, or as plain files in the store. The monadic procedures below allow you to do that (@pxref{The Store Monad}, for more diff --git a/guix/gexp.scm b/guix/gexp.scm index a9a4b89ab4..a70b723e57 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -112,6 +112,7 @@ gexp-compiler? file-like? lower-object + let-system lower-inputs @@ -195,7 +196,9 @@ returns its output file name of OBJ's OUTPUT." ((? derivation? drv) (derivation->output-path drv output)) ((? string? file) - file))) + file) + (obj ;lists, vectors, etc. + obj))) (define (register-compiler! compiler) "Register COMPILER as a gexp compiler." @@ -324,6 +327,52 @@ The expander specifies how an object is converted to its sexp representation." (derivation-file-name lowered) lowered))) + +;;; +;;; System dependencies. +;;; + +;; Binding form for the current system and cross-compilation target. +(define-record-type + (system-binding proc) + system-binding? + (proc system-binding-proc)) + +(define-syntax let-system + (syntax-rules () + "Introduce a system binding in a gexp. The simplest form is: + + (let-system system + (cond ((string=? system \"x86_64-linux\") ...) + (else ...))) + +which binds SYSTEM to the currently targeted system. The second form is +similar, but it also shows the cross-compilation target: + + (let-system (system target) + ...) + +Here TARGET is bound to the cross-compilation triplet or #f." + ((_ (system target) exp0 exp ...) + (system-binding (lambda (system target) + exp0 exp ...))) + ((_ system exp0 exp ...) + (system-binding (lambda (system target) + exp0 exp ...))))) + +(define-gexp-compiler system-binding-compiler + compiler => (lambda (binding system target) + (match binding + (($ proc) + (with-monad %store-monad + ;; PROC is expected to return a lowerable object. + ;; 'lower-object' takes care of residualizing it to a + ;; derivation or similar. + (return (proc system target)))))) + + ;; Delegate to the expander of the object returned by PROC. + expander => #f) + ;;; ;;; File declarations. diff --git a/tests/gexp.scm b/tests/gexp.scm index 6a42d3eb57..c1d65b2c4e 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -322,6 +322,56 @@ (string-append (derivation->output-path drv) "/bin/touch")))))) +(test-equal "let-system" + (list `(begin ,(%current-system) #t) '(system-binding) '()) + (let ((exp #~(begin + #$(let-system system system) + #t))) + (list (gexp->sexp* exp) + (match (gexp-inputs exp) + (((($ (@@ (guix gexp) )) "out")) + '(system-binding)) + (x x)) + (gexp-native-inputs exp)))) + +(test-equal "let-system, target" + (list `(list ,(%current-system) #f) + `(list ,(%current-system) "aarch64-linux-gnu")) + (let ((exp #~(list #$@(let-system (system target) + (list system target))))) + (list (gexp->sexp* exp) + (gexp->sexp* exp "aarch64-linux-gnu")))) + +(test-equal "let-system, ungexp-native, target" + `(here it is: ,(%current-system) #f) + (let ((exp #~(here it is: #+@(let-system (system target) + (list system target))))) + (gexp->sexp* exp "aarch64-linux-gnu"))) + +(test-equal "let-system, nested" + (list `(system* ,(string-append "qemu-system-" (%current-system)) + "-m" "256") + '() + '(system-binding)) + (let ((exp #~(system* + #+(let-system (system target) + (file-append (@@ (gnu packages virtualization) + qemu) + "/bin/qemu-system-" + system)) + "-m" "256"))) + (list (match (gexp->sexp* exp) + (('system* command rest ...) + `(system* ,(and (string-prefix? (%store-prefix) command) + (basename command)) + ,@rest)) + (x x)) + (gexp-inputs exp) + (match (gexp-native-inputs exp) + (((($ (@@ (guix gexp) )) "out")) + '(system-binding)) + (x x))))) + (test-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) (ungexp coreutils) -- 2.26.2