03/05: gexp: Add 'file-append'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit a9e5e92f940381e3a4ee828c6d8ff22a73067e17
Author: Ludovic Courtès <address@hidden>
Date:   Fri Sep 9 22:46:36 2016 +0200

    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'.
---
 doc/guix.texi  |   35 +++++++++++++++++++++++++++++++----
 guix/gexp.scm  |   29 +++++++++++++++++++++++++++++
 tests/gexp.scm |   53 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 113 insertions(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 3923627..6d33618 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
 
address@hidden {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
address@hidden is a string.
+
+As an example, consider this gexp:
+
address@hidden
+(gexp->script "run-uname"
+              #~(system* #$(file-append coreutils
+                                        "/bin/uname")))
address@hidden example
+
+The same effect could be achieved with:
+
address@hidden
+(gexp->script "run-uname"
+              #~(system* (string-append #$coreutils
+                                        "/bin/uname")))
address@hidden 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
address@hidden)} expression to construct the file name @emph{at run time}.
address@hidden 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 8d380ec..7e2ecf6 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 03a64fa..214e7a5 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