;;; 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* (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
+ (pre-load-modules? #t)) ;transitional
+ "*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 (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
+ #:pre-load-modules?
+ pre-load-modules?
+ #:deprecation-warnings
+ deprecation-warnings)
+ (return #f))))
+ (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 '())
+
+ ;; TODO: This parameter is transitional; it's here
+ ;; to avoid a full rebuild. Remove it on the next
+ ;; rebuild cycle.
+ (pre-load-modules? #t)
+
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
+ #:pre-load-modules?
+ pre-load-modules?))
+
(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
#: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)
#: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)))
(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)
(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 '()))
(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
(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))
+ (deprecation-warnings #f)
+
+ ;; TODO: This flag is here to prevent a full
+ ;; rebuild. Remove it on the next rebuild cycle.
+ (pre-load-modules? #t))
"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-splicing (if pre-load-modules?
+ (gexp ((ungexp total)))
+ (gexp ()))))
+ (ungexp (* total (if pre-load-modules? 2 1)))
+ 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)
(mkdir (ungexp output))
(chdir (ungexp modules))
+
+ (ungexp-splicing
+ (if pre-load-modules?
+ (gexp ((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)))
+
+ (load-from-directory ".")))
+ (gexp ())))
+
(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)
- (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)
- (string-append extension
- "/lib/guile/"
- (effective-version)
- "/site-ccache"))
- '((ungexp-native-splicing extensions)))
- %load-compiled-path))))))))
+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)
+ (set! %load-path
+ (cons (ungexp modules)
+ (append (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)
+ (string-append extension
+ "/lib/guile/"
+ (effective-version)
+ "/site-ccache"))
+ '((ungexp-native-splicing 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)
HCoop / jackhill / guix / guix.git / blobdiff