diff options
Diffstat (limited to 'guix/gexp.scm')
| -rw-r--r-- | guix/gexp.scm | 188 |
1 files changed, 102 insertions, 86 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index b929b79c26..302879fb42 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -29,6 +29,7 @@ #:use-module (ice-9 match) #:export (gexp gexp? + with-imported-modules gexp-input gexp-input? @@ -49,14 +50,12 @@ computed-file? computed-file-name computed-file-gexp - computed-file-modules computed-file-options program-file program-file? program-file-name program-file-gexp - program-file-modules program-file-guile scheme-file @@ -98,11 +97,11 @@ ;; "G expressions". (define-record-type <gexp> - (make-gexp references natives proc) + (make-gexp references modules proc) gexp? - (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) - (natives gexp-native-references) ; ((DRV-OR-PKG OUTPUT) ...) - (proc gexp-proc)) ; procedure + (references gexp-references) ;list of <gexp-input> + (modules gexp-self-modules) ;list of module names + (proc gexp-proc)) ;procedure (define (write-gexp gexp port) "Write GEXP on PORT." @@ -113,8 +112,7 @@ ;; tries to use 'append' on that, which fails with wrong-type-arg. (false-if-exception (write (apply (gexp-proc gexp) - (append (gexp-references gexp) - (gexp-native-references gexp))) + (gexp-references gexp)) port)) (format port " ~a>" (number->string (object-address gexp) 16))) @@ -273,55 +271,49 @@ This is the declarative counterpart of 'text-file'." (text-file name content references)))) (define-record-type <computed-file> - (%computed-file name gexp modules options) + (%computed-file name gexp options) computed-file? (name computed-file-name) ;string (gexp computed-file-gexp) ;gexp - (modules computed-file-modules) ;list of module names (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key (modules '()) (options '(#:local-build? #t))) + #:key (options '(#:local-build? #t))) "Return an object representing the store item NAME, a file or directory -computed by GEXP. MODULES specifies the set of modules visible in the -execution context of GEXP. OPTIONS is a list of additional arguments to pass +computed by GEXP. OPTIONS is a list of additional arguments to pass to 'gexp->derivation'. This is the declarative counterpart of 'gexp->derivation'." - (%computed-file name gexp modules options)) + (%computed-file name gexp options)) (define-gexp-compiler (computed-file-compiler (file computed-file?) system target) ;; Compile FILE by returning a derivation whose build expression is its ;; gexp. (match file - (($ <computed-file> name gexp modules options) - (apply gexp->derivation name gexp #:modules modules options)))) + (($ <computed-file> name gexp options) + (apply gexp->derivation name gexp options)))) (define-record-type <program-file> - (%program-file name gexp modules guile) + (%program-file name gexp guile) program-file? (name program-file-name) ;string (gexp program-file-gexp) ;gexp - (modules program-file-modules) ;list of module names (guile program-file-guile)) ;package -(define* (program-file name gexp - #:key (modules '()) (guile #f)) +(define* (program-file name gexp #:key (guile #f)) "Return an object representing the executable store item NAME that runs -GEXP. GUILE is the Guile package used to execute that script, and MODULES is -the list of modules visible to that script. +GEXP. GUILE is the Guile package used to execute that script. This is the declarative counterpart of 'gexp->script'." - (%program-file name gexp modules guile)) + (%program-file name gexp guile)) (define-gexp-compiler (program-file-compiler (file program-file?) system target) ;; Compile FILE by returning a derivation that builds the script. (match file - (($ <program-file> name gexp modules guile) + (($ <program-file> name gexp guile) (gexp->script name gexp - #:modules modules #:guile (or guile (default-guile)))))) (define-record-type <scheme-file> @@ -386,6 +378,23 @@ 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." + (delete-duplicates + (append (gexp-self-modules gexp) + (append-map (match-lambda + (($ <gexp-input> (? gexp? exp)) + (gexp-modules exp)) + (($ <gexp-input> (lst ...)) + (append-map (lambda (item) + (if (gexp? item) + (gexp-modules item) + '())) + lst)) + (_ + '())) + (gexp-references gexp))))) + (define raw-derivation (store-lift derivation)) @@ -467,7 +476,8 @@ derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When TARGET is true, it is used as the cross-compilation target triplet for packages referred to by EXP. -Make MODULES available in the evaluation context of EXP; MODULES is a list of +MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to +make MODULES available in the evaluation context of EXP; MODULES is a list of 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)). @@ -496,7 +506,9 @@ Similarly for DISALLOWED-REFERENCES, which can list items that must not be referenced by the outputs. The other arguments are as for 'derivation'." - (define %modules modules) + (define %modules + (delete-duplicates + (append modules (gexp-modules exp)))) (define outputs (gexp-outputs exp)) (define (graphs-file-names graphs) @@ -630,11 +642,15 @@ references; otherwise, return only non-native references." ;; Ignore references to other kinds of objects. result))) + (define (native-input? x) + (and (gexp-input? x) + (gexp-input-native? x))) + (fold-right add-reference-inputs '() (if native? - (gexp-native-references exp) - (gexp-references exp)))) + (filter native-input? (gexp-references exp)) + (remove native-input? (gexp-references exp))))) (define gexp-native-inputs (cut gexp-inputs <> #:native? #t)) @@ -687,7 +703,7 @@ and in the current monad setting (system type, etc.)" (if (gexp-input? ref) ref (%gexp-input ref "out" n?)) - native?)) + (or n? native?))) refs))) (($ <gexp-input> (? struct? thing) output n?) (let ((target (if (or n? native?) #f target))) @@ -706,9 +722,7 @@ and in the current monad setting (system type, etc.)" (mlet %store-monad ((args (sequence %store-monad - (append (map reference->sexp (gexp-references exp)) - (map (cut reference->sexp <> #t) - (gexp-native-references exp)))))) + (map reference->sexp (gexp-references exp))))) (return (apply (gexp-proc exp) args)))) (define (syntax-location-string s) @@ -724,6 +738,17 @@ and in the current monad setting (system type, etc.)" (simple-format #f "~a:~a" line column))) "<unknown location>"))) +(define-syntax-parameter current-imported-modules + ;; Current list of imported modules. + (identifier-syntax '())) + +(define-syntax-rule (with-imported-modules modules body ...) + "Mark the gexps defined in BODY... as requiring MODULES in their execution +environment." + (syntax-parameterize ((current-imported-modules + (identifier-syntax modules))) + body ...)) + (define-syntax gexp (lambda (s) (define (collect-escapes exp) @@ -741,33 +766,9 @@ and in the current monad setting (system type, etc.)" ((ungexp-splicing _ ...) (cons exp result)) ((ungexp-native _ ...) - result) - ((ungexp-native-splicing _ ...) - result) - ((exp0 exp ...) - (let ((result (loop #'exp0 result))) - (fold loop result #'(exp ...)))) - (_ - result)))) - - (define (collect-native-escapes exp) - ;; Return all the 'ungexp-native' forms present in EXP. - (let loop ((exp exp) - (result '())) - (syntax-case exp (ungexp - ungexp-splicing - ungexp-native - ungexp-native-splicing) - ((ungexp-native _) - (cons exp result)) - ((ungexp-native _ _) (cons exp result)) ((ungexp-native-splicing _ ...) (cons exp result)) - ((ungexp _ ...) - result) - ((ungexp-splicing _ ...) - result) ((exp0 exp ...) (let ((result (loop #'exp0 result))) (fold loop result #'(exp ...)))) @@ -838,14 +839,12 @@ and in the current monad setting (system type, etc.)" (syntax-case s (ungexp output) ((_ exp) - (let* ((normals (delete-duplicates (collect-escapes #'exp))) - (natives (delete-duplicates (collect-native-escapes #'exp))) - (escapes (append normals natives)) + (let* ((escapes (delete-duplicates (collect-escapes #'exp))) (formals (generate-temporaries escapes)) (sexp (substitute-references #'exp (zip escapes formals))) - (refs (map escape->ref normals)) - (nrefs (map escape->ref natives))) - #`(make-gexp (list #,@refs) (list #,@nrefs) + (refs (map escape->ref escapes))) + #`(make-gexp (list #,@refs) + current-imported-modules (lambda #,formals #,sexp))))))) @@ -983,12 +982,24 @@ they can refer to each other." (module-ref (resolve-interface '(gnu packages commencement)) 'guile-final)) -(define* (gexp->script name exp - #:key (modules '()) (guile (default-guile))) - "Return an executable script NAME that runs EXP using GUILE with MODULES in -its search path." +(define (load-path-expression modules) + "Return as a monadic value a gexp that sets '%load-path' and +'%load-compiled-path' to point to MODULES, a list of module names." (mlet %store-monad ((modules (imported-modules modules)) (compiled (compiled-modules modules))) + (return (gexp (eval-when (expand load eval) + (set! %load-path + (cons (ungexp modules) %load-path)) + (set! %load-compiled-path + (cons (ungexp compiled) + %load-compiled-path))))))) + +(define* (gexp->script name exp + #:key (guile (default-guile))) + "Return an executable script NAME that runs EXP using GUILE, with EXP's +imported modules in its search path." + (mlet %store-monad ((set-load-path + (load-path-expression (gexp-modules exp)))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1001,28 +1012,33 @@ its search path." "#!~a/bin/guile --no-auto-compile~%!#~%" (ungexp guile)) - ;; Write the 'eval-when' form so that it can be - ;; compiled. - (write - '(eval-when (expand load eval) - (set! %load-path - (cons (ungexp modules) %load-path)) - (set! %load-compiled-path - (cons (ungexp compiled) - %load-compiled-path))) - port) + (write '(ungexp set-load-path) port) (write '(ungexp exp) port) (chmod port #o555))))))) -(define (gexp->file name exp) - "Return a derivation that builds a file NAME containing EXP." - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (write '(ungexp exp) port)))) - #:local-build? #t - #:substitutable? #f)) +(define* (gexp->file name exp #:key (set-load-path? #t)) + "Return a derivation that builds a file NAME containing EXP. 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." + (match (if set-load-path? (gexp-modules exp) '()) + (() ;zero modules + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp exp) port)))) + #:local-build? #t + #:substitutable? #f)) + ((modules ...) + (mlet %store-monad ((set-load-path (load-path-expression modules))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp set-load-path) port) + (write '(ungexp exp) port)))) + #:local-build? #t + #:substitutable? #f))))) (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing |