;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix derivations)
#:use-module (guix grafts)
#:use-module (guix utils)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (gexp
gexp?
with-imported-modules
with-extensions
+ let-system
gexp-input
gexp-input?
gexp-input-output
gexp-input-native?
+ assume-valid-file-name
local-file
local-file?
local-file-file
local-file-absolute-file-name
local-file-name
local-file-recursive?
+ local-file-select?
plain-file
plain-file?
file-append-base
file-append-suffix
+ raw-derivation-file
+ raw-derivation-file?
+
+ with-parameters
+ parameterized?
+
load-path-expression
gexp-modules
;; "G expressions".
(define-record-type <gexp>
- (make-gexp references modules extensions proc)
+ (make-gexp references modules extensions proc location)
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
+ (proc gexp-proc) ;procedure
+ (location %gexp-location)) ;location alist
+
+(define (gexp-location gexp)
+ "Return the source code location of GEXP."
+ (and=> (%gexp-location gexp) source-properties->location))
(define (write-gexp gexp port)
"Write GEXP on PORT."
(write (apply (gexp-proc gexp)
(gexp-references gexp))
port))
+
+ (let ((loc (gexp-location gexp)))
+ (when loc
+ (format port " ~a" (location->string loc))))
+
(format port " ~a>"
(number->string (object-address gexp) 16)))
((? derivation? drv)
(derivation->output-path drv output))
((? string? file)
- file)))
+ file)
+ ((? self-quoting? obj)
+ obj)))
(define (register-compiler! compiler)
"Register COMPILER as a gexp compiler."
(define* (lower-object obj
#:optional (system (%current-system))
- #:key target)
+ #:key (target 'current))
"Return as a value in %STORE-MONAD the derivation or store item
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
OBJ must be an object that has an associated gexp compiler, such as a
<package>."
- (match (lookup-compiler obj)
- (#f
- (raise (condition (&gexp-input-error (input obj)))))
- (lower
- ;; 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?)))))
+ (mlet %store-monad ((target (if (eq? target 'current)
+ (current-target-system)
+ (return target)))
+ (graft? (grafting?)))
+ (let loop ((obj obj))
+ (match (lookup-compiler obj)
+ (#f
+ (raise (condition (&gexp-input-error (input obj)))))
+ (lower
+ ;; Cache in STORE the result of lowering OBJ.
+ (mcached (mlet %store-monad ((lowered (lower obj system target)))
+ (if (and (struct? lowered)
+ (not (derivation? lowered)))
+ (loop lowered)
+ (return lowered)))
+ obj
+ system target graft?))))))
+
+(define* (lower+expand-object obj
+ #:optional (system (%current-system))
+ #:key target (output "out"))
+ "Return as a value in %STORE-MONAD the output of object OBJ expands to for
+SYSTEM and TARGET. Object such as <package>, <file-append>, or <plain-file>
+expand to file names, but it's possible to expand to a plain data type."
+ (let loop ((obj obj)
+ (expand (and (struct? obj) (lookup-expander obj))))
+ (match (lookup-compiler obj)
+ (#f
+ (raise (condition (&gexp-input-error (input obj)))))
+ (lower
+ (mlet* %store-monad ((graft? (grafting?))
+ (lowered (mcached (lower obj system target)
+ obj
+ system target graft?)))
+ ;; LOWER might return something that needs to be further
+ ;; lowered.
+ (if (struct? lowered)
+ ;; If we lack an expander, delegate to that of LOWERED.
+ (if (not expand)
+ (loop lowered (lookup-expander lowered))
+ (return (expand obj lowered output)))
+ (if (not expand) ;self-quoting
+ (return lowered)
+ (return (expand obj lowered output)))))))))
(define-syntax define-gexp-compiler
(syntax-rules (=> compiler expander)
"Define NAME as a compiler for objects matching PREDICATE encountered in
gexps.
-In the simplest form of the macro, BODY must return a derivation for PARAM, an
-object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
-#f except when cross-compiling.)
+In the simplest form of the macro, BODY must return (1) a derivation for
+a record of the specified type, for SYSTEM and TARGET (the latter of which is
+#f except when cross-compiling), (2) another record that can itself be
+compiled down to a derivation, or (3) an object of a primitive data type.
The more elaborate form allows you to specify an expander:
- (define-gexp-compiler something something?
+ (define-gexp-compiler something-compiler <something>
compiler => (lambda (param system target) ...)
expander => (lambda (param drv output) ...))
(with-monad %store-monad
(return drv)))
+;; Expand to a raw ".drv" file for the lowerable object it wraps. In other
+;; words, this gives the raw ".drv" file instead of its build result.
+(define-record-type <raw-derivation-file>
+ (raw-derivation-file obj)
+ raw-derivation-file?
+ (obj raw-derivation-file-object)) ;lowerable object
+
+(define-gexp-compiler raw-derivation-file-compiler <raw-derivation-file>
+ compiler => (lambda (obj system target)
+ (mlet %store-monad ((obj (lower-object
+ (raw-derivation-file-object obj)
+ system #:target target)))
+ ;; Returning the .drv file name instead of the <derivation>
+ ;; record ensures that 'lower-gexp' will classify it as a
+ ;; "source" and not as an "input".
+ (return (if (derivation? obj)
+ (derivation-file-name obj)
+ obj))))
+ expander => (lambda (obj lowered output)
+ (if (derivation? lowered)
+ (derivation-file-name lowered)
+ lowered)))
+
+\f
+;;;
+;;; System dependencies.
+;;;
+
+;; Binding form for the current system and cross-compilation target.
+(define-record-type <system-binding>
+ (system-binding proc)
+ system-binding?
+ (proc system-binding-proc))
+
+(define-syntax let-system
+ (syntax-rules ()
+ "Introduce a system binding in a gexp. The simplest form is:
+
+ (let-system system
+ (cond ((string=? system \"x86_64-linux\") ...)
+ (else ...)))
+
+which binds SYSTEM to the currently targeted system. The second form is
+similar, but it also shows the cross-compilation target:
+
+ (let-system (system target)
+ ...)
+
+Here TARGET is bound to the cross-compilation triplet or #f."
+ ((_ (system target) exp0 exp ...)
+ (system-binding (lambda (system target)
+ exp0 exp ...)))
+ ((_ system exp0 exp ...)
+ (system-binding (lambda (system target)
+ exp0 exp ...)))))
+
+(define-gexp-compiler system-binding-compiler <system-binding>
+ compiler => (lambda (binding system target)
+ (match binding
+ (($ <system-binding> proc)
+ (with-monad %store-monad
+ ;; PROC is expected to return a lowerable object.
+ ;; 'lower-object' takes care of residualizing it to a
+ ;; derivation or similar.
+ (return (proc system target))))))
+
+ ;; Delegate to the expander of the object returned by PROC.
+ expander => #f)
+
\f
;;;
;;; File declarations.
(define (true file stat) #t)
(define* (%local-file file promise #:optional (name (basename file))
- #:key recursive? (select? true))
+ #:key
+ (literal? #t) location
+ recursive? (select? true))
;; This intermediate procedure is part of our ABI, but the underlying
;; %%LOCAL-FILE is not.
+ (when (and (not literal?) (not (string-prefix? "/" file)))
+ (warning (and=> location source-properties->location)
+ (G_ "resolving '~a' relative to current directory~%")
+ file))
(%%local-file file promise name recursive? select?))
(define (absolute-file-name file directory)
(string-append directory "/" file))
(else file))))
+(define-syntax-rule (assume-valid-file-name file)
+ "This is a syntactic keyword to tell 'local-file' that it can assume that
+the given file name is valid, even if it's not a string literal, and thus not
+warn about it."
+ file)
+
(define-syntax local-file
(lambda (s)
"Return an object representing local file FILE to add to the store; this
This is the declarative counterpart of the 'interned-file' monadic procedure.
It is implemented as a macro to capture the current source directory where it
appears."
- (syntax-case s ()
+ (syntax-case s (assume-valid-file-name)
((_ file rest ...)
+ (string? (syntax->datum #'file))
+ ;; FILE is a literal, so resolve it relative to the source directory.
#'(%local-file file
(delay (absolute-file-name file (current-source-directory)))
rest ...))
+ ((_ (assume-valid-file-name file) rest ...)
+ ;; FILE is not a literal, so resolve it relative to the current
+ ;; directory. Since the user declared FILE is valid, do not pass
+ ;; #:literal? #f so that we do not warn about it later on.
+ #'(%local-file file
+ (delay (absolute-file-name file (getcwd)))
+ rest ...))
+ ((_ file rest ...)
+ ;; Resolve FILE relative to the current directory.
+ (with-syntax ((location (datum->syntax s (syntax-source s))))
+ #`(%local-file file
+ (delay (absolute-file-name file (getcwd)))
+ rest ...
+ #:location 'location
+ #:literal? #f))) ;warn if FILE is relative
((_)
#'(syntax-error "missing file name"))
(id
(options computed-file-options)) ;list of arguments
(define* (computed-file name gexp
- #:key guile (options '(#:local-build? #t)))
+ #:key guile (local-build? #t) (options '()))
"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'.
+computed by GEXP. When LOCAL-BUILD? is #t (the default), it ensures the
+corresponding derivation is built locally. OPTIONS may be used to pass
+additional arguments to 'gexp->derivation'.
This is the declarative counterpart of 'gexp->derivation'."
- (%computed-file name gexp guile options))
+ (let ((options* `(#:local-build? ,local-build? ,@options)))
+ (%computed-file name gexp guile options*)))
(define-gexp-compiler (computed-file-compiler (file <computed-file>)
system target)
#:target target))))
(define-record-type <scheme-file>
- (%scheme-file name gexp splice?)
+ (%scheme-file name gexp splice? load-path?)
scheme-file?
(name scheme-file-name) ;string
(gexp scheme-file-gexp) ;gexp
- (splice? scheme-file-splice?)) ;Boolean
+ (splice? scheme-file-splice?) ;Boolean
+ (load-path? scheme-file-set-load-path?)) ;Boolean
-(define* (scheme-file name gexp #:key splice?)
+(define* (scheme-file name gexp #:key splice? (set-load-path? #t))
"Return an object representing the Scheme file NAME that contains GEXP.
This is the declarative counterpart of 'gexp->file'."
- (%scheme-file name gexp splice?))
+ (%scheme-file name gexp splice? set-load-path?))
(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 splice?)
- (gexp->file name gexp #:splice? splice?))))
+ (($ <scheme-file> name gexp splice? set-load-path?)
+ (gexp->file name gexp
+ #:set-load-path? set-load-path?
+ #:splice? splice?
+ #:system system
+ #:target target))))
;; Appending SUFFIX to BASE's output file name.
(define-record-type <file-append>
(base (expand base lowered output)))
(string-append base (string-concatenate suffix)))))))
+;; Representation of SRFI-39 parameter settings in the dynamic scope of an
+;; object lowering.
+(define-record-type <parameterized>
+ (parameterized bindings thunk)
+ parameterized?
+ (bindings parameterized-bindings) ;list of parameter/value pairs
+ (thunk parameterized-thunk)) ;thunk
+
+(define-syntax-rule (with-parameters ((param value) ...) body ...)
+ "Bind each PARAM to the corresponding VALUE for the extent during which BODY
+is lowered. Consider this example:
+
+ (with-parameters ((%current-system \"x86_64-linux\"))
+ coreutils)
+
+It returns a <parameterized> object that ensures %CURRENT-SYSTEM is set to
+x86_64-linux when COREUTILS is lowered."
+ (parameterized (list (list param (lambda () value)) ...)
+ (lambda ()
+ body ...)))
+
+(define-gexp-compiler compile-parameterized <parameterized>
+ compiler =>
+ (lambda (parameterized system target)
+ (match (parameterized-bindings parameterized)
+ (((parameters values) ...)
+ (let ((fluids (map parameter-fluid parameters))
+ (thunk (parameterized-thunk parameterized)))
+ ;; Install the PARAMETERS for the dynamic extent of THUNK.
+ (with-fluids* fluids
+ (map (lambda (thunk) (thunk)) values)
+ (lambda ()
+ ;; Special-case '%current-system' and '%current-target-system' to
+ ;; make sure we get the desired effect.
+ (let ((system (if (memq %current-system parameters)
+ (%current-system)
+ system))
+ (target (if (memq %current-target-system parameters)
+ (%current-target-system)
+ target)))
+ (lower-object (thunk) system #:target target))))))))
+
+ expander => (lambda (parameterized lowered output)
+ (match (parameterized-bindings parameterized)
+ (((parameters values) ...)
+ (let ((fluids (map parameter-fluid parameters))
+ (thunk (parameterized-thunk parameterized)))
+ ;; Install the PARAMETERS for the dynamic extent of THUNK.
+ (with-fluids* fluids
+ (map (lambda (thunk) (thunk)) values)
+ (lambda ()
+ ;; Delegate to the expander of the wrapped object.
+ (let* ((base (thunk))
+ (expand (lookup-expander base)))
+ (expand base lowered output)))))))))
+
\f
;;;
;;; Inputs & outputs.
(set-record-type-printer! <gexp-output> write-gexp-output)
-(define* (gexp-attribute gexp self-attribute #:optional (equal? equal?))
+(define* (gexp-attribute gexp self-attribute #:optional (equal? equal?)
+ #:key (validate (const #t)))
"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'."
+second argument to 'delete-duplicates'. Pass VALIDATE every gexp and
+attribute that is traversed."
(if (gexp? gexp)
(delete-duplicates
- (append (self-attribute gexp)
+ (append (let ((attribute (self-attribute gexp)))
+ (validate gexp attribute)
+ attribute)
(append-map (match-lambda
(($ <gexp-input> (? gexp? exp))
- (gexp-attribute exp self-attribute))
+ (gexp-attribute exp self-attribute
+ #:validate validate))
(($ <gexp-input> (lst ...))
(append-map (lambda (item)
- (if (gexp? item)
- (gexp-attribute item
- self-attribute)
- '()))
+ (gexp-attribute item self-attribute
+ #:validate
+ validate))
lst))
(_
'()))
(_
(equal? m1 m2))))
- (gexp-attribute gexp gexp-self-modules module=?))
+ (define (validate-modules gexp modules)
+ ;; Warn if MODULES, imported by GEXP, contains modules that in general
+ ;; should not be imported from the host because they vary from user to
+ ;; user and may thus be a source of non-reproducibility. This includes
+ ;; (guix config) as well as modules that come with Guile.
+ (match (filter (match-lambda
+ ((or ('guix 'config) ('ice-9 . _)) #t)
+ (_ #f))
+ modules)
+ (() #t)
+ (suspects
+ (warning (gexp-location gexp)
+ (N_ "importing module~{ ~a~} from the host~%"
+ "importing modules~{ ~a~} from the host~%"
+ (length suspects))
+ suspects))))
+
+ (gexp-attribute gexp gexp-self-modules module=?
+ #:validate validate-modules))
(define (gexp-extensions gexp)
"Return the list of Guile extensions (packages) GEXP relies on. If (gexp?
list."
(gexp-attribute gexp gexp-self-extensions))
+(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? char?)))
+
(define* (lower-inputs inputs
#:key system target)
"Turn any object from INPUTS into a derivation input for SYSTEM or a store
(define (store-item? obj)
(and (string? obj) (store-path? obj)))
+ (define filterm
+ (lift1 (cut filter ->bool <>) %store-monad))
+
(with-monad %store-monad
- (mapm %store-monad
+ (>>= (mapm/accumulate-builds
(match-lambda
(((? struct? thing) sub-drv ...)
(mlet %store-monad ((obj (lower-object
sub-drv)))
(derivation-input drv outputs)))
((? store-item? item)
- item)))))
+ item)
+ ((? self-quoting?)
+ ;; Some inputs such as <system-binding> can lower to
+ ;; a self-quoting object that FILTERM will filter
+ ;; out.
+ #f)))))
(((? store-item? item))
(return item)))
- inputs)))
+ inputs)
+ filterm)))
(define* (lower-reference-graphs graphs #:key system target)
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
#:target target)))
(return (derivation->output-path drv))))))
- (mapm %store-monad lower lst)))
+ (mapm/accumulate-builds lower lst)))
(define default-guile-derivation
;; Here we break the abstraction by talking to the higher-level layer.
(target 'current)
(graft? (%graft?))
(guile-for-build (%guile-for-build))
- (effective-version "2.2")
+ (effective-version "3.0")
deprecation-warnings)
"*Note: This API is subject to change; use at your own risk!*
(extensions -> (gexp-extensions exp))
(exts (mapm %store-monad
(lambda (obj)
- (lower-object obj system))
+ (lower-object obj system
+ #:target #f))
extensions))
(modules+compiled (imported+compiled-modules
%modules system
(modules '())
(module-path %load-path)
(guile-for-build (%guile-for-build))
- (effective-version "2.2")
+ (effective-version "3.0")
(graft? (%graft?))
references-graphs
allowed-references disallowed-references
(make-gexp (gexp-references exp)
(append modules (gexp-self-modules exp))
(gexp-self-extensions exp)
- (gexp-proc exp))))
+ (gexp-proc exp)
+ (gexp-location exp))))
(mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>=
(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
(or n? native?)))
refs))
(($ <gexp-input> (? struct? thing) output n?)
- (let ((target (if (or n? native?) #f target))
- (expand (lookup-expander thing)))
- (mlet %store-monad ((obj (lower-object thing system
- #:target target)))
- ;; OBJ must be either a derivation or a store file name.
- (return (expand thing obj output)))))
+ (let ((target (if (or n? native?) #f target)))
+ (lower+expand-object thing system
+ #:target target
+ #:output output)))
(($ <gexp-input> (? self-quoting? x))
(return x))
(($ <gexp-input> x)
current-imported-modules
current-imported-extensions
(lambda #,formals
- #,sexp)))))))
+ #,sexp)
+ (current-source-location)))))))
\f
;;;
;;; 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
#:system system
#:guile-for-build guile
#:local-build? #t
+ #:substitutable? #f
;; Avoid deprecation warnings about the use of the _IO*
;; constants in (guix build utils).
(guile (%guile-for-build))
(module-path %load-path)
(extensions '())
- (deprecation-warnings #f))
+ (deprecation-warnings #f)
+ (optimization-level 1))
"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. When TARGET is true, cross-compile MODULES for
(ice-9 format)
(srfi srfi-1)
(srfi srfi-26)
+ (system base target)
(system base compile))
- ;; TODO: Inline this on the next rebuild cycle.
- (ungexp-splicing
- (if target
- (gexp ((use-modules (system base target))))
- (gexp ())))
+ (define optimizations-for-level
+ (or (and=> (false-if-exception
+ (resolve-interface '(system base optimize)))
+ (lambda (iface)
+ (module-ref iface 'optimizations-for-level))) ;Guile 3.0
+ (const '())))
(define (regular? file)
(not (member file '("." ".."))))
(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)))))
+ (with-target (ungexp (or target (gexp %host-type)))
+ (lambda ()
+ (compile-file entry
+ #:output-file output
+ #:opts
+ `(,@%auto-compilation-options
+ ,@(optimizations-for-level
+ (ungexp optimization-level))))))
(+ 1 processed))))
;;;
(define (default-guile)
- ;; Lazily resolve 'guile-2.2' (not 'guile-final' because this is for
+ ;; Lazily resolve 'guile-3.0' (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 guile))
- 'guile-2.2))
+ 'guile-3.0))
(define* (load-path-expression modules #:optional (path %load-path)
#:key (extensions '()) system target)
#:key (guile (default-guile))
(module-path %load-path)
(system (%current-system))
- target)
+ (target 'current))
"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)
- #:system system
- #:target target)))
+ (mlet* %store-monad ((target (if (eq? target 'current)
+ (current-target-system)
+ (return target)))
+ (set-load-path
+ (load-path-expression (gexp-modules exp)
+ module-path
+ #:extensions
+ (gexp-extensions exp)
+ #:system system
+ #:target target)))
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
(chmod port #o555))))
#:system system
#:target target
- #:module-path module-path)))
+ #:module-path module-path
+
+ ;; These derivations are not worth offloading or
+ ;; substituting.
+ #:local-build? #t
+ #:substitutable? #f)))
(define* (gexp->file name exp #:key
(set-load-path? #t)
(module-path %load-path)
- (splice? #f))
+ (splice? #f)
+ (system (%current-system))
+ (target 'current))
"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.
(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)))
+ (mlet* %store-monad
+ ((target (if (eq? target 'current)
+ (current-target-system)
+ (return target)))
+ (no-load-path? -> (or (not set-load-path?)
+ (and (null? modules)
+ (null? extensions))))
+ (set-load-path
+ (load-path-expression modules module-path
+ #:extensions extensions
+ #:system system
+ #:target target)))
+ (if no-load-path?
+ (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
+ #:system system
+ #:target target)
(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)))))))))
+ (for-each
+ (lambda (exp)
+ (write exp port))
+ '(ungexp (if splice?
+ exp
+ (gexp ((ungexp exp)))))))))
#:module-path module-path
#:local-build? #t
- #:substitutable? #f))))
+ #:substitutable? #f
+ #:system system
+ #:target target))))
(define* (text-file* name #:rest text)
"Return as a monadic value a derivation that builds a text file containing
HCoop / jackhill / guix / guix.git / blobdiff