diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | doc/guix.texi | 26 | ||||
| -rw-r--r-- | guix/gexp.scm | 110 | ||||
| -rw-r--r-- | tests/gexp.scm | 54 |
4 files changed, 165 insertions, 26 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index ce305602f2..fcde914e60 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -85,6 +85,7 @@ (eval . (put 'with-imported-modules 'scheme-indent-function 1)) (eval . (put 'with-extensions 'scheme-indent-function 1)) (eval . (put 'with-parameters 'scheme-indent-function 1)) + (eval . (put 'let-system 'scheme-indent-function 1)) (eval . (put 'with-database 'scheme-indent-function 2)) (eval . (put 'call-with-transaction 'scheme-indent-function 2)) diff --git a/doc/guix.texi b/doc/guix.texi index a36b9691fb..d043852ac3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8123,6 +8123,32 @@ the second case, the resulting script contains a @code{(string-append @dots{})} expression to construct the file name @emph{at run time}. @end deffn +@deffn {Scheme Syntax} let-system @var{system} @var{body}@dots{} +@deffnx {Scheme Syntax} let-system (@var{system} @var{target}) @var{body}@dots{} +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 + @deffn {Scheme Syntax} with-parameters ((@var{parameter} @var{value}) @dots{}) @var{exp} This macro is similar to the @code{parameterize} form for dynamically-bound @dfn{parameters} (@pxref{Parameters,,, guile, GNU diff --git a/guix/gexp.scm b/guix/gexp.scm index 5c614f3e12..78b8af6fbc 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -37,6 +37,7 @@ gexp? with-imported-modules with-extensions + let-system gexp-input gexp-input? @@ -195,7 +196,9 @@ returns its output file name of OBJ's OUTPUT." ((? derivation? drv) (derivation->output-path drv output)) ((? string? file) - file))) + file) + ((? self-quoting? obj) + obj))) (define (register-compiler! compiler) "Register COMPILER as a gexp compiler." @@ -329,6 +332,52 @@ The expander specifies how an object is converted to its sexp representation." ;;; +;;; System dependencies. +;;; + +;; Binding form for the current system and cross-compilation target. +(define-record-type <system-binding> + (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 <system-binding> + compiler => (lambda (binding system target) + (match binding + (($ <system-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. ;;; @@ -706,6 +755,15 @@ GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty list." (gexp-attribute gexp gexp-self-extensions)) +(define (self-quoting? x) + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? keyword? pair? null? array? + number? boolean? char?))) + (define* (lower-inputs inputs #:key system target) "Turn any object from INPUTS into a derivation input for SYSTEM or a store @@ -714,23 +772,32 @@ When TARGET is true, use it as the cross-compilation target triplet." (define (store-item? obj) (and (string? obj) (store-path? obj))) + (define filterm + (lift1 (cut filter ->bool <>) %store-monad)) + (with-monad %store-monad - (mapm/accumulate-builds - (match-lambda - (((? struct? thing) sub-drv ...) - (mlet %store-monad ((obj (lower-object - thing system #:target target))) - (return (match obj - ((? derivation? drv) - (let ((outputs (if (null? sub-drv) - '("out") - sub-drv))) - (derivation-input drv outputs))) - ((? store-item? item) - item))))) - (((? store-item? item)) - (return item))) - inputs))) + (>>= (mapm/accumulate-builds + (match-lambda + (((? struct? thing) sub-drv ...) + (mlet %store-monad ((obj (lower-object + thing system #:target target))) + (return (match obj + ((? derivation? drv) + (let ((outputs (if (null? sub-drv) + '("out") + sub-drv))) + (derivation-input drv outputs))) + ((? store-item? item) + item) + ((? self-quoting?) + ;; Some inputs such as <system-binding> can lower to + ;; a self-quoting object that FILTERM will filter + ;; out. + #f))))) + (((? store-item? item)) + (return item))) + inputs) + filterm))) (define* (lower-reference-graphs graphs #:key system target) "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a @@ -1146,15 +1213,6 @@ references; otherwise, return only non-native references." (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 (self-quoting? x) - (letrec-syntax ((one-of (syntax-rules () - ((_) #f) - ((_ pred rest ...) - (or (pred x) - (one-of rest ...)))))) - (one-of symbol? string? keyword? pair? null? array? - number? boolean? char?))) - (define* (reference->sexp ref #:optional native?) (with-monad %store-monad (match ref diff --git a/tests/gexp.scm b/tests/gexp.scm index 6a42d3eb57..e073a7b816 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -321,6 +321,60 @@ (string=? result (string-append (derivation->output-path drv) "/bin/touch")))))) +(test-equal "let-system" + (list `(begin ,(%current-system) #t) '(system-binding) '() + 'low '() '()) + (let* ((exp #~(begin + #$(let-system system system) + #t)) + (low (run-with-store %store (lower-gexp exp)))) + (list (lowered-gexp-sexp low) + (match (gexp-inputs exp) + (((($ (@@ (guix gexp) <system-binding>)) "out")) + '(system-binding)) + (x x)) + (gexp-native-inputs exp) + 'low + (lowered-gexp-inputs low) + (lowered-gexp-sources low)))) + +(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) <system-binding>)) "out")) + '(system-binding)) + (x x))))) (test-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) |