08/12: gexp: Add 'scheme-file'.

[Ludovic Courtès]

civodul pushed a commit to branch wip-service-refactor
in repository guix.

commit 8f83cf0327eb83adcaf0ecb4f078c88e790f24cd
Author: Ludovic Courtès <address@hidden>
Date:   Wed Sep 16 15:03:52 2015 +0200

    gexp: Add 'scheme-file'.
    
    * guix/gexp.scm (<scheme-file>): New record type.
      (scheme-file, scheme-file-compiler): New procedures.
    * tests/gexp.scm ("scheme-file"): New test.
    * doc/guix.texi (G-Expressions): Document 'scheme-file'.
---
 doc/guix.texi  |   15 +++++++++++----
 guix/gexp.scm  |   24 ++++++++++++++++++++++++
 tests/gexp.scm |   13 +++++++++++++
 3 files changed, 48 insertions(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 591c440..80c8d87 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3345,10 +3345,10 @@ The other arguments are as for @code{derivation} 
(@pxref{Derivations}).
 @end deffn
 
 @cindex file-like objects
-The @code{local-file}, @code{plain-file}, @code{computed-file}, and
address@hidden procedures below return @dfn{file-like objects}.
-That is, when unquoted in a G-expression, these objects lead to a file
-in the store.  Consider this G-expression:
+The @code{local-file}, @code{plain-file}, @code{computed-file},
address@hidden, and @code{scheme-file} procedures below return
address@hidden objects}.  That is, when unquoted in a G-expression,
+these objects lead to a file in the store.  Consider this G-expression:
 
 @example
 #~(system* (string-append #$glibc "/sbin/nscd") "-f"
@@ -3437,6 +3437,13 @@ The resulting file holds references to all the 
dependencies of @var{exp}
 or a subset thereof.
 @end deffn
 
address@hidden {Scheme Procedure} scheme-file @var{name} @var{exp}
+Return an object representing the Scheme file @var{name} that contains
address@hidden
+
+This is the declarative counterpart of @code{gexp->file}.
address@hidden deffn
+
 @deffn {Monadic Procedure} text-file* @var{name} @var{text} @dots{}
 Return as a monadic value a derivation that builds a text file
 containing all of @var{text}.  @var{text} may list, in addition to
diff --git a/guix/gexp.scm b/guix/gexp.scm
index f44df9c..27bccc6 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -57,6 +57,11 @@
             program-file-modules
             program-file-guile
 
+            scheme-file
+            scheme-file?
+            scheme-file-name
+            scheme-file-gexp
+
             gexp->derivation
             gexp->file
             gexp->script
@@ -281,6 +286,25 @@ This is the declarative counterpart of 'gexp->script'."
                    #:modules modules
                    #:guile (or guile (default-guile))))))
 
+(define-record-type <scheme-file>
+  (%scheme-file name gexp)
+  scheme-file?
+  (name       scheme-file-name)                  ;string
+  (gexp       scheme-file-gexp))                 ;gexp
+
+(define* (scheme-file name gexp)
+  "Return an object representing the Scheme file NAME that contains GEXP.
+
+This is the declarative counterpart of 'gexp->file'."
+  (%scheme-file name gexp))
+
+(define-gexp-compiler (scheme-file-compiler (file scheme-file?)
+                                            system target)
+  ;; Compile FILE by returning a derivation that builds the file.
+  (match file
+    (($ <scheme-file> name gexp)
+     (gexp->file name gexp))))
+
 
 ;;;
 ;;; Inputs & outputs.
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 77439cf..4860a8e 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -636,6 +636,19 @@
           (return (and (zero? (close-pipe pipe))
                        (= n (string->number str)))))))))
 
+(test-assertm "scheme-file"
+  (let* ((text   (plain-file "foo" "Hello, world!"))
+         (scheme (scheme-file "bar" #~(list "foo" #$text))))
+    (mlet* %store-monad ((drv  (lower-object scheme))
+                         (text (lower-object text))
+                         (out -> (derivation->output-path drv)))
+      (mbegin %store-monad
+        (built-derivations (list drv))
+        (mlet %store-monad ((refs ((store-lift references) out)))
+          (return (and (equal? refs (list text))
+                       (equal? `(list "foo" ,text)
+                               (call-with-input-file out read)))))))))
+
 (test-assert "text-file*"
   (let ((references (store-lift references)))
     (run-with-store %store