[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#31633] [PATCH 1/7] gexp: Add 'with-extensions'.
|
From: |
Ludovic Courtès |
|
Subject: |
[bug#31633] [PATCH 1/7] gexp: Add 'with-extensions'. |
|
Date: |
Mon, 28 May 2018 23:59:24 +0200 |
* 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'.
---
.dir-locals.el | 1 +
doc/guix.texi | 33 ++++++++++
guix/gexp.scm | 168 ++++++++++++++++++++++++++++++++++++-------------
tests/gexp.scm | 86 +++++++++++++++++++++++++
4 files changed, 246 insertions(+), 42 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index dac6cb145..2db751ca2 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -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))
diff --git a/doc/guix.texi b/doc/guix.texi
index 5eee40fc3..e55fecc31 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5041,6 +5041,23 @@ headers, which comes in handy in this case:
@dots{})))
@end example
address@hidden extensions, for gexps
address@hidden 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:
+
address@hidden
+(use-modules (gnu packages guile)) ;for 'guile-json'
+
+(with-extensions (list guile-json)
+ (gexp->derivation "something-with-json"
+ #~(begin
+ (use-modules (json))
+ @dots{})))
address@hidden example
+
The syntactic form to construct gexps is summarized below.
@deffn {Scheme Syntax} address@hidden
@@ -5124,6 +5141,18 @@ directly defined in @address@hidden, but not on those
defined, say, in
procedures called from @address@hidden
@end deffn
address@hidden {Scheme Syntax} with-extensions @var{extensions} @address@hidden
+Mark the gexps defined in @address@hidden as requiring
address@hidden in their build and execution environment.
address@hidden 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 @address@hidden; they
+are also added to the load path of the gexp returned by
address@hidden@dots{}.
address@hidden deffn
+
@deffn {Scheme Procedure} gexp? @var{obj}
Return @code{#t} if @var{obj} is a G-expression.
@end deffn
@@ -5138,6 +5167,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] @
@@ -5158,6 +5188,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))}.
address@hidden determines the string to use when adding extensions of
address@hidden (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.
diff --git a/guix/gexp.scm b/guix/gexp.scm
index dd5eb81bd..eda962d0a 100644
--- a/guix/gexp.scm
+++ b/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
@@ -1114,6 +1159,26 @@ they can refer to each other."
%auto-compilation-options))))
entries)))
+ ;; 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))
(mkdir (ungexp output))
(chdir (ungexp modules))
@@ -1146,20 +1211,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))
@@ -1168,7 +1247,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)
@@ -1197,35 +1278,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
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 3c8b4624d..a560adfc5 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -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))))
--
2.17.0
- [bug#31633] [PATCH 0/7] Add 'with-extensions' for gexps, Ludovic Courtès, 2018/05/28
- [bug#31633] [PATCH 1/7] gexp: Add 'with-extensions'.,
Ludovic Courtès <=
- [bug#31633] [PATCH 4/7] bootloader: grub: Simplify 'svg->png'., Ludovic Courtès, 2018/05/28
- [bug#31633] [PATCH 5/7] bootloader: grub: Use 'with-extensions'., Ludovic Courtès, 2018/05/28
- [bug#31633] [PATCH 6/7] profiles: Use 'with-extensions'., Ludovic Courtès, 2018/05/28
- [bug#31633] [PATCH 2/7] pack: Use 'with-extensions' when referring to (guix docker)., Ludovic Courtès, 2018/05/28
- [bug#31633] [PATCH 3/7] tests: ssh: Use 'with-extensions'., Ludovic Courtès, 2018/05/28
- [bug#31633] [PATCH 7/7] vm: Use 'with-extensions'., Ludovic Courtès, 2018/05/28