gexp: Add 'file-append'.
* guix/gexp.scm (<file-append>): New record type. (file-append): New procedure. (file-append-compiler): New gexp compiler. * tests/gexp.scm ("file-append", "file-append, output") ("file-append, nested", "gexp->file + file-append"): New tests. * doc/guix.texi (G-Expressions): Use it in 'nscd' and 'list-files' examples. Document 'file-append'.
This commit is contained in:
parent
ebdfd776f4
commit
a9e5e92f94
|
@ -3985,7 +3985,7 @@ The @code{local-file}, @code{plain-file}, @code{computed-file},
|
||||||
these objects lead to a file in the store. Consider this G-expression:
|
these objects lead to a file in the store. Consider this G-expression:
|
||||||
|
|
||||||
@example
|
@example
|
||||||
#~(system* (string-append #$glibc "/sbin/nscd") "-f"
|
#~(system* #$(file-append glibc "/sbin/nscd") "-f"
|
||||||
#$(local-file "/tmp/my-nscd.conf"))
|
#$(local-file "/tmp/my-nscd.conf"))
|
||||||
@end example
|
@end example
|
||||||
|
|
||||||
|
@ -4044,7 +4044,7 @@ command:
|
||||||
(use-modules (guix gexp) (gnu packages base))
|
(use-modules (guix gexp) (gnu packages base))
|
||||||
|
|
||||||
(gexp->script "list-files"
|
(gexp->script "list-files"
|
||||||
#~(execl (string-append #$coreutils "/bin/ls")
|
#~(execl #$(file-append coreutils "/bin/ls")
|
||||||
"ls"))
|
"ls"))
|
||||||
@end example
|
@end example
|
||||||
|
|
||||||
|
@ -4055,8 +4055,7 @@ executable file @file{/gnu/store/@dots{}-list-files} along these lines:
|
||||||
@example
|
@example
|
||||||
#!/gnu/store/@dots{}-guile-2.0.11/bin/guile -ds
|
#!/gnu/store/@dots{}-guile-2.0.11/bin/guile -ds
|
||||||
!#
|
!#
|
||||||
(execl (string-append "/gnu/store/@dots{}-coreutils-8.22"/bin/ls")
|
(execl "/gnu/store/@dots{}-coreutils-8.22"/bin/ls" "ls")
|
||||||
"ls")
|
|
||||||
@end example
|
@end example
|
||||||
@end deffn
|
@end deffn
|
||||||
|
|
||||||
|
@ -4126,6 +4125,34 @@ as in:
|
||||||
This is the declarative counterpart of @code{text-file*}.
|
This is the declarative counterpart of @code{text-file*}.
|
||||||
@end deffn
|
@end deffn
|
||||||
|
|
||||||
|
@deffn {Scheme Procedure} file-append @var{obj} @var{suffix} @dots{}
|
||||||
|
Return a file-like object that expands to the concatenation of @var{obj}
|
||||||
|
and @var{suffix}, where @var{obj} is a lowerable object and each
|
||||||
|
@var{suffix} is a string.
|
||||||
|
|
||||||
|
As an example, consider this gexp:
|
||||||
|
|
||||||
|
@example
|
||||||
|
(gexp->script "run-uname"
|
||||||
|
#~(system* #$(file-append coreutils
|
||||||
|
"/bin/uname")))
|
||||||
|
@end example
|
||||||
|
|
||||||
|
The same effect could be achieved with:
|
||||||
|
|
||||||
|
@example
|
||||||
|
(gexp->script "run-uname"
|
||||||
|
#~(system* (string-append #$coreutils
|
||||||
|
"/bin/uname")))
|
||||||
|
@end example
|
||||||
|
|
||||||
|
There is one difference though: in the @code{file-append} case, the
|
||||||
|
resulting script contains the absolute file name as a string, whereas in
|
||||||
|
the second case, the resulting script contains a @code{(string-append
|
||||||
|
@dots{})} expression to construct the file name @emph{at run time}.
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
|
||||||
Of course, in addition to gexps embedded in ``host'' code, there are
|
Of course, in addition to gexps embedded in ``host'' code, there are
|
||||||
also modules containing build tools. To make it clear that they are
|
also modules containing build tools. To make it clear that they are
|
||||||
meant to be used in the build stratum, these modules are kept in the
|
meant to be used in the build stratum, these modules are kept in the
|
||||||
|
|
|
@ -63,6 +63,11 @@
|
||||||
scheme-file-name
|
scheme-file-name
|
||||||
scheme-file-gexp
|
scheme-file-gexp
|
||||||
|
|
||||||
|
file-append
|
||||||
|
file-append?
|
||||||
|
file-append-base
|
||||||
|
file-append-suffix
|
||||||
|
|
||||||
gexp->derivation
|
gexp->derivation
|
||||||
gexp->file
|
gexp->file
|
||||||
gexp->script
|
gexp->script
|
||||||
|
@ -368,6 +373,30 @@ This is the declarative counterpart of 'gexp->file'."
|
||||||
(($ <scheme-file> name gexp)
|
(($ <scheme-file> name gexp)
|
||||||
(gexp->file name gexp))))
|
(gexp->file name gexp))))
|
||||||
|
|
||||||
|
;; Appending SUFFIX to BASE's output file name.
|
||||||
|
(define-record-type <file-append>
|
||||||
|
(%file-append base suffix)
|
||||||
|
file-append?
|
||||||
|
(base file-append-base) ;<package> | <derivation> | ...
|
||||||
|
(suffix file-append-suffix)) ;list of strings
|
||||||
|
|
||||||
|
(define (file-append base . suffix)
|
||||||
|
"Return a <file-append> object that expands to the concatenation of BASE and
|
||||||
|
SUFFIX."
|
||||||
|
(%file-append base suffix))
|
||||||
|
|
||||||
|
(define-gexp-compiler file-append-compiler file-append?
|
||||||
|
compiler => (lambda (obj system target)
|
||||||
|
(match obj
|
||||||
|
(($ <file-append> base _)
|
||||||
|
(lower-object base system #:target target))))
|
||||||
|
expander => (lambda (obj lowered output)
|
||||||
|
(match obj
|
||||||
|
(($ <file-append> base suffix)
|
||||||
|
(let* ((expand (lookup-expander base))
|
||||||
|
(base (expand base lowered output)))
|
||||||
|
(string-append base (string-concatenate suffix)))))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Inputs & outputs.
|
;;; Inputs & outputs.
|
||||||
|
|
|
@ -207,6 +207,47 @@
|
||||||
(e3 `(display ,txt)))
|
(e3 `(display ,txt)))
|
||||||
(equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
|
(equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
|
||||||
|
|
||||||
|
(test-assert "file-append"
|
||||||
|
(let* ((drv (package-derivation %store %bootstrap-guile))
|
||||||
|
(fa (file-append %bootstrap-guile "/bin/guile"))
|
||||||
|
(exp #~(here we go #$fa)))
|
||||||
|
(and (match (gexp->sexp* exp)
|
||||||
|
(('here 'we 'go (? string? result))
|
||||||
|
(string=? result
|
||||||
|
(string-append (derivation->output-path drv)
|
||||||
|
"/bin/guile"))))
|
||||||
|
(match (gexp-inputs exp)
|
||||||
|
(((thing "out"))
|
||||||
|
(eq? thing fa))))))
|
||||||
|
|
||||||
|
(test-assert "file-append, output"
|
||||||
|
(let* ((drv (package-derivation %store glibc))
|
||||||
|
(fa (file-append glibc "/lib" "/debug"))
|
||||||
|
(exp #~(foo #$fa:debug)))
|
||||||
|
(and (match (gexp->sexp* exp)
|
||||||
|
(('foo (? string? result))
|
||||||
|
(string=? result
|
||||||
|
(string-append (derivation->output-path drv "debug")
|
||||||
|
"/lib/debug"))))
|
||||||
|
(match (gexp-inputs exp)
|
||||||
|
(((thing "debug"))
|
||||||
|
(eq? thing fa))))))
|
||||||
|
|
||||||
|
(test-assert "file-append, nested"
|
||||||
|
(let* ((drv (package-derivation %store glibc))
|
||||||
|
(dir (file-append glibc "/bin"))
|
||||||
|
(slash (file-append dir "/"))
|
||||||
|
(file (file-append slash "getent"))
|
||||||
|
(exp #~(foo #$file)))
|
||||||
|
(and (match (gexp->sexp* exp)
|
||||||
|
(('foo (? string? result))
|
||||||
|
(string=? result
|
||||||
|
(string-append (derivation->output-path drv)
|
||||||
|
"/bin/getent"))))
|
||||||
|
(match (gexp-inputs exp)
|
||||||
|
(((thing "out"))
|
||||||
|
(eq? thing file))))))
|
||||||
|
|
||||||
(test-assert "ungexp + ungexp-native"
|
(test-assert "ungexp + ungexp-native"
|
||||||
(let* ((exp (gexp (list (ungexp-native %bootstrap-guile)
|
(let* ((exp (gexp (list (ungexp-native %bootstrap-guile)
|
||||||
(ungexp coreutils)
|
(ungexp coreutils)
|
||||||
|
@ -338,6 +379,18 @@
|
||||||
(return (and (equal? sexp (call-with-input-file out read))
|
(return (and (equal? sexp (call-with-input-file out read))
|
||||||
(equal? (list guile) refs)))))
|
(equal? (list guile) refs)))))
|
||||||
|
|
||||||
|
(test-assertm "gexp->file + file-append"
|
||||||
|
(mlet* %store-monad ((exp -> #~#$(file-append %bootstrap-guile
|
||||||
|
"/bin/guile"))
|
||||||
|
(guile (package-file %bootstrap-guile))
|
||||||
|
(drv (gexp->file "foo" exp))
|
||||||
|
(out -> (derivation->output-path drv))
|
||||||
|
(done (built-derivations (list drv)))
|
||||||
|
(refs ((store-lift references) out)))
|
||||||
|
(return (and (equal? (string-append guile "/bin/guile")
|
||||||
|
(call-with-input-file out read))
|
||||||
|
(equal? (list guile) refs)))))
|
||||||
|
|
||||||
(test-assertm "gexp->derivation"
|
(test-assertm "gexp->derivation"
|
||||||
(mlet* %store-monad ((file (text-file "foo" "Hello, world!"))
|
(mlet* %store-monad ((file (text-file "foo" "Hello, world!"))
|
||||||
(exp -> (gexp
|
(exp -> (gexp
|
||||||
|
|
Loading…
Reference in New Issue