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:
Ludovic Courtès 2015-08-26 11:28:23 +02:00
parent f7283db37d
commit c2b8467645
3 changed files with 45 additions and 11 deletions

View file

@ -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

View file

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

View file

@ -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:]]+>$"