;;; GNU Guix --- Functional package management for GNU
;;; 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?
;; "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)
(%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 guile options)
(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
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.
(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
(return #f)))
(compiled (if (pair? %modules)
(compiled-modules %modules
+ #:derivation?
+ import-creates-derivation?
#:system system
#:module-path module-path
+ #:extensions extensions
#:guile guile-for-build
#:deprecation-warnings
deprecation-warnings)
"/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))
-
- ;; 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))
+(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
(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)
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
+ (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)
+ (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
(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) 0))))
(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))
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)
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
`((\"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))))))
+ (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)
HCoop / jackhill / guix / guix.git / blobdiff