mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
gexp: Add 'lower-object'.
* guix/gexp.scm (lower-object): New procedure. (lower-inputs, lower-references, gexp->sexp): Use it. * tests/gexp.scm ("lower-object"): New test. * doc/guix.texi (G-Expressions): Document it.
This commit is contained in:
parent
f7283db37d
commit
c2b8467645
3 changed files with 45 additions and 11 deletions
|
@ -3125,9 +3125,11 @@ and these dependencies are automatically added as inputs to the build
|
||||||
processes that use them.
|
processes that use them.
|
||||||
@end itemize
|
@end itemize
|
||||||
|
|
||||||
|
@cindex lowering, of high-level objects in gexps
|
||||||
This mechanism is not limited to package and derivation
|
This mechanism is not limited to package and derivation
|
||||||
objects: @dfn{compilers} able to ``lower'' other high-level objects to
|
objects: @dfn{compilers} able to ``lower'' other high-level objects to
|
||||||
derivations can be defined, such that these objects can also be inserted
|
derivations or files in the store can be defined,
|
||||||
|
such that these objects can also be inserted
|
||||||
into gexps. For example, a useful type of high-level object that can be
|
into gexps. For example, a useful type of high-level object that can be
|
||||||
inserted in a gexp is ``file-like objects'', which make it easy to
|
inserted in a gexp is ``file-like objects'', which make it easy to
|
||||||
add files to the store and refer to them in
|
add files to the store and refer to them in
|
||||||
|
@ -3400,6 +3402,20 @@ also modules containing build tools. To make it clear that they are
|
||||||
meant to be used in the build stratum, these modules are kept in the
|
meant to be used in the build stratum, these modules are kept in the
|
||||||
@code{(guix build @dots{})} name space.
|
@code{(guix build @dots{})} name space.
|
||||||
|
|
||||||
|
@cindex lowering, of high-level objects in gexps
|
||||||
|
Internally, high-level objects are @dfn{lowered}, using their compiler,
|
||||||
|
to either derivations or store items. For instance, lowering a package
|
||||||
|
yields a derivation, and lowering a @code{plain-file} yields a store
|
||||||
|
item. This is achieved using the @code{lower-object} monadic procedure.
|
||||||
|
|
||||||
|
@deffn {Monadic Procedure} lower-object @var{obj} [@var{system}] @
|
||||||
|
[#:target #f]
|
||||||
|
Return as a value in @var{%store-monad} the derivation or store item
|
||||||
|
corresponding to @var{obj} for @var{system}, cross-compiling for
|
||||||
|
@var{target} if @var{target} is true. @var{obj} must be an object that
|
||||||
|
has an associated gexp compiler, such as a @code{<package>}.
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
|
||||||
@c *********************************************************************
|
@c *********************************************************************
|
||||||
@node Utilities
|
@node Utilities
|
||||||
|
|
|
@ -53,6 +53,7 @@ (define-module (guix gexp)
|
||||||
|
|
||||||
define-gexp-compiler
|
define-gexp-compiler
|
||||||
gexp-compiler?
|
gexp-compiler?
|
||||||
|
lower-object
|
||||||
|
|
||||||
lower-inputs))
|
lower-inputs))
|
||||||
|
|
||||||
|
@ -126,6 +127,16 @@ (define (lookup-compiler object)
|
||||||
(and (predicate object) lower)))
|
(and (predicate object) lower)))
|
||||||
%gexp-compilers))
|
%gexp-compilers))
|
||||||
|
|
||||||
|
(define* (lower-object obj
|
||||||
|
#:optional (system (%current-system))
|
||||||
|
#:key target)
|
||||||
|
"Return as a value in %STORE-MONAD the derivation or store item
|
||||||
|
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
|
||||||
|
OBJ must be an object that has an associated gexp compiler, such as a
|
||||||
|
<package>."
|
||||||
|
(let ((lower (lookup-compiler obj)))
|
||||||
|
(lower obj system target)))
|
||||||
|
|
||||||
(define-syntax-rule (define-gexp-compiler (name (param predicate)
|
(define-syntax-rule (define-gexp-compiler (name (param predicate)
|
||||||
system target)
|
system target)
|
||||||
body ...)
|
body ...)
|
||||||
|
@ -258,8 +269,8 @@ (define* (lower-inputs inputs
|
||||||
(sequence %store-monad
|
(sequence %store-monad
|
||||||
(map (match-lambda
|
(map (match-lambda
|
||||||
(((? struct? thing) sub-drv ...)
|
(((? struct? thing) sub-drv ...)
|
||||||
(mlet* %store-monad ((lower -> (lookup-compiler thing))
|
(mlet %store-monad ((drv (lower-object
|
||||||
(drv (lower thing system target)))
|
thing system #:target target)))
|
||||||
(return `(,drv ,@sub-drv))))
|
(return `(,drv ,@sub-drv))))
|
||||||
(input
|
(input
|
||||||
(return input)))
|
(return input)))
|
||||||
|
@ -288,13 +299,13 @@ (define lower
|
||||||
((? string? output)
|
((? string? output)
|
||||||
(return output))
|
(return output))
|
||||||
(($ <gexp-input> thing output native?)
|
(($ <gexp-input> thing output native?)
|
||||||
(mlet* %store-monad ((lower -> (lookup-compiler thing))
|
(mlet %store-monad ((drv (lower-object thing system
|
||||||
(drv (lower thing system
|
#:target (if native?
|
||||||
(if native? #f target))))
|
#f target))))
|
||||||
(return (derivation->output-path drv output))))
|
(return (derivation->output-path drv output))))
|
||||||
(thing
|
(thing
|
||||||
(mlet* %store-monad ((lower -> (lookup-compiler thing))
|
(mlet %store-monad ((drv (lower-object thing system
|
||||||
(drv (lower thing system target)))
|
#:target target)))
|
||||||
(return (derivation->output-path drv))))))
|
(return (derivation->output-path drv))))))
|
||||||
|
|
||||||
(sequence %store-monad (map lower lst))))
|
(sequence %store-monad (map lower lst))))
|
||||||
|
@ -540,9 +551,9 @@ (define* (reference->sexp ref #:optional native?)
|
||||||
native?))
|
native?))
|
||||||
refs)))
|
refs)))
|
||||||
(($ <gexp-input> (? struct? thing) output n?)
|
(($ <gexp-input> (? struct? thing) output n?)
|
||||||
(let ((lower (lookup-compiler thing))
|
(let ((target (if (or n? native?) #f target)))
|
||||||
(target (if (or n? native?) #f target)))
|
(mlet %store-monad ((obj (lower-object thing system
|
||||||
(mlet %store-monad ((obj (lower thing system target)))
|
#:target target)))
|
||||||
;; OBJ must be either a derivation or a store file name.
|
;; OBJ must be either a derivation or a store file name.
|
||||||
(return (match obj
|
(return (match obj
|
||||||
((? derivation? drv)
|
((? derivation? drv)
|
||||||
|
|
|
@ -654,6 +654,13 @@ (define shebang
|
||||||
(parameterize ((%current-target-system "fooooo"))
|
(parameterize ((%current-target-system "fooooo"))
|
||||||
(derivation? (run-with-store %store mval)))))
|
(derivation? (run-with-store %store mval)))))
|
||||||
|
|
||||||
|
(test-assertm "lower-object"
|
||||||
|
(mlet %store-monad ((drv1 (lower-object %bootstrap-guile))
|
||||||
|
(drv2 (lower-object (package-source coreutils)))
|
||||||
|
(item (lower-object (plain-file "foo" "Hello!"))))
|
||||||
|
(return (and (derivation? drv1) (derivation? drv2)
|
||||||
|
(store-path? item)))))
|
||||||
|
|
||||||
(test-assert "printer"
|
(test-assert "printer"
|
||||||
(string-match "^#<gexp \\(string-append .*#<package coreutils.*\
|
(string-match "^#<gexp \\(string-append .*#<package coreutils.*\
|
||||||
\"/bin/uname\"\\) [[:xdigit:]]+>$"
|
\"/bin/uname\"\\) [[:xdigit:]]+>$"
|
||||||
|
|
Loading…
Reference in a new issue