;;; 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
(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?)
(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
(mapm %store-monad
(match-lambda
(((? struct? thing) sub-drv ...)
- (mlet %store-monad ((drv (lower-object
+ (mlet %store-monad ((obj (lower-object
thing system #:target target)))
- (return `(,drv ,@sub-drv))))
- (input
- (return input)))
+ (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
(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)
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)
- (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" ,(if (derivation? modules)
- (derivation->output-path modules)
- 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
(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
#: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)))))
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 '()))
(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))
(mlet %store-monad ((modules (imported-modules modules
(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)))
(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