;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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?
raw-derivation-file
raw-derivation-file?
+ with-parameters
+ parameterized?
+
load-path-expression
gexp-modules
file-like?
lower-object
- lower-inputs
-
&gexp-error
gexp-error?
&gexp-input-error
;; "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."
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 ((target (if (eq? target 'current)
- (current-target-system)
- (return target)))
- (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) ...))
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 ...))
- ((_ file rest ...)
- ;; Resolve FILE relative to the current directory.
+ ((_ (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?)
+ (($ <scheme-file> name gexp splice? set-load-path?)
(gexp->file name gexp
+ #:set-load-path? set-load-path?
#:splice? splice?
#:system system
#:target target))))
(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-map (match-lambda
- (($ <gexp-input> (? gexp? exp))
- (gexp-attribute exp self-attribute))
- (($ <gexp-input> (lst ...))
- (append-map (lambda (item)
- (if (gexp? item)
- (gexp-attribute item
- self-attribute)
- '()))
- lst))
- (_
- '()))
- (gexp-references gexp)))
+ (append (let ((attribute (self-attribute gexp)))
+ (validate gexp attribute)
+ attribute)
+ (reverse
+ (fold (lambda (input result)
+ (match input
+ (($ <gexp-input> (? gexp? exp))
+ (append (gexp-attribute exp self-attribute
+ #:validate validate)
+ result))
+ (($ <gexp-input> (lst ...))
+ (fold/tree (lambda (obj result)
+ (match obj
+ ((? gexp? exp)
+ (append (gexp-attribute exp self-attribute
+ #:validate validate)
+ result))
+ (_
+ result)))
+ result
+ lst))
+ (_
+ result)))
+ '()
+ (gexp-references gexp))))
equal?)
'())) ;plain Scheme data type
(_
(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* (lower-inputs inputs
- #:key system target)
+(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 system target)
"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)))
+ (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
- thing system #:target target)))
+ (($ <gexp-input> (? store-item? item))
+ (return item))
+ (($ <gexp-input> thing output native?)
+ (mlet %store-monad ((obj (lower-object thing system
+ #:target
+ (and (not native?)
+ target))))
(return (match obj
((? derivation? drv)
- (let ((outputs (if (null? sub-drv)
- '("out")
- sub-drv)))
- (derivation-input drv outputs)))
+ (derivation-input drv (list output)))
((? store-item? item)
- item)))))
- (((? store-item? item))
- (return item)))
- inputs)))
+ item)
+ ((? self-quoting?)
+ ;; Some inputs such as <system-binding> can lower to
+ ;; a self-quoting object that FILTERM will filter
+ ;; out.
+ #f))))))
+ inputs)
+ filterm)))
(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-input> or store item."
+ (define tuple->gexp-input
+ (match-lambda
+ ((thing)
+ (%gexp-input thing "out" (not target)))
+ ((thing output)
+ (%gexp-input thing output (not target)))))
+
(match graphs
(((file-names . inputs) ...)
- (mlet %store-monad ((inputs (lower-inputs inputs
- #:system system
- #:target target)))
+ (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs)
+ system target)))
(return (map cons file-names inputs))))))
(define* (lower-references lst #:key system target)
#: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.
modules
system extensions guile deprecation-warnings module-path))
+(define (sexp->string sexp)
+ "Like 'object->string', but deterministic and slightly faster."
+ ;; Explicitly use UTF-8 for determinism, and also because UTF-8 output is
+ ;; faster.
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-output-string
+ (lambda (port)
+ (write sexp port)))))
+
(define* (lower-gexp exp
#:key
(module-path %load-path)
(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!*
(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))
+ (inputs (lower-inputs (gexp-inputs exp)
+ system target))
+ (sexp (gexp->sexp exp system target))
(extensions -> (gexp-extensions exp))
(exts (mapm %store-monad
(lambda (obj)
(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 >>=
(return #f)))
(guile -> (lowered-gexp-guile lowered))
(builder (text-file script-name
- (object->string
+ (sexp->string
(lowered-gexp-sexp lowered)))))
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
#: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 (fold/tree proc seed lst)
+ "Like 'fold', but recurse into sub-lists of LST and accept improper lists."
+ (let loop ((obj lst)
+ (result seed))
+ (match obj
+ ((head . tail)
+ (loop tail (loop head result)))
+ (_
+ (proc obj result)))))
+
+(define (gexp-inputs exp)
+ "Return the list of <gexp-input> for EXP."
+ (define set-gexp-input-native?
+ (match-lambda
+ (($ <gexp-input> thing output)
+ (%gexp-input thing output #t))))
+
+ (define (interesting? obj)
+ (or (file-like? obj)
+ (and (string? obj) (direct-store-path? obj))))
+
(define (add-reference-inputs ref result)
(match ref
(($ <gexp-input> (? gexp? exp) _ #t)
- (if native?
- (append (gexp-inputs exp)
- (gexp-inputs exp #:native? #t)
- result)
- result))
- (($ <gexp-input> (? gexp? exp) _ #f)
- (append (gexp-inputs exp #:native? native?)
+ (append (map set-gexp-input-native? (gexp-inputs exp))
result))
+ (($ <gexp-input> (? gexp? exp) _ #f)
+ (append (gexp-inputs exp) result))
(($ <gexp-input> (? string? str))
(if (direct-store-path? str)
- (cons `(,str) result)
+ (cons ref result)
result))
(($ <gexp-input> (? struct? thing) output n?)
- (if (and (eqv? n? native?) (lookup-compiler thing))
+ (if (lookup-compiler thing)
;; THING is a derivation, or a package, or an origin, etc.
- (cons `(,thing ,output) result)
+ (cons ref result)
result))
- (($ <gexp-input> (lst ...) output n?)
- (fold-right add-reference-inputs result
- ;; XXX: For now, automatically convert LST to a list of
- ;; gexp-inputs. Inherit N?.
- (map (match-lambda
- ((? gexp-input? x)
- (%gexp-input (gexp-input-thing x)
- (gexp-input-output x)
- n?))
- (x
- (%gexp-input x "out" n?)))
- lst)))
+ (($ <gexp-input> (? pair? lst) output n?)
+ ;; XXX: Scan LST for inputs. Inherit N?.
+ (fold/tree (lambda (obj result)
+ (match obj
+ ((? gexp-input? x)
+ (cons (%gexp-input (gexp-input-thing x)
+ (gexp-input-output x)
+ n?)
+ result))
+ ((? interesting? x)
+ (cons (%gexp-input x "out" n?) result))
+ ((? gexp? x)
+ (append (gexp-inputs x) result))
+ (_
+ result)))
+ result
+ lst))
(_
;; Ignore references to other kinds of objects.
result)))
'()
(gexp-references exp)))
-(define gexp-native-inputs
- (cut gexp-inputs <> #:native? #t))
-
(define (gexp-outputs exp)
"Return the outputs referred to by EXP as a list of strings."
(define (add-reference-output ref result)
(cons name result))
(($ <gexp-input> (? gexp? exp))
(append (gexp-outputs exp) result))
- (($ <gexp-input> (lst ...) output native?)
- ;; XXX: Automatically convert LST.
- (add-reference-output (map (match-lambda
- ((? gexp-input? x) x)
- (x (%gexp-input x "out" native?)))
- lst)
- result))
- ((lst ...)
- (fold-right add-reference-output result lst))
+ (($ <gexp-input> (? pair? lst))
+ ;; XXX: Scan LST for outputs.
+ (fold/tree (lambda (obj result)
+ (match obj
+ (($ <gexp-output> name) (cons name result))
+ ((? gexp? x) (append (gexp-outputs x) result))
+ (_ result)))
+ result
+ lst))
(_
result)))
(delete-duplicates
- (add-reference-output (gexp-references exp) '())))
+ (fold add-reference-output '() (gexp-references exp))))
-(define* (gexp->sexp exp #:key
- (system (%current-system))
- (target (%current-target-system)))
+(define (gexp->sexp exp system target)
"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? char?)))
-
(define* (reference->sexp ref #:optional native?)
(with-monad %store-monad
(match ref
(return `((@ (guile) getenv) ,output)))
(($ <gexp-input> (? gexp? exp) output n?)
(gexp->sexp exp
- #:system system
- #:target (if (or n? native?) #f target)))
+ system (if (or n? native?) #f target)))
(($ <gexp-input> (refs ...) output n?)
(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?)))
+ (if (or (symbol? ref) (number? ref)
+ (boolean? ref) (null? ref) (array? ref))
+ (return ref)
+ (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)))
- (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)
reference->sexp (gexp-references exp))))
(return (apply (gexp-proc exp) args))))
-(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
+(define-syntax-parameter current-imported-modules
;; Current list of imported modules.
(identifier-syntax '()))
(identifier-syntax modules)))
body ...))
-(define-syntax-parameter-once current-imported-extensions
+(define-syntax-parameter current-imported-extensions
;; Current list of extensions.
(identifier-syntax '()))
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).
(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 (regular? file)
(not (member file '("." ".."))))
;; TODO: Pass MODULES as an environment variable.
(gexp->derivation name build
#:system system
+ #:target target
#:guile-for-build guile
#:local-build? #t
#:env-vars
;;;
(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)