gexp: Add 'with-extensions'.
* guix/gexp.scm (<gexp>)[extensions]: New field.
(gexp-attribute): New procedure.
(gexp-modules): Write in terms of 'gexp-attribute'.
(gexp-extensions): New procedure.
(gexp->derivation): Add #:effective-version.
[extension-flags]: New procedure.
Honor extensions of EXP.
(current-imported-extensions): New syntax parameter.
(with-extensions): New macro.
(gexp): Honor CURRENT-IMPORTED-EXTENSIONS.
(compiled-modules): Add #:extensions and honor it.
(load-path-expression): Likewise.
(gexp->script, gexp->file): Honor extensions.
* tests/gexp.scm (%extension-package): New variable.
("gexp-extensions & ungexp")
("gexp-extensions & ungexp-splicing")
("gexp-extensions and literal Scheme object")
("gexp->derivation & with-extensions")
("program-file & with-extensions"): New tests.
* doc/guix.texi (G-Expressions): Document 'with-extensions'.
This commit is contained in:
Ludovic Courtès
parent
ccc951cab3
commit
838e17d805
|
|
@ -73,6 +73,7 @@
|
|||
(eval . (put 'run-with-state 'scheme-indent-function 1))
|
||||
(eval . (put 'wrap-program 'scheme-indent-function 1))
|
||||
(eval . (put 'with-imported-modules 'scheme-indent-function 1))
|
||||
(eval . (put 'with-extensions 'scheme-indent-function 1))
|
||||
|
||||
(eval . (put 'call-with-container 'scheme-indent-function 1))
|
||||
(eval . (put 'container-excursion 'scheme-indent-function 1))
|
||||
|
|
|
|||
|
|
@ -5064,6 +5064,23 @@ headers, which comes in handy in this case:
|
|||
@dots{})))
|
||||
@end example
|
||||
|
||||
@cindex extensions, for gexps
|
||||
@findex with-extensions
|
||||
In the same vein, sometimes you want to import not just pure-Scheme
|
||||
modules, but also ``extensions'' such as Guile bindings to C libraries
|
||||
or other ``full-blown'' packages. Say you need the @code{guile-json}
|
||||
package available on the build side, here's how you would do it:
|
||||
|
||||
@example
|
||||
(use-modules (gnu packages guile)) ;for 'guile-json'
|
||||
|
||||
(with-extensions (list guile-json)
|
||||
(gexp->derivation "something-with-json"
|
||||
#~(begin
|
||||
(use-modules (json))
|
||||
@dots{})))
|
||||
@end example
|
||||
|
||||
The syntactic form to construct gexps is summarized below.
|
||||
|
||||
@deffn {Scheme Syntax} #~@var{exp}
|
||||
|
|
@ -5147,6 +5164,18 @@ directly defined in @var{body}@dots{}, but not on those defined, say, in
|
|||
procedures called from @var{body}@dots{}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Syntax} with-extensions @var{extensions} @var{body}@dots{}
|
||||
Mark the gexps defined in @var{body}@dots{} as requiring
|
||||
@var{extensions} in their build and execution environment.
|
||||
@var{extensions} is typically a list of package objects such as those
|
||||
defined in the @code{(gnu packages guile)} module.
|
||||
|
||||
Concretely, the packages listed in @var{extensions} are added to the
|
||||
load path while compiling imported modules in @var{body}@dots{}; they
|
||||
are also added to the load path of the gexp returned by
|
||||
@var{body}@dots{}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} gexp? @var{obj}
|
||||
Return @code{#t} if @var{obj} is a G-expression.
|
||||
@end deffn
|
||||
|
|
@ -5161,6 +5190,7 @@ information about monads.)
|
|||
[#:hash #f] [#:hash-algo #f] @
|
||||
[#:recursive? #f] [#:env-vars '()] [#:modules '()] @
|
||||
[#:module-path @var{%load-path}] @
|
||||
[#:effective-version "2.2"] @
|
||||
[#:references-graphs #f] [#:allowed-references #f] @
|
||||
[#:disallowed-references #f] @
|
||||
[#:leaked-env-vars #f] @
|
||||
|
|
@ -5181,6 +5211,9 @@ make @var{modules} available in the evaluation context of @var{exp};
|
|||
the load path during the execution of @var{exp}---e.g., @code{((guix
|
||||
build utils) (guix build gnu-build-system))}.
|
||||
|
||||
@var{effective-version} determines the string to use when adding extensions of
|
||||
@var{exp} (see @code{with-extensions}) to the search path---e.g., @code{"2.2"}.
|
||||
|
||||
@var{graft?} determines whether packages referred to by @var{exp} should be grafted when
|
||||
applicable.
|
||||
|
||||
|
|
|
|||
168
guix/gexp.scm
168
guix/gexp.scm
|
|
@ -33,6 +33,7 @@
|
|||
#:export (gexp
|
||||
gexp?
|
||||
with-imported-modules
|
||||
with-extensions
|
||||
|
||||
gexp-input
|
||||
gexp-input?
|
||||
|
|
@ -118,10 +119,11 @@
|
|||
|
||||
;; "G expressions".
|
||||
(define-record-type <gexp>
|
||||
(make-gexp references modules proc)
|
||||
(make-gexp references modules extensions proc)
|
||||
gexp?
|
||||
(references gexp-references) ;list of <gexp-input>
|
||||
(modules gexp-self-modules) ;list of module names
|
||||
(extensions gexp-self-extensions) ;list of lowerable things
|
||||
(proc gexp-proc)) ;procedure
|
||||
|
||||
(define (write-gexp gexp port)
|
||||
|
|
@ -492,19 +494,20 @@ whether this should be considered a \"native\" input or not."
|
|||
|
||||
(set-record-type-printer! <gexp-output> write-gexp-output)
|
||||
|
||||
(define (gexp-modules gexp)
|
||||
"Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is
|
||||
false, meaning that GEXP is a plain Scheme object, return the empty list."
|
||||
(define (gexp-attribute gexp self-attribute)
|
||||
"Recurse on GEXP and the expressions it refers to, summing the items
|
||||
returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
|
||||
(if (gexp? gexp)
|
||||
(delete-duplicates
|
||||
(append (gexp-self-modules gexp)
|
||||
(append (self-attribute gexp)
|
||||
(append-map (match-lambda
|
||||
(($ <gexp-input> (? gexp? exp))
|
||||
(gexp-modules exp))
|
||||
(gexp-attribute exp self-attribute))
|
||||
(($ <gexp-input> (lst ...))
|
||||
(append-map (lambda (item)
|
||||
(if (gexp? item)
|
||||
(gexp-modules item)
|
||||
(gexp-attribute item
|
||||
self-attribute)
|
||||
'()))
|
||||
lst))
|
||||
(_
|
||||
|
|
@ -512,6 +515,17 @@ false, meaning that GEXP is a plain Scheme object, return the empty list."
|
|||
(gexp-references gexp))))
|
||||
'())) ;plain Scheme data type
|
||||
|
||||
(define (gexp-modules gexp)
|
||||
"Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is
|
||||
false, meaning that GEXP is a plain Scheme object, return the empty list."
|
||||
(gexp-attribute gexp gexp-self-modules))
|
||||
|
||||
(define (gexp-extensions gexp)
|
||||
"Return the list of Guile extensions (packages) GEXP relies on. If (gexp?
|
||||
GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
|
||||
list."
|
||||
(gexp-attribute gexp gexp-self-extensions))
|
||||
|
||||
(define* (lower-inputs inputs
|
||||
#:key system target)
|
||||
"Turn any package from INPUTS into a derivation for SYSTEM; return the
|
||||
|
|
@ -577,6 +591,7 @@ names and file names suitable for the #:allowed-references argument to
|
|||
(modules '())
|
||||
(module-path %load-path)
|
||||
(guile-for-build (%guile-for-build))
|
||||
(effective-version "2.2")
|
||||
(graft? (%graft?))
|
||||
references-graphs
|
||||
allowed-references disallowed-references
|
||||
|
|
@ -595,6 +610,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store,
|
|||
compiled, and made available in the load path during the execution of
|
||||
EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
|
||||
|
||||
EFFECTIVE-VERSION determines the string to use when adding extensions of
|
||||
EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
|
||||
|
||||
GRAFT? determines whether packages referred to by EXP should be grafted when
|
||||
applicable.
|
||||
|
||||
|
|
@ -630,7 +648,7 @@ The other arguments are as for 'derivation'."
|
|||
(define (graphs-file-names graphs)
|
||||
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
|
||||
(map (match-lambda
|
||||
;; TODO: Remove 'derivation?' special cases.
|
||||
;; TODO: Remove 'derivation?' special cases.
|
||||
((file-name (? derivation? drv))
|
||||
(cons file-name (derivation->output-path drv)))
|
||||
((file-name (? derivation? drv) sub-drv)
|
||||
|
|
@ -639,7 +657,13 @@ The other arguments are as for 'derivation'."
|
|||
(cons file-name thing)))
|
||||
graphs))
|
||||
|
||||
(mlet* %store-monad (;; The following binding forces '%current-system' and
|
||||
(define (extension-flags extension)
|
||||
`("-L" ,(string-append (derivation->output-path extension)
|
||||
"/share/guile/site/" effective-version)
|
||||
"-C" ,(string-append (derivation->output-path extension)
|
||||
"/lib/guile/" effective-version "/site-ccache")))
|
||||
|
||||
(mlet* %store-monad ( ;; The following binding forces '%current-system' and
|
||||
;; '%current-target-system' to be looked up at >>=
|
||||
;; time.
|
||||
(graft? (set-grafting graft?))
|
||||
|
|
@ -660,6 +684,11 @@ The other arguments are as for 'derivation'."
|
|||
#:target target))
|
||||
(builder (text-file script-name
|
||||
(object->string sexp)))
|
||||
(extensions -> (gexp-extensions exp))
|
||||
(exts (mapm %store-monad
|
||||
(lambda (obj)
|
||||
(lower-object obj system))
|
||||
extensions))
|
||||
(modules (if (pair? %modules)
|
||||
(imported-modules %modules
|
||||
#:system system
|
||||
|
|
@ -672,6 +701,7 @@ The other arguments are as for 'derivation'."
|
|||
(compiled-modules %modules
|
||||
#:system system
|
||||
#:module-path module-path
|
||||
#:extensions extensions
|
||||
#:guile guile-for-build
|
||||
#:deprecation-warnings
|
||||
deprecation-warnings)
|
||||
|
|
@ -704,6 +734,7 @@ The other arguments are as for 'derivation'."
|
|||
`("-L" ,(derivation->output-path modules)
|
||||
"-C" ,(derivation->output-path compiled))
|
||||
'())
|
||||
,@(append-map extension-flags exts)
|
||||
,builder)
|
||||
#:outputs outputs
|
||||
#:env-vars env-vars
|
||||
|
|
@ -713,6 +744,7 @@ The other arguments are as for 'derivation'."
|
|||
,@(if modules
|
||||
`((,modules) (,compiled) ,@inputs)
|
||||
inputs)
|
||||
,@(map list exts)
|
||||
,@(match graphs
|
||||
(((_ . inputs) ...) inputs)
|
||||
(_ '())))
|
||||
|
|
@ -861,6 +893,17 @@ environment."
|
|||
(identifier-syntax modules)))
|
||||
body ...))
|
||||
|
||||
(define-syntax-parameter current-imported-extensions
|
||||
;; Current list of extensions.
|
||||
(identifier-syntax '()))
|
||||
|
||||
(define-syntax-rule (with-extensions extensions body ...)
|
||||
"Mark the gexps defined in BODY... as requiring EXTENSIONS in their
|
||||
execution environment."
|
||||
(syntax-parameterize ((current-imported-extensions
|
||||
(identifier-syntax extensions)))
|
||||
body ...))
|
||||
|
||||
(define-syntax gexp
|
||||
(lambda (s)
|
||||
(define (collect-escapes exp)
|
||||
|
|
@ -957,6 +1000,7 @@ environment."
|
|||
(refs (map escape->ref escapes)))
|
||||
#`(make-gexp (list #,@refs)
|
||||
current-imported-modules
|
||||
current-imported-extensions
|
||||
(lambda #,formals
|
||||
#,sexp)))))))
|
||||
|
||||
|
|
@ -1071,6 +1115,7 @@ last one is created from the given <scheme-file> object."
|
|||
(system (%current-system))
|
||||
(guile (%guile-for-build))
|
||||
(module-path %load-path)
|
||||
(extensions '())
|
||||
(deprecation-warnings #f))
|
||||
"Return a derivation that builds a tree containing the `.go' files
|
||||
corresponding to MODULES. All the MODULES are built in a context where
|
||||
|
|
@ -1129,6 +1174,26 @@ they can refer to each other."
|
|||
(@ (guix build utils) mkdir-p))))
|
||||
'()))
|
||||
|
||||
;; Add EXTENSIONS to the search path.
|
||||
;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle.
|
||||
(ungexp-splicing
|
||||
(if (null? extensions)
|
||||
'()
|
||||
(gexp ((set! %load-path
|
||||
(append (map (lambda (extension)
|
||||
(string-append extension
|
||||
"/share/guile/site/"
|
||||
(effective-version)))
|
||||
'((ungexp-native-splicing extensions)))
|
||||
%load-path))
|
||||
(set! %load-compiled-path
|
||||
(append (map (lambda (extension)
|
||||
(string-append extension "/lib/guile/"
|
||||
(effective-version)
|
||||
"/site-ccache"))
|
||||
'((ungexp-native-splicing extensions)))
|
||||
%load-compiled-path))))))
|
||||
|
||||
(set! %load-path (cons (ungexp modules) %load-path))
|
||||
|
||||
(ungexp-splicing
|
||||
|
|
@ -1174,20 +1239,34 @@ they can refer to each other."
|
|||
(module-ref (resolve-interface '(gnu packages guile))
|
||||
'guile-2.2))
|
||||
|
||||
(define* (load-path-expression modules #:optional (path %load-path))
|
||||
(define* (load-path-expression modules #:optional (path %load-path)
|
||||
#:key (extensions '()))
|
||||
"Return as a monadic value a gexp that sets '%load-path' and
|
||||
'%load-compiled-path' to point to MODULES, a list of module names. MODULES
|
||||
are searched for in PATH."
|
||||
(mlet %store-monad ((modules (imported-modules modules
|
||||
#:module-path path))
|
||||
(compiled (compiled-modules modules
|
||||
#:extensions extensions
|
||||
#:module-path path)))
|
||||
(return (gexp (eval-when (expand load eval)
|
||||
(set! %load-path
|
||||
(cons (ungexp modules) %load-path))
|
||||
(cons (ungexp modules)
|
||||
(append (map (lambda (extension)
|
||||
(string-append extension
|
||||
"/share/guile/site/"
|
||||
(effective-version)))
|
||||
'((ungexp-native-splicing extensions)))
|
||||
%load-path)))
|
||||
(set! %load-compiled-path
|
||||
(cons (ungexp compiled)
|
||||
%load-compiled-path)))))))
|
||||
(append (map (lambda (extension)
|
||||
(string-append extension
|
||||
"/lib/guile/"
|
||||
(effective-version)
|
||||
"/site-ccache"))
|
||||
'((ungexp-native-splicing extensions)))
|
||||
%load-compiled-path))))))))
|
||||
|
||||
(define* (gexp->script name exp
|
||||
#:key (guile (default-guile))
|
||||
|
|
@ -1196,7 +1275,9 @@ are searched for in PATH."
|
|||
imported modules in its search path. Look up EXP's modules in MODULE-PATH."
|
||||
(mlet %store-monad ((set-load-path
|
||||
(load-path-expression (gexp-modules exp)
|
||||
module-path)))
|
||||
module-path
|
||||
#:extensions
|
||||
(gexp-extensions exp))))
|
||||
(gexp->derivation name
|
||||
(gexp
|
||||
(call-with-output-file (ungexp output)
|
||||
|
|
@ -1225,35 +1306,38 @@ the resulting file.
|
|||
When SET-LOAD-PATH? is true, emit code in the resulting file to set
|
||||
'%load-path' and '%load-compiled-path' to honor EXP's imported modules.
|
||||
Lookup EXP's modules in MODULE-PATH."
|
||||
(match (if set-load-path? (gexp-modules exp) '())
|
||||
(() ;zero modules
|
||||
(gexp->derivation name
|
||||
(gexp
|
||||
(call-with-output-file (ungexp output)
|
||||
(lambda (port)
|
||||
(for-each (lambda (exp)
|
||||
(write exp port))
|
||||
'(ungexp (if splice?
|
||||
exp
|
||||
(gexp ((ungexp exp)))))))))
|
||||
#:local-build? #t
|
||||
#:substitutable? #f))
|
||||
((modules ...)
|
||||
(mlet %store-monad ((set-load-path (load-path-expression modules
|
||||
module-path)))
|
||||
(gexp->derivation name
|
||||
(gexp
|
||||
(call-with-output-file (ungexp output)
|
||||
(lambda (port)
|
||||
(write '(ungexp set-load-path) port)
|
||||
(for-each (lambda (exp)
|
||||
(write exp port))
|
||||
'(ungexp (if splice?
|
||||
exp
|
||||
(gexp ((ungexp exp)))))))))
|
||||
#:module-path module-path
|
||||
#:local-build? #t
|
||||
#:substitutable? #f)))))
|
||||
(define modules (gexp-modules exp))
|
||||
(define extensions (gexp-extensions exp))
|
||||
|
||||
(if (or (not set-load-path?)
|
||||
(and (null? modules) (null? extensions)))
|
||||
(gexp->derivation name
|
||||
(gexp
|
||||
(call-with-output-file (ungexp output)
|
||||
(lambda (port)
|
||||
(for-each (lambda (exp)
|
||||
(write exp port))
|
||||
'(ungexp (if splice?
|
||||
exp
|
||||
(gexp ((ungexp exp)))))))))
|
||||
#:local-build? #t
|
||||
#:substitutable? #f)
|
||||
(mlet %store-monad ((set-load-path
|
||||
(load-path-expression modules module-path
|
||||
#:extensions extensions)))
|
||||
(gexp->derivation name
|
||||
(gexp
|
||||
(call-with-output-file (ungexp output)
|
||||
(lambda (port)
|
||||
(write '(ungexp set-load-path) port)
|
||||
(for-each (lambda (exp)
|
||||
(write exp port))
|
||||
'(ungexp (if splice?
|
||||
exp
|
||||
(gexp ((ungexp exp)))))))))
|
||||
#:module-path module-path
|
||||
#:local-build? #t
|
||||
#:substitutable? #f))))
|
||||
|
||||
(define* (text-file* name #:rest text)
|
||||
"Return as a monadic value a derivation that builds a text file containing
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
#:use-module (guix grafts)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix build-system trivial)
|
||||
#:use-module (guix tests)
|
||||
#:use-module ((guix build utils) #:select (with-directory-excursion))
|
||||
#:use-module ((guix utils) #:select (call-with-temporary-directory))
|
||||
|
|
@ -66,6 +67,27 @@
|
|||
(run-with-store %store exp
|
||||
#:guile-for-build (%guile-for-build))))
|
||||
|
||||
(define %extension-package
|
||||
;; Example of a package to use when testing 'with-extensions'.
|
||||
(dummy-package "extension"
|
||||
(build-system trivial-build-system)
|
||||
(arguments
|
||||
`(#:guile ,%bootstrap-guile
|
||||
#:modules ((guix build utils))
|
||||
#:builder
|
||||
(begin
|
||||
(use-modules (guix build utils))
|
||||
(let* ((out (string-append (assoc-ref %outputs "out")
|
||||
"/share/guile/site/"
|
||||
(effective-version))))
|
||||
(mkdir-p out)
|
||||
(call-with-output-file (string-append out "/hg2g.scm")
|
||||
(lambda (port)
|
||||
(write '(define-module (hg2g)
|
||||
#:export (the-answer))
|
||||
port)
|
||||
(write '(define the-answer 42) port)))))))))
|
||||
|
||||
|
||||
(test-begin "gexp")
|
||||
|
||||
|
|
@ -739,6 +761,54 @@
|
|||
(built-derivations (list drv))
|
||||
(return (= 42 (call-with-input-file out read))))))
|
||||
|
||||
(test-equal "gexp-extensions & ungexp"
|
||||
(list sed grep)
|
||||
((@@ (guix gexp) gexp-extensions)
|
||||
#~(foo #$(with-extensions (list grep) #~+)
|
||||
#+(with-extensions (list sed) #~-))))
|
||||
|
||||
(test-equal "gexp-extensions & ungexp-splicing"
|
||||
(list grep sed)
|
||||
((@@ (guix gexp) gexp-extensions)
|
||||
#~(foo #$@(list (with-extensions (list grep) #~+)
|
||||
(with-imported-modules '((foo))
|
||||
(with-extensions (list sed) #~-))))))
|
||||
|
||||
(test-equal "gexp-extensions and literal Scheme object"
|
||||
'()
|
||||
((@@ (guix gexp) gexp-extensions) #t))
|
||||
|
||||
(test-assertm "gexp->derivation & with-extensions"
|
||||
;; Create a fake Guile extension and make sure it is accessible both to the
|
||||
;; imported modules and to the derivation build script.
|
||||
(mlet* %store-monad
|
||||
((extension -> %extension-package)
|
||||
(module -> (scheme-file "x" #~( ;; splice!
|
||||
(define-module (foo)
|
||||
#:use-module (hg2g)
|
||||
#:export (multiply))
|
||||
|
||||
(define (multiply x)
|
||||
(* the-answer x)))
|
||||
#:splice? #t))
|
||||
(build -> (with-extensions (list extension)
|
||||
(with-imported-modules `((guix build utils)
|
||||
((foo) => ,module))
|
||||
#~(begin
|
||||
(use-modules (guix build utils)
|
||||
(hg2g) (foo))
|
||||
(call-with-output-file #$output
|
||||
(lambda (port)
|
||||
(write (list the-answer (multiply 2))
|
||||
port)))))))
|
||||
(drv (gexp->derivation "thingie" build
|
||||
;; %BOOTSTRAP-GUILE is 2.0.
|
||||
#:effective-version "2.0"))
|
||||
(out -> (derivation->output-path drv)))
|
||||
(mbegin %store-monad
|
||||
(built-derivations (list drv))
|
||||
(return (equal? '(42 84) (call-with-input-file out read))))))
|
||||
|
||||
(test-assertm "gexp->derivation #:references-graphs"
|
||||
(mlet* %store-monad
|
||||
((one (text-file "one" (random-text)))
|
||||
|
|
@ -948,6 +1018,22 @@
|
|||
(return (and (zero? (close-pipe pipe))
|
||||
(string=? text str))))))))))
|
||||
|
||||
(test-assertm "program-file & with-extensions"
|
||||
(let* ((exp (with-extensions (list %extension-package)
|
||||
(gexp (begin
|
||||
(use-modules (hg2g))
|
||||
(display the-answer)))))
|
||||
(file (program-file "program" exp
|
||||
#:guile %bootstrap-guile)))
|
||||
(mlet* %store-monad ((drv (lower-object file))
|
||||
(out -> (derivation->output-path drv)))
|
||||
(mbegin %store-monad
|
||||
(built-derivations (list drv))
|
||||
(let* ((pipe (open-input-pipe out))
|
||||
(str (get-string-all pipe)))
|
||||
(return (and (zero? (close-pipe pipe))
|
||||
(= 42 (string->number str)))))))))
|
||||
|
||||
(test-assertm "scheme-file"
|
||||
(let* ((text (plain-file "foo" "Hello, world!"))
|
||||
(scheme (scheme-file "bar" #~(list "foo" #$text))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue