ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gexp: Add 'with-extensions'.

Browse source 
* 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 2018-05-28 18:14:37 +02:00
parent ccc951cab3
commit 838e17d805
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
4 changed files with 246 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

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

33
doc/guix.texi
View file

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

@ -33,6 +33,7 @@ (define-module (guix gexp)
#:export (gexp
gexp?
with-imported-modules
with-extensions
gexp-input
gexp-input?
@ -118,10 +119,11 @@ (define-module (guix gexp)
;; "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 @@ (define (write-gexp-output output port)
(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 @@ (define (gexp-modules gexp)
(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 @@ (define* (gexp->derivation name exp
(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 @@ (define* (gexp->derivation name exp
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 @@ (define outputs (gexp-outputs exp))
(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 @@ (define (graphs-file-names graphs)
(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 @@ (define (graphs-file-names graphs)
#: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 @@ (define (graphs-file-names graphs)
(compiled-modules %modules
#:system system
#:module-path module-path
#:extensions extensions
#:guile guile-for-build
#:deprecation-warnings
deprecation-warnings)
@ -704,6 +734,7 @@ (define (graphs-file-names graphs)
`("-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 @@ (define (graphs-file-names graphs)
,@(if modules
`((,modules) (,compiled) ,@inputs)
inputs)
,@(map list exts)
,@(match graphs
(((_ . inputs) ...) inputs)
(_ '())))
@ -861,6 +893,17 @@ (define-syntax-rule (with-imported-modules modules body ...)
(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 @@ (define (substitute-references exp substs)
(refs (map escape->ref escapes)))
#`(make-gexp (list #,@refs)
current-imported-modules
current-imported-extensions
(lambda #,formals
#,sexp)))))))
@ -1071,6 +1115,7 @@ (define* (compiled-modules modules
(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 @@ (define (process-directory directory output)
(@ (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 @@ (define (default-guile)
(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 @@ (define* (gexp->script name exp
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 @@ (define* (gexp->file name exp #:key
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

86
tests/gexp.scm
View file

@ -23,6 +23,7 @@ (define-module (test-gexp)
#: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 @@ (define-syntax-rule (test-assertm name exp)
(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 @@ (define the-answer 42))
(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 @@ (define-public %stupid-thing ,text))
(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))))