;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix derivations)
#:use-module (guix grafts)
#:use-module (guix utils)
+ #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (gexp
gexp?
with-imported-modules
+ with-extensions
gexp-input
gexp-input?
program-file-name
program-file-gexp
program-file-guile
+ program-file-module-path
scheme-file
scheme-file?
define-gexp-compiler
gexp-compiler?
+ file-like?
lower-object
lower-inputs
;; "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)
(and=> (hashq-ref %gexp-compilers (struct-vtable object))
gexp-compiler-lower))
+(define (file-like? object)
+ "Return #t if OBJECT leads to a file in the store once unquoted in a
+G-expression; otherwise return #f."
+ (and (struct? object) (->bool (lookup-compiler object))))
+
(define (lookup-expander object)
"Search for an expander for OBJECT. Upon success, return the three argument
procedure to expand it; otherwise return #f."
(%plain-file name content references)
plain-file?
(name plain-file-name) ;string
- (content plain-file-content) ;string
+ (content plain-file-content) ;string or bytevector
(references plain-file-references)) ;list (currently unused)
(define (plain-file name content)
(define-gexp-compiler (plain-file-compiler (file <plain-file>) system target)
;; "Compile" FILE by adding it to the store.
(match file
- (($ <plain-file> name content references)
- (text-file name content references))))
+ (($ <plain-file> name (and (? string?) content) references)
+ (text-file name content references))
+ (($ <plain-file> name (and (? bytevector?) content) references)
+ (binary-file name content references))))
(define-record-type <computed-file>
- (%computed-file name gexp options)
+ (%computed-file name gexp guile options)
computed-file?
(name computed-file-name) ;string
(gexp computed-file-gexp) ;gexp
+ (guile computed-file-guile) ;<package>
(options computed-file-options)) ;list of arguments
(define* (computed-file name gexp
- #:key (options '(#:local-build? #t)))
+ #:key guile (options '(#:local-build? #t)))
"Return an object representing the store item NAME, a file or directory
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 options))
+ (%computed-file name gexp guile 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 options)
- (apply gexp->derivation name gexp options))))
+ (($ <computed-file> name gexp guile options)
+ (if guile
+ (mlet %store-monad ((guile (lower-object guile system
+ #:target target)))
+ (apply gexp->derivation name gexp #:guile-for-build guile
+ options))
+ (apply gexp->derivation name gexp options)))))
(define-record-type <program-file>
- (%program-file name gexp guile)
+ (%program-file name gexp guile path)
program-file?
(name program-file-name) ;string
(gexp program-file-gexp) ;gexp
- (guile program-file-guile)) ;package
+ (guile program-file-guile) ;package
+ (path program-file-module-path)) ;list of strings
-(define* (program-file name gexp #:key (guile #f))
+(define* (program-file name gexp #:key (guile #f) (module-path %load-path))
"Return an object representing the executable store item NAME that runs
-GEXP. GUILE is the Guile package used to execute that script.
+GEXP. GUILE is the Guile package used to execute that script. Imported
+modules of GEXP are looked up in MODULE-PATH.
This is the declarative counterpart of 'gexp->script'."
- (%program-file name gexp guile))
+ (%program-file name gexp guile module-path))
(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 guile)
+ (($ <program-file> name gexp guile module-path)
(gexp->script name gexp
+ #:module-path module-path
#:guile (or guile (default-guile))))))
(define-record-type <scheme-file>
- (%scheme-file name gexp)
+ (%scheme-file name gexp splice?)
scheme-file?
(name scheme-file-name) ;string
- (gexp scheme-file-gexp)) ;gexp
+ (gexp scheme-file-gexp) ;gexp
+ (splice? scheme-file-splice?)) ;Boolean
-(define* (scheme-file name gexp)
+(define* (scheme-file name gexp #:key splice?)
"Return an object representing the Scheme file NAME that contains GEXP.
This is the declarative counterpart of 'gexp->file'."
- (%scheme-file name gexp))
+ (%scheme-file name gexp splice?))
(define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
system target)
;; Compile FILE by returning a derivation that builds the file.
(match file
- (($ <scheme-file> name gexp)
- (gexp->file name gexp))))
+ (($ <scheme-file> name gexp splice?)
+ (gexp->file name gexp #:splice? splice?))))
;; Appending SUFFIX to BASE's output file name.
(define-record-type <file-append>
(base file-append-base) ;<package> | <derivation> | ...
(suffix file-append-suffix)) ;list of strings
+(define (write-file-append file port)
+ (match file
+ (($ <file-append> base suffix)
+ (format port "#<file-append ~s ~s>" base
+ (string-join suffix)))))
+
+(set-record-type-printer! <file-append> write-file-append)
+
(define (file-append base . suffix)
"Return a <file-append> object that expands to the concatenation of BASE and
SUFFIX."
(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 #:optional (equal? equal?))
+ "Recurse on GEXP and the expressions it refers to, summing the items
+returned by SELF-ATTRIBUTE, a procedure that takes a gexp. Use EQUAL? as the
+second argument to 'delete-duplicates'."
(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))
(_
'()))
- (gexp-references gexp))))
+ (gexp-references gexp)))
+ equal?)
'())) ;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."
+ (define (module=? m1 m2)
+ ;; Return #t when M1 equals M2. Special-case '=>' specs because their
+ ;; right-hand side may not be comparable with 'equal?': it's typically a
+ ;; file-like object that embeds a gexp, which in turn embeds closure;
+ ;; those closures may be 'eq?' when running compiled code but are unlikely
+ ;; to be 'eq?' when running on 'eval'. Ignore the right-hand side to
+ ;; avoid this discrepancy.
+ (match m1
+ (((name1 ...) '=> _)
+ (match m2
+ (((name2 ...) '=> _) (equal? name1 name2))
+ (_ #f)))
+ (_
+ (equal? m1 m2))))
+
+ (gexp-attribute gexp gexp-self-modules module=?))
+
+(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
(modules '())
(module-path %load-path)
(guile-for-build (%guile-for-build))
+ (effective-version "2.2")
(graft? (%graft?))
references-graphs
allowed-references disallowed-references
leaked-env-vars
local-build? (substitutable? #t)
+
+ ;; TODO: This parameter is transitional; it's here
+ ;; to avoid a full rebuild. Remove it on the next
+ ;; rebuild cycle.
+ import-creates-derivation?
+
+ deprecation-warnings
(script-name (string-append name "-builder")))
"Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When
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.
Similarly for DISALLOWED-REFERENCES, which can list items that must not be
referenced by the outputs.
+DEPRECATION-WARNINGS determines whether to show deprecation warnings while
+compiling modules. It can be #f, #t, or 'detailed.
+
The other arguments are as for 'derivation'."
(define %modules
(delete-duplicates
(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)
(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?))
#: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
+ #:derivation?
+ import-creates-derivation?
#:system system
#:module-path module-path
- #:guile guile-for-build)
+ #:guile guile-for-build
+ #:deprecation-warnings
+ deprecation-warnings)
(return #f)))
(compiled (if (pair? %modules)
(compiled-modules %modules
+ #:derivation?
+ import-creates-derivation?
#:system system
#:module-path module-path
- #:guile guile-for-build)
+ #:extensions extensions
+ #:guile guile-for-build
+ #:deprecation-warnings
+ deprecation-warnings)
(return #f)))
(graphs (if references-graphs
(lower-reference-graphs references-graphs
"/bin/guile")
`("--no-auto-compile"
,@(if (pair? %modules)
- `("-L" ,(derivation->output-path modules)
+ `("-L" ,(if (derivation? modules)
+ (derivation->output-path modules)
+ modules)
"-C" ,(derivation->output-path compiled))
'())
+ ,@(append-map extension-flags exts)
,builder)
#:outputs outputs
#:env-vars env-vars
,@(if modules
`((,modules) (,compiled) ,@inputs)
inputs)
+ ,@(map list exts)
,@(match graphs
(((_ . inputs) ...) inputs)
(_ '())))
(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)
(refs (map escape->ref escapes)))
#`(make-gexp (list #,@refs)
current-imported-modules
+ current-imported-extensions
(lambda #,formals
#,sexp)))))))
;;; Module handling.
;;;
+(define %not-slash
+ (char-set-complement (char-set #\/)))
+
+(define (file-mapping->tree mapping)
+ "Convert MAPPING, an alist like:
+
+ ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
+
+to a tree suitable for 'interned-file-tree'."
+ (let ((mapping (map (match-lambda
+ ((destination . source)
+ (cons (string-tokenize destination
+ %not-slash)
+ source)))
+ mapping)))
+ (fold (lambda (pair result)
+ (match pair
+ ((destination . source)
+ (let loop ((destination destination)
+ (result result))
+ (match destination
+ ((file)
+ (let* ((mode (stat:mode (stat source)))
+ (type (if (zero? (logand mode #o100))
+ 'regular
+ 'executable)))
+ (alist-cons file
+ `(,type (file ,source))
+ result)))
+ ((file rest ...)
+ (let ((directory (assoc-ref result file)))
+ (alist-cons file
+ `(directory
+ ,@(loop rest
+ (match directory
+ (('directory . entries) entries)
+ (#f '()))))
+ (if directory
+ (alist-delete file result)
+ result)))))))))
+ '()
+ mapping)))
+
(define %utils-module
;; This file provides 'mkdir-p', needed to implement 'imported-files' and
;; other primitives below. Note: We give the file name relative to this
(local-file "build/utils.scm"
"build-utils.scm"))
-(define* (imported-files files
- #:key (name "file-import")
- (system (%current-system))
- (guile (%guile-for-build)))
+(define* (imported-files/derivation files
+ #:key (name "file-import")
+ (symlink? #f)
+ (system (%current-system))
+ (guile (%guile-for-build))
+
+ ;; XXX: The only reason we have
+ ;; #:deprecation-warnings is because (guix
+ ;; build utils), which we use here, relies
+ ;; on _IO*, which is deprecated in 2.2. On
+ ;; the next full-rebuild cycle, we should
+ ;; disable such warnings unconditionally.
+ (deprecation-warnings #f))
"Return a derivation that imports FILES into STORE. FILES must be a list
of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the
resulting store path. FILE can be either a file name, or a file-like object,
-as returned by 'local-file' for example."
+as returned by 'local-file' for example. If SYMLINK? is true, create symlinks
+to the source files instead of copying them."
(define file-pair
(match-lambda
((final-path . (? string? file-name))
(for-each (match-lambda
((final-path store-path)
(mkdir-p (dirname final-path))
- (symlink store-path final-path)))
+ ((ungexp (if symlink? 'symlink 'copy-file))
+ store-path final-path)))
'(ungexp files)))))
;; TODO: Pass FILES as an environment variable so that BUILD remains
(gexp->derivation name build
#:system system
#:guile-for-build guile
- #:local-build? #t)))
+ #:local-build? #t
+
+ ;; TODO: On the next rebuild cycle, set to "no"
+ ;; unconditionally.
+ #:env-vars
+ (case deprecation-warnings
+ ((#f)
+ '(("GUILE_WARN_DEPRECATED" . "no")))
+ ((detailed)
+ '(("GUILE_WARN_DEPRECATED" . "detailed")))
+ (else
+ '())))))
+
+(define* (imported-files files
+ #:key (name "file-import")
+
+ ;; TODO: Remove this parameter on the next rebuild
+ ;; cycle.
+ (derivation? #f)
+
+ ;; The following parameters make sense when creating
+ ;; an actual derivation.
+ (system (%current-system))
+ (guile (%guile-for-build))
+ (deprecation-warnings #f))
+ "Import FILES into the store and return the resulting derivation or store
+file name (a derivation is created if and only if some elements of FILES are
+file-like objects and not local file names.) FILES must be a list
+of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the
+resulting store path. FILE can be either a file name, or a file-like object,
+as returned by 'local-file' for example."
+ (if (or derivation?
+ (any (match-lambda
+ ((_ . (? struct? source)) #t)
+ (_ #f))
+ files))
+ (imported-files/derivation files #:name name
+ #:symlink? derivation?
+ #:system system #:guile guile
+ #:deprecation-warnings deprecation-warnings)
+ (interned-file-tree `(,name directory
+ ,@(file-mapping->tree files)))))
(define* (imported-modules modules
#:key (name "module-import")
+ (derivation? #f) ;TODO: remove on next rebuild
(system (%current-system))
(guile (%guile-for-build))
- (module-path %load-path))
+ (module-path %load-path)
+ (deprecation-warnings #f))
"Return a derivation that contains the source files of MODULES, a list of
module names such as `(ice-9 q)'. All of MODULES must be either names of
modules to be found in the MODULE-PATH search path, or a module name followed
In this example, the first two modules are taken from MODULE-PATH, and the
last one is created from the given <scheme-file> object."
- (mlet %store-monad ((files
- (mapm %store-monad
- (match-lambda
- (((module ...) '=> file)
- (return
- (cons (module->source-file-name module)
- file)))
- ((module ...)
- (let ((f (module->source-file-name module)))
- (return
- (cons f (search-path* module-path f))))))
- modules)))
- (imported-files files #:name name #:system system
- #:guile guile)))
+ (let ((files (map (match-lambda
+ (((module ...) '=> file)
+ (cons (module->source-file-name module)
+ file))
+ ((module ...)
+ (let ((f (module->source-file-name module)))
+ (cons f (search-path* module-path f)))))
+ modules)))
+ (imported-files files #:name name
+ #:derivation? derivation?
+ #:system system
+ #:guile guile
+ #:deprecation-warnings deprecation-warnings)))
(define* (compiled-modules modules
#:key (name "module-import-compiled")
+ (derivation? #f) ;TODO: remove on next rebuild
(system (%current-system))
(guile (%guile-for-build))
- (module-path %load-path))
+ (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
they can refer to each other."
+ (define total (length modules))
+
+ (define build-utils-hack?
+ ;; To avoid a full rebuild, we limit the fix below to the case where
+ ;; MODULE-PATH is different from %LOAD-PATH. This happens when building
+ ;; modules for 'compute-guix-derivation' upon 'guix pull'. TODO: Make
+ ;; this unconditional on the next rebuild cycle.
+ (and (member '(guix build utils) modules)
+ (not (equal? module-path %load-path))))
+
(mlet %store-monad ((modules (imported-modules modules
+ #:derivation? derivation?
#:system system
#:guile guile
#:module-path
- module-path)))
+ module-path
+ #:deprecation-warnings
+ deprecation-warnings)))
(define build
(gexp
(begin
(primitive-load (ungexp %utils-module)) ;for 'mkdir-p'
(use-modules (ice-9 ftw)
+ (ice-9 format)
+ (srfi srfi-1)
(srfi srfi-26)
(system base compile))
(define (regular? file)
(not (member file '("." ".."))))
- (define (process-directory directory output)
+ (define (process-entry entry output processed)
+ (if (file-is-directory? entry)
+ (let ((output (string-append output "/" (basename entry))))
+ (mkdir-p output)
+ (process-directory entry output processed))
+ (let* ((base (basename entry ".scm"))
+ (output (string-append output "/" base ".go")))
+ (format #t "[~2@a/~2@a] Compiling '~a'...~%"
+ (+ 1 processed) (ungexp total) entry)
+ (compile-file entry
+ #:output-file output
+ #:opts %auto-compilation-options)
+ (+ 1 processed))))
+
+ (define (process-directory directory output processed)
(let ((entries (map (cut string-append directory "/" <>)
(scandir directory regular?))))
- (for-each (lambda (entry)
- (if (file-is-directory? entry)
- (let ((output (string-append output "/"
- (basename entry))))
- (mkdir-p output)
- (process-directory entry output))
- (let* ((base (string-drop-right
- (basename entry)
- 4)) ;.scm
- (output (string-append output "/" base
- ".go")))
- (compile-file entry
- #:output-file output
- #:opts
- %auto-compilation-options))))
- entries)))
+ (fold (cut process-entry <> output <>)
+ processed
+ entries)))
+
+ (setvbuf (current-output-port)
+ (cond-expand (guile-2.2 'line) (else _IOLBF)))
+
+ (ungexp-splicing
+ (if build-utils-hack?
+ (gexp ((define mkdir-p
+ ;; Capture 'mkdir-p'.
+ (@ (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
+ (if build-utils-hack?
+ ;; Above we loaded our own (guix build utils) but now we may
+ ;; need to load a compile a different one. Thus, force a
+ ;; reload.
+ (gexp ((let ((utils (ungexp
+ (file-append modules
+ "/guix/build/utils.scm"))))
+ (when (file-exists? utils)
+ (load utils)))))
+ '()))
+
(mkdir (ungexp output))
(chdir (ungexp modules))
- (process-directory "." (ungexp output)))))
+ (process-directory "." (ungexp output) 0))))
;; TODO: Pass MODULES as an environment variable.
(gexp->derivation name build
#:system system
#:guile-for-build guile
- #:local-build? #t)))
+ #:local-build? #t
+ #:env-vars
+ (case deprecation-warnings
+ ((#f)
+ '(("GUILE_WARN_DEPRECATED" . "no")))
+ ((detailed)
+ '(("GUILE_WARN_DEPRECATED" . "detailed")))
+ (else
+ '())))))
\f
;;;
;;;
(define (default-guile)
- ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …)
+ ;; Lazily resolve 'guile-2.2' (not 'guile-final' because this is for
+ ;; programs returned by 'program-file' and we don't want to keep references
+ ;; to several Guile packages). This module must not refer to (gnu …)
;; modules directly, to avoid circular dependencies, hence this hack.
- (module-ref (resolve-interface '(gnu packages commencement))
- 'guile-final))
+ (module-ref (resolve-interface '(gnu packages guile))
+ 'guile-2.2))
-(define (load-path-expression modules)
+(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."
- (mlet %store-monad ((modules (imported-modules modules))
- (compiled (compiled-modules modules)))
+'%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)))
+ #:key (guile (default-guile))
+ (module-path %load-path))
"Return an executable script NAME that runs EXP using GUILE, with EXP's
-imported modules in its search 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))))
+ (load-path-expression (gexp-modules exp)
+ module-path
+ #:extensions
+ (gexp-extensions exp))))
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
(write '(ungexp set-load-path) port)
(write '(ungexp exp) port)
- (chmod port #o555)))))))
-
-(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)))))
+ (chmod port #o555))))
+ #:module-path module-path)))
+
+(define* (gexp->file name exp #:key
+ (set-load-path? #t)
+ (module-path %load-path)
+ (splice? #f))
+ "Return a derivation that builds a file NAME containing EXP. When SPLICE?
+is true, EXP is considered to be a list of expressions that will be spliced in
+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."
+ (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
`((\"hosts\" ,(plain-file \"hosts\"
\"127.0.0.1 localhost\"))
(\"bashrc\" ,(plain-file \"bashrc\"
- \"alias ls='ls --color'\"))))
+ \"alias ls='ls --color'\"))
+ (\"libvirt/qemu.conf\" ,(plain-file \"qemu.conf\" \"\"))))
This yields an 'etc' directory containing these two files."
(computed-file name
- (gexp
- (begin
- (mkdir (ungexp output))
- (chdir (ungexp output))
- (ungexp-splicing
- (map (match-lambda
- ((target source)
- (gexp
- (begin
- ;; Stat the source to abort early if it does
- ;; not exist.
- (stat (ungexp source))
-
- (symlink (ungexp source)
- (ungexp target))))))
- files))))))
-
-(define (directory-union name things)
+ (with-imported-modules '((guix build utils))
+ (gexp
+ (begin
+ (use-modules (guix build utils))
+
+ (mkdir (ungexp output))
+ (chdir (ungexp output))
+ (ungexp-splicing
+ (map (match-lambda
+ ((target source)
+ (gexp
+ (begin
+ ;; Stat the source to abort early if it does
+ ;; not exist.
+ (stat (ungexp source))
+
+ (mkdir-p (dirname (ungexp target)))
+ (symlink (ungexp source)
+ (ungexp target))))))
+ files)))))))
+
+(define* (directory-union name things
+ #:key (copy? #f) (quiet? #f)
+ (resolve-collision 'warn-about-collision))
"Return a directory that is the union of THINGS, where THINGS is a list of
file-like objects denoting directories. For example:
(directory-union \"guile+emacs\" (list guile emacs))
-yields a directory that is the union of the 'guile' and 'emacs' packages."
+yields a directory that is the union of the 'guile' and 'emacs' packages.
+
+Call RESOLVE-COLLISION when several files collide, passing it the list of
+colliding files. RESOLVE-COLLISION must return the chosen file or #f, in
+which case the colliding entry is skipped altogether.
+
+When HARD-LINKS? is true, create hard links instead of symlinks. When QUIET?
+is true, the derivation will not print anything."
+ (define symlink
+ (if copy?
+ (gexp (lambda (old new)
+ (if (file-is-directory? old)
+ (symlink old new)
+ (copy-file old new))))
+ (gexp symlink)))
+
+ (define log-port
+ (if quiet?
+ (gexp (%make-void-port "w"))
+ (gexp (current-error-port))))
+
(match things
((one)
;; Only one thing; return it.
(computed-file name
(with-imported-modules '((guix build union))
(gexp (begin
- (use-modules (guix build union))
+ (use-modules (guix build union)
+ (srfi srfi-1)) ;for 'first' and 'last'
+
(union-build (ungexp output)
- '(ungexp things)))))))))
+ '(ungexp things)
+
+ #:log-port (ungexp log-port)
+ #:symlink (ungexp symlink)
+ #:resolve-collision
+ (ungexp resolve-collision)))))))))
\f
;;;
HCoop / jackhill / guix / guix.git / blobdiff