01/03: gexp: Add 'local-file'.

[Ludovic Courtès]

civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.

commit 46959ae58296406b96b0b05e45850cb72ab1d30f
Author: Ludovic Courtès <address@hidden>
Date:   Thu Mar 26 21:25:18 2015 +0100

    gexp: Add 'local-file'.
    
    * guix/gexp.scm (<local-file>): New record type.
      (local-file): New procedure.
      (local-file-compiler): New compiler.
      (gexp->sexp) <struct? thing>: Handle the case where 'lower' returns a
      file name.
    * tests/gexp.scm ("one local file", "gexp->derivation, local-file"): New
      tests.
---
 guix/gexp.scm  |   42 ++++++++++++++++++++++++++++++++++++++++--
 tests/gexp.scm |   24 ++++++++++++++++++++++++
 2 files changed, 64 insertions(+), 2 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 01290db..3048492 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -31,6 +31,8 @@
 
             gexp-input
             gexp-input?
+            local-file
+            local-file?
 
             gexp->derivation
             gexp->file
@@ -135,6 +137,37 @@ cross-compiling.)"
 
 
 ;;;
+;;; Local files.
+;;;
+
+(define-record-type <local-file>
+  (%local-file file name recursive?)
+  local-file?
+  (file       local-file-file)                    ;string
+  (name       local-file-name)                    ;string
+  (recursive? local-file-recursive?))             ;Boolean
+
+(define* (local-file file #:optional (name (basename file))
+                     #:key (recursive? #t))
+  "Return an object representing local file FILE to add to the store; this
+object can be used in a gexp.  FILE will be added to the store under NAME--by
+default the base name of FILE.
+
+When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
+designates a flat file and RECURSIVE? is true, its contents are added, and its
+permission bits are kept.
+
+This is the declarative counterpart of the 'interned-file' monadic procedure."
+  (%local-file file name recursive?))
+
+(define-gexp-compiler (local-file-compiler (file local-file?) system target)
+  ;; "Compile" FILE by adding it to the store.
+  (match file
+    (($ <local-file> file name recursive?)
+     (interned-file file name #:recursive? recursive?))))
+
+
+;;;
 ;;; Inputs & outputs.
 ;;;
 
@@ -453,8 +486,13 @@ and in the current monad setting (system type, etc.)"
         (($ <gexp-input> (? struct? thing) output n?)
          (let ((lower  (lookup-compiler thing))
                (target (if (or n? native?) #f target)))
-           (mlet %store-monad ((drv (lower thing system target)))
-             (return (derivation->output-path drv output)))))
+           (mlet %store-monad ((obj (lower thing system target)))
+             ;; OBJ must be either a derivation or a store file name.
+             (return (match obj
+                       ((? derivation? drv)
+                        (derivation->output-path drv output))
+                       ((? string? file)
+                        file))))))
         (($ <gexp-input> x)
          (return x))
         (x
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 0540969..d8b6d3f 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -97,6 +97,18 @@
                               %store (package-source coreutils))))
                  (gexp->sexp* exp)))))
 
+(test-assert "one local file"
+  (let* ((file  (search-path %load-path "guix.scm"))
+         (local (local-file file))
+         (exp   (gexp (display (ungexp local))))
+         (intd  (add-to-store %store (basename file) #t
+                              "sha256" file)))
+    (and (gexp? exp)
+         (match (gexp-inputs exp)
+           (((x "out"))
+            (eq? x local)))
+         (equal? `(display ,intd) (gexp->sexp* exp)))))
+
 (test-assert "same input twice"
   (let ((exp (gexp (begin
                      (display (ungexp coreutils))
@@ -336,6 +348,18 @@
     (mlet %store-monad ((drv mdrv))
       (return (string=? system (derivation-system drv))))))
 
+(test-assertm "gexp->derivation, local-file"
+  (mlet* %store-monad ((file ->  (search-path %load-path "guix.scm"))
+                       (intd     (interned-file file))
+                       (local -> (local-file file))
+                       (exp ->   (gexp (symlink (ungexp local)
+                                                (ungexp output))))
+                       (drv      (gexp->derivation "local-file" exp)))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (return (string=? (readlink (derivation->output-path drv))
+                        intd)))))
+
 (test-assertm "gexp->derivation, cross-compilation"
   (mlet* %store-monad ((target -> "mips64el-linux")
                        (exp    -> (gexp (list (ungexp coreutils)