diff options
| -rw-r--r-- | doc/guix.texi | 35 | ||||
| -rw-r--r-- | guix/gexp.scm | 29 | ||||
| -rw-r--r-- | tests/gexp.scm | 53 |
3 files changed, 113 insertions, 4 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 3923627c79..6d3361878b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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: @example -#~(system* (string-append #$glibc "/sbin/nscd") "-f" +#~(system* #$(file-append glibc "/sbin/nscd") "-f" #$(local-file "/tmp/my-nscd.conf")) @end example @@ -4044,7 +4044,7 @@ command: (use-modules (guix gexp) (gnu packages base)) (gexp->script "list-files" - #~(execl (string-append #$coreutils "/bin/ls") + #~(execl #$(file-append coreutils "/bin/ls") "ls")) @end example @@ -4055,8 +4055,7 @@ executable file @file{/gnu/store/@dots{}-list-files} along these lines: @example #!/gnu/store/@dots{}-guile-2.0.11/bin/guile -ds !# -(execl (string-append "/gnu/store/@dots{}-coreutils-8.22"/bin/ls") - "ls") +(execl "/gnu/store/@dots{}-coreutils-8.22"/bin/ls" "ls") @end example @end deffn @@ -4126,6 +4125,34 @@ as in: This is the declarative counterpart of @code{text-file*}. @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 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 diff --git a/guix/gexp.scm b/guix/gexp.scm index 8d380ec95b..7e2ecf6c33 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -63,6 +63,11 @@ scheme-file-name scheme-file-gexp + file-append + file-append? + file-append-base + file-append-suffix + gexp->derivation gexp->file gexp->script @@ -368,6 +373,30 @@ This is the declarative counterpart of 'gexp->file'." (($ <scheme-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. diff --git a/tests/gexp.scm b/tests/gexp.scm index 03a64fa6bb..214e7a5302 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -207,6 +207,47 @@ (e3 `(display ,txt))) (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" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) (ungexp coreutils) @@ -338,6 +379,18 @@ (return (and (equal? sexp (call-with-input-file out read)) (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" (mlet* %store-monad ((file (text-file "foo" "Hello, world!")) (exp -> (gexp |