;;; 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?
gexp-input-output
gexp-input-native?
+ assume-valid-file-name
local-file
local-file?
local-file-file
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)))
(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)
(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?
(one-of symbol? string? keyword? pair? null? array?
number? boolean? char?)))
-(define* (lower-inputs inputs
- #:key system target)
+(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."
(with-monad %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)
((? 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)))
+ #f))))))
inputs)
filterm)))
"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)
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)
(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)
(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* (reference->sexp ref #:optional native?)
(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)))
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
;;;
#: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).
;; TODO: Pass MODULES as an environment variable.
(gexp->derivation name build
#:system system
+ #:target target
#:guile-for-build guile
#:local-build? #t
#:env-vars
HCoop / jackhill / guix / guix.git / blobdiff