;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
gexp-input
gexp-input?
+ gexp-input-thing
+ gexp-input-output
+ gexp-input-native?
local-file
local-file?
load-path-expression
gexp-modules
+ lower-gexp
+ lowered-gexp?
+ lowered-gexp-sexp
+ lowered-gexp-inputs
+ lowered-gexp-sources
+ lowered-gexp-guile
+ lowered-gexp-load-path
+ lowered-gexp-load-compiled-path
+
gexp->derivation
gexp->file
gexp->script
(#f
(raise (condition (&gexp-input-error (input obj)))))
(lower
- (lower obj system target))))
+ ;; Cache in STORE the result of lowering OBJ.
+ (mlet %store-monad ((graft? (grafting?)))
+ (mcached (let ((lower (lookup-compiler obj)))
+ (lower obj system target))
+ obj
+ system target graft?)))))
(define-syntax define-gexp-compiler
(syntax-rules (=> compiler expander)
(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)))))
+ #:system system #:target target options))
+ (apply gexp->derivation name gexp
+ #:system system #:target target options)))))
(define-record-type <program-file>
(%program-file name gexp guile path)
(($ <program-file> name gexp guile module-path)
(gexp->script name gexp
#:module-path module-path
- #:guile (or guile (default-guile))))))
+ #:guile (or guile (default-guile))
+ #:system system
+ #:target target))))
(define-record-type <scheme-file>
(%scheme-file name gexp splice?)
(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-attribute gexp self-attribute)
+(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."
+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 (self-attribute gexp)
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."
- (gexp-attribute gexp gexp-self-modules))
+ (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?
(define* (lower-inputs inputs
#:key system target)
- "Turn any package from INPUTS into a derivation for SYSTEM; return the
-corresponding input list as a monadic value. When TARGET is true, use it as
-the cross-compilation target triplet."
+ "Turn any object from INPUTS into a derivation input for SYSTEM or a store
+item (a \"source\"); return the corresponding input list as a monadic value.
+When TARGET is true, use it as the cross-compilation target triplet."
+ (define (store-item? obj)
+ (and (string? obj) (store-path? obj)))
+
(with-monad %store-monad
- (sequence %store-monad
- (map (match-lambda
- (((? struct? thing) sub-drv ...)
- (mlet %store-monad ((drv (lower-object
- thing system #:target target)))
- (return `(,drv ,@sub-drv))))
- (input
- (return input)))
- inputs))))
+ (mapm %store-monad
+ (match-lambda
+ (((? struct? thing) sub-drv ...)
+ (mlet %store-monad ((obj (lower-object
+ thing system #:target target)))
+ (return (match obj
+ ((? derivation? drv)
+ (let ((outputs (if (null? sub-drv)
+ '("out")
+ sub-drv)))
+ (derivation-input drv outputs)))
+ ((? store-item? item)
+ item)))))
+ (((? store-item? item))
+ (return item)))
+ inputs)))
(define* (lower-reference-graphs graphs #:key system target)
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
#:reference-graphs argument, lower it such that each INPUT is replaced by the
-corresponding derivation."
+corresponding <derivation-input> or store item."
(match graphs
(((file-names . inputs) ...)
(mlet %store-monad ((inputs (lower-inputs inputs
#:target target)))
(return (derivation->output-path drv))))))
- (sequence %store-monad (map lower lst))))
+ (mapm %store-monad lower lst)))
(define default-guile-derivation
;; Here we break the abstraction by talking to the higher-level layer.
(lambda (system)
((force proc) system))))
+;; Representation of a gexp instantiated for a given target and system.
+;; It's an intermediate representation between <gexp> and <derivation>.
+(define-record-type <lowered-gexp>
+ (lowered-gexp sexp inputs sources guile load-path load-compiled-path)
+ lowered-gexp?
+ (sexp lowered-gexp-sexp) ;sexp
+ (inputs lowered-gexp-inputs) ;list of <derivation-input>
+ (sources lowered-gexp-sources) ;list of store items
+ (guile lowered-gexp-guile) ;<derivation-input> | #f
+ (load-path lowered-gexp-load-path) ;list of store items
+ (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items
+
+(define* (imported+compiled-modules modules system
+ #:key (extensions '())
+ deprecation-warnings guile
+ (module-path %load-path))
+ "Return a pair where the first element is the imported MODULES and the
+second element is the derivation to compile them."
+ (mcached equal?
+ (mlet %store-monad ((modules (if (pair? modules)
+ (imported-modules modules
+ #:system system
+ #:module-path module-path)
+ (return #f)))
+ (compiled (if (pair? modules)
+ (compiled-modules modules
+ #:system system
+ #:module-path module-path
+ #:extensions extensions
+ #:guile guile
+ #:deprecation-warnings
+ deprecation-warnings)
+ (return #f))))
+ (return (cons modules compiled)))
+ modules
+ system extensions guile deprecation-warnings module-path))
+
+(define* (lower-gexp exp
+ #:key
+ (module-path %load-path)
+ (system (%current-system))
+ (target 'current)
+ (graft? (%graft?))
+ (guile-for-build (%guile-for-build))
+ (effective-version "2.2")
+
+ deprecation-warnings)
+ "*Note: This API is subject to change; use at your own risk!*
+
+Lower EXP, a gexp, instantiating it for SYSTEM and TARGET. Return a
+<lowered-gexp> ready to be used.
+
+Lowered gexps are an intermediate representation that's useful for
+applications that deal with gexps outside in a way that is disconnected from
+derivations--e.g., code evaluated for its side effects."
+ (define %modules
+ (delete-duplicates (gexp-modules exp)))
+
+ (define (search-path modules extensions suffix)
+ (append (match modules
+ ((? derivation? drv)
+ (list (derivation->output-path drv)))
+ (#f
+ '())
+ ((? store-path? item)
+ (list item)))
+ (map (lambda (extension)
+ (string-append (match extension
+ ((? derivation? drv)
+ (derivation->output-path drv))
+ ((? store-path? item)
+ item))
+ suffix))
+ extensions)))
+
+ (mlet* %store-monad ( ;; The following binding forces '%current-system' and
+ ;; '%current-target-system' to be looked up at >>=
+ ;; time.
+ (graft? (set-grafting graft?))
+
+ (system -> (or system (%current-system)))
+ (target -> (if (eq? target 'current)
+ (%current-target-system)
+ target))
+ (guile (if guile-for-build
+ (return guile-for-build)
+ (default-guile-derivation system)))
+ (normals (lower-inputs (gexp-inputs exp)
+ #:system system
+ #:target target))
+ (natives (lower-inputs (gexp-native-inputs exp)
+ #:system system
+ #:target #f))
+ (inputs -> (append normals natives))
+ (sexp (gexp->sexp exp
+ #:system system
+ #:target target))
+ (extensions -> (gexp-extensions exp))
+ (exts (mapm %store-monad
+ (lambda (obj)
+ (lower-object obj system))
+ extensions))
+ (modules+compiled (imported+compiled-modules
+ %modules system
+ #:extensions extensions
+ #:deprecation-warnings
+ deprecation-warnings
+ #:guile guile
+ #:module-path module-path))
+ (modules -> (car modules+compiled))
+ (compiled -> (cdr modules+compiled)))
+ (define load-path
+ (search-path modules exts
+ (string-append "/share/guile/site/" effective-version)))
+
+ (define load-compiled-path
+ (search-path compiled exts
+ (string-append "/lib/guile/" effective-version
+ "/site-ccache")))
+
+ (mbegin %store-monad
+ (set-grafting graft?) ;restore the initial setting
+ (return (lowered-gexp sexp
+ `(,@(if (derivation? modules)
+ (list (derivation-input modules))
+ '())
+ ,@(if compiled
+ (list (derivation-input compiled))
+ '())
+ ,@(map derivation-input exts)
+ ,@(filter derivation-input? inputs))
+ (filter string? (cons modules inputs))
+ (derivation-input guile '("out"))
+ load-path
+ load-compiled-path)))))
+
(define* (gexp->derivation name exp
#:key
system (target 'current)
allowed-references disallowed-references
leaked-env-vars
local-build? (substitutable? #t)
+ (properties '())
deprecation-warnings
(script-name (string-append name "-builder")))
"Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
compiling modules. It can be #f, #t, or 'detailed.
The other arguments are as for 'derivation'."
- (define %modules
- (delete-duplicates
- (append modules (gexp-modules exp))))
(define outputs (gexp-outputs exp))
+ (define requested-graft? graft?)
(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.
- ((file-name (? derivation? drv))
- (cons file-name (derivation->output-path drv)))
- ((file-name (? derivation? drv) sub-drv)
- (cons file-name (derivation->output-path drv sub-drv)))
- ((file-name thing)
- (cons file-name thing)))
+ ((file-name . (? derivation-input? input))
+ (cons file-name (first (derivation-input-output-paths input))))
+ ((file-name . (? string? item))
+ (cons file-name item)))
graphs))
- (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")))
+ (define (add-modules exp modules)
+ (if (null? modules)
+ exp
+ (make-gexp (gexp-references exp)
+ (append modules (gexp-self-modules exp))
+ (gexp-self-extensions exp)
+ (gexp-proc exp))))
(mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>=
(target -> (if (eq? target 'current)
(%current-target-system)
target))
- (normals (lower-inputs (gexp-inputs exp)
- #:system system
- #:target target))
- (natives (lower-inputs (gexp-native-inputs exp)
- #:system system
- #:target #f))
- (inputs -> (append normals natives))
- (sexp (gexp->sexp exp
- #:system system
- #: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
- #:module-path module-path
- #:guile guile-for-build
- #:deprecation-warnings
- deprecation-warnings)
- (return #f)))
- (compiled (if (pair? %modules)
- (compiled-modules %modules
- #:system system
- #:module-path module-path
- #:extensions extensions
- #:guile guile-for-build
- #:deprecation-warnings
- deprecation-warnings)
- (return #f)))
+ (exp -> (add-modules exp modules))
+ (lowered (lower-gexp exp
+ #:module-path module-path
+ #:system system
+ #:target target
+ #:graft? requested-graft?
+ #:guile-for-build
+ guile-for-build
+ #:effective-version
+ effective-version
+ #:deprecation-warnings
+ deprecation-warnings))
+
(graphs (if references-graphs
(lower-reference-graphs references-graphs
#:system system
#:system system
#:target target)
(return #f)))
- (guile (if guile-for-build
- (return guile-for-build)
- (default-guile-derivation system))))
+ (guile -> (lowered-gexp-guile lowered))
+ (builder (text-file script-name
+ (object->string
+ (lowered-gexp-sexp lowered)))))
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
(raw-derivation name
- (string-append (derivation->output-path guile)
+ (string-append (derivation-input-output-path guile)
"/bin/guile")
`("--no-auto-compile"
- ,@(if (pair? %modules)
- `("-L" ,(derivation->output-path modules)
- "-C" ,(derivation->output-path compiled))
- '())
- ,@(append-map extension-flags exts)
+ ,@(append-map (lambda (directory)
+ `("-L" ,directory))
+ (lowered-gexp-load-path lowered))
+ ,@(append-map (lambda (directory)
+ `("-C" ,directory))
+ (lowered-gexp-load-compiled-path lowered))
,builder)
#:outputs outputs
#:env-vars env-vars
#:system system
- #:inputs `((,guile)
- (,builder)
- ,@(if modules
- `((,modules) (,compiled) ,@inputs)
- inputs)
- ,@(map list exts)
+ #:inputs `(,guile
+ ,@(lowered-gexp-inputs lowered)
,@(match graphs
- (((_ . inputs) ...) inputs)
- (_ '())))
+ (((_ . inputs) ...)
+ (filter derivation-input? inputs))
+ (#f '())))
+ #:sources `(,builder
+ ,@(if (and (string? modules)
+ (store-path? modules))
+ (list modules)
+ '())
+ ,@(lowered-gexp-sources lowered)
+ ,@(match graphs
+ (((_ . inputs) ...)
+ (filter string? inputs))
+ (#f '())))
+
#:hash hash #:hash-algo hash-algo #:recursive? recursive?
#:references-graphs (and=> graphs graphs-file-names)
#:allowed-references allowed
#:disallowed-references disallowed
#:leaked-env-vars leaked-env-vars
#:local-build? local-build?
- #:substitutable? substitutable?))))
+ #:substitutable? substitutable?
+ #:properties properties))))
(define* (gexp-inputs exp #:key native?)
"Return the input list for EXP. When NATIVE? is true, return only native
references; otherwise, return only non-native references."
+ ;; TODO: Return <gexp-input> records instead of tuples.
(define (add-reference-inputs ref result)
(match ref
(($ <gexp-input> (? gexp? exp) _ #t)
(target (%current-target-system)))
"Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
and in the current monad setting (system type, etc.)"
+ (define (self-quoting? x)
+ (letrec-syntax ((one-of (syntax-rules ()
+ ((_) #f)
+ ((_ pred rest ...)
+ (or (pred x)
+ (one-of rest ...))))))
+ (one-of symbol? string? keyword? pair? null? array?
+ number? boolean?)))
+
(define* (reference->sexp ref #:optional native?)
(with-monad %store-monad
(match ref
#:system system
#:target (if (or n? native?) #f target)))
(($ <gexp-input> (refs ...) output n?)
- (sequence %store-monad
- (map (lambda (ref)
- ;; XXX: Automatically convert REF to an gexp-input.
- (reference->sexp
- (if (gexp-input? ref)
- ref
- (%gexp-input ref "out" n?))
- (or n? native?)))
- refs)))
+ (mapm %store-monad
+ (lambda (ref)
+ ;; XXX: Automatically convert REF to an gexp-input.
+ (reference->sexp
+ (if (gexp-input? ref)
+ ref
+ (%gexp-input ref "out" n?))
+ (or n? native?)))
+ refs))
(($ <gexp-input> (? struct? thing) output n?)
(let ((target (if (or n? native?) #f target))
(expand (lookup-expander thing)))
#:target target)))
;; OBJ must be either a derivation or a store file name.
(return (expand thing obj output)))))
- (($ <gexp-input> x)
+ (($ <gexp-input> (? self-quoting? x))
(return x))
+ (($ <gexp-input> x)
+ (raise (condition (&gexp-input-error (input x)))))
(x
(return x)))))
(mlet %store-monad
- ((args (sequence %store-monad
- (map reference->sexp (gexp-references exp)))))
+ ((args (mapm %store-monad
+ reference->sexp (gexp-references exp))))
(return (apply (gexp-proc exp) args))))
-(define (syntax-location-string s)
- "Return a string representing the source code location of S."
- (let ((props (syntax-source s)))
- (if props
- (let ((file (assoc-ref props 'filename))
- (line (and=> (assoc-ref props 'line) 1+))
- (column (assoc-ref props 'column)))
- (if file
- (simple-format #f "~a:~a:~a"
- file line column)
- (simple-format #f "~a:~a" line column)))
- "<unknown location>")))
-
-(define-syntax-parameter current-imported-modules
+(define-syntax-rule (define-syntax-parameter-once name proc)
+ ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME
+ ;; does not get redefined. This works around a race condition in a
+ ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>.
+ (eval-when (load eval expand compile)
+ (define name
+ (if (module-locally-bound? (current-module) 'name)
+ (module-ref (current-module) 'name)
+ (make-syntax-transformer 'name 'syntax-parameter
+ (list proc))))))
+
+(define-syntax-parameter-once current-imported-modules
;; Current list of imported modules.
(identifier-syntax '()))
(identifier-syntax modules)))
body ...))
-(define-syntax-parameter current-imported-extensions
+(define-syntax-parameter-once current-imported-extensions
;; Current list of extensions.
(identifier-syntax '()))
;;; 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)))
"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))
(mlet %store-monad ((file (lower-object file-like system)))
(return (list final-path file))))))
- (mlet %store-monad ((files (sequence %store-monad
- (map file-pair files))))
+ (mlet %store-monad ((files (mapm %store-monad file-pair files)))
(define build
(gexp
(begin
(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
#:guile-for-build guile
#:local-build? #t
- ;; TODO: On the next rebuild cycle, set to "no"
- ;; unconditionally.
+ ;; Avoid deprecation warnings about the use of the _IO*
+ ;; constants in (guix build utils).
#:env-vars
- (case deprecation-warnings
- ((#f)
- '(("GUILE_WARN_DEPRECATED" . "no")))
- ((detailed)
- '(("GUILE_WARN_DEPRECATED" . "detailed")))
- (else
- '())))))
+ '(("GUILE_WARN_DEPRECATED" . "no")))))
+
+(define* (imported-files files
+ #:key (name "file-import")
+ ;; The following parameters make sense when creating
+ ;; an actual derivation.
+ (system (%current-system))
+ (guile (%guile-for-build)))
+ "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 (any (match-lambda
+ ((_ . (? struct? source)) #t)
+ (_ #f))
+ files)
+ (imported-files/derivation files #:name name
+ #:symlink? derivation?
+ #:system system #:guile guile)
+ (interned-file-tree `(,name directory
+ ,@(file-mapping->tree files)))))
(define* (imported-modules modules
#:key (name "module-import")
(system (%current-system))
(guile (%guile-for-build))
- (module-path %load-path)
- (deprecation-warnings #f))
+ (module-path %load-path))
"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
(let ((f (module->source-file-name module)))
(cons f (search-path* module-path f)))))
modules)))
- (imported-files files #:name name #:system system
- #:guile guile
- #:deprecation-warnings deprecation-warnings)))
+ (imported-files files #:name name
+ #:system system
+ #:guile guile)))
(define* (compiled-modules modules
#:key (name "module-import-compiled")
(system (%current-system))
+ target
(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."
+they can refer to each other. When TARGET is true, cross-compile MODULES for
+TARGET, a GNU triplet."
(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
#:system system
#:guile guile
#:module-path
- module-path
- #:deprecation-warnings
- deprecation-warnings)))
+ module-path)))
(define build
(gexp
(begin
(srfi srfi-26)
(system base compile))
+ ;; TODO: Inline this on the next rebuild cycle.
+ (ungexp-splicing
+ (if target
+ (gexp ((use-modules (system base target))))
+ (gexp ())))
+
(define (regular? file)
(not (member file '("." ".."))))
(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 (ungexp total))
+ (ungexp (* total 2))
+ entry)
+
+ (ungexp-splicing
+ (if target
+ (gexp ((with-target (ungexp target)
+ (lambda ()
+ (compile-file entry
+ #:output-file output
+ #:opts
+ %auto-compilation-options)))))
+ (gexp ((compile-file entry
+ #:output-file output
+ #:opts %auto-compilation-options)))))
+
(+ 1 processed))))
(define (process-directory directory output processed)
processed
entries)))
+ (define* (load-from-directory directory
+ #:optional (loaded 0))
+ "Load all the source files found in DIRECTORY."
+ ;; XXX: This works around <https://bugs.gnu.org/15602>.
+ (let ((entries (map (cut string-append directory "/" <>)
+ (scandir directory regular?))))
+ (fold (lambda (file loaded)
+ (if (file-is-directory? file)
+ (load-from-directory file loaded)
+ (begin
+ (format #t "[~2@a/~2@a] Loading '~a'...~%"
+ (+ 1 loaded) (ungexp (* 2 total))
+ file)
+ (save-module-excursion
+ (lambda ()
+ (primitive-load file)))
+ (+ 1 loaded))))
+ loaded
+ 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))))
- '()))
+ (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
+ (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)))))
- '()))
+ ;; Above we loaded our own (guix build utils) but now we may need to
+ ;; load a compile a different one. Thus, force a reload.
+ (let ((utils (string-append (ungexp modules)
+ "/guix/build/utils.scm")))
+ (when (file-exists? utils)
+ (load utils)))
(mkdir (ungexp output))
(chdir (ungexp modules))
+
+ (load-from-directory ".")
(process-directory "." (ungexp output) 0))))
;; TODO: Pass MODULES as an environment variable.
'guile-2.2))
(define* (load-path-expression modules #:optional (path %load-path)
- #:key (extensions '()))
+ #:key (extensions '()) system target)
"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)
- (append (map (lambda (extension)
+are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty."
+ (if (and (null? modules) (null? extensions))
+ (with-monad %store-monad
+ (return #f))
+ (mlet %store-monad ((modules (imported-modules modules
+ #:module-path path
+ #:system system))
+ (compiled (compiled-modules modules
+ #:extensions extensions
+ #:module-path path
+ #:system system
+ #:target target)))
+ (return
+ (gexp (eval-when (expand load eval)
+ ;; Augment the load paths and delete duplicates. Do that
+ ;; without loading (srfi srfi-1) or anything.
+ (let ((extensions '((ungexp-splicing extensions)))
+ (prepend (lambda (items lst)
+ ;; This is O(N²) but N is typically small.
+ (let loop ((items items)
+ (lst lst))
+ (if (null? items)
+ lst
+ (loop (cdr items)
+ (cons (car items)
+ (delete (car items) lst))))))))
+ (set! %load-path
+ (prepend (cons (ungexp modules)
+ (map (lambda (extension)
(string-append extension
"/share/guile/site/"
(effective-version)))
- '((ungexp-native-splicing extensions)))
- %load-path)))
- (set! %load-compiled-path
- (cons (ungexp compiled)
- (append (map (lambda (extension)
+ extensions))
+ %load-path))
+ (set! %load-compiled-path
+ (prepend (cons (ungexp compiled)
+ (map (lambda (extension)
(string-append extension
"/lib/guile/"
(effective-version)
"/site-ccache"))
- '((ungexp-native-splicing extensions)))
- %load-compiled-path))))))))
+ extensions))
+ %load-compiled-path)))))))))
(define* (gexp->script name exp
#:key (guile (default-guile))
- (module-path %load-path))
+ (module-path %load-path)
+ (system (%current-system))
+ target)
"Return an executable script NAME that runs EXP using GUILE, with EXP's
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
#:extensions
- (gexp-extensions exp))))
+ (gexp-extensions exp)
+ #:system system
+ #:target target)))
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
"#!~a/bin/guile --no-auto-compile~%!#~%"
(ungexp guile))
- (write '(ungexp set-load-path) port)
+ (ungexp-splicing
+ (if set-load-path
+ (gexp ((write '(ungexp set-load-path) port)))
+ (gexp ())))
+
(write '(ungexp exp) port)
(chmod port #o555))))
+ #:system system
+ #:target target
#:module-path module-path)))
(define* (gexp->file name exp #:key
`((\"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)