gexp: Add 'let-system'.
* guix/gexp.scm (<system-binding>): New record type.
(let-system): New macro.
(system-binding-compiler): New procedure.
(default-expander): Add 'self-quoting?' case.
(self-quoting?): New procedure.
(lower-inputs): Add 'filterm'. Pass the result of
'mapm/accumulate-builds' through FILTERM.
(gexp->sexp)[self-quoting?]: Remove.
* 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.
This commit is contained in:
Ludovic Courtès
parent
d03001a31a
commit
644cb40cd8
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
110
guix/gexp.scm
110
guix/gexp.scm
@ -37,6 +37,7 @@ (define-module (guix gexp)
|
||||
gexp?
|
||||
with-imported-modules
|
||||
with-extensions
|
||||
let-system
|
||||
|
||||
gexp-input
|
||||
gexp-input?
|
||||
@ -195,7 +196,9 @@ (define (default-expander thing obj 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."
|
||||
@ -327,6 +330,52 @@ (define-gexp-compiler raw-derivation-file-compiler <raw-derivation-file>
|
||||
(derivation-file-name lowered)
|
||||
lowered)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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 @@ (define (gexp-extensions gexp)
|
||||
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 @@ (define* (lower-inputs inputs
|
||||
(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 @@ (define* (gexp->sexp exp #:key
|
||||
(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
|
||||
|
||||
@ -321,6 +321,60 @@ (define (match-input thing)
|
||||
(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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user