Browse Source

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.
gn-latest-20200725
Ludovic Courtès 4 years ago
parent
commit
644cb40cd8
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 1
      .dir-locals.el
  2. 26
      doc/guix.texi
  3. 110
      guix/gexp.scm
  4. 54
      tests/gexp.scm

1
.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))

26
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

110
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."
@ -327,6 +330,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>
(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

54
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)

Loading…
Cancel
Save