03/04: gexp: Add #:select? parameter to 'local-file'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 0687fc9cd98e38feab80e2f9c8044e77ad52c7fd
Author: Ludovic Courtès <address@hidden>
Date:   Thu Jun 16 00:06:27 2016 +0200

    gexp: Add #:select? parameter to 'local-file'.
    
    * guix/gexp.scm (<local-file>)[select?]: New field.
    (true): New procedure.
    (%local-file): Add #:select? and honor it.
    (local-file): Likewise.
    * tests/gexp.scm ("local-file, #:select?"): New test.
    * doc/guix.texi (G-Expressions): Adjust accordingly.
---
 doc/guix.texi  |    7 ++++++-
 guix/gexp.scm  |   20 ++++++++++++++------
 tests/gexp.scm |   18 +++++++++++++++++-
 3 files changed, 37 insertions(+), 8 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index f85221d..227d861 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3804,7 +3804,7 @@ does not have any effect on what the G-expression does.
 content is directly passed as a string.
 
 @deffn {Scheme Procedure} local-file @var{file} address@hidden @
-   [#:recursive? #f]
+   [#:recursive? #f] [#:select? (const #t)]
 Return an object representing local file @var{file} to add to the store; this
 object can be used in a gexp.  If @var{file} is a relative file name, it is 
looked
 up relative to the source file where this form appears.  @var{file} will be 
added to
@@ -3814,6 +3814,11 @@ When @var{recursive?} is true, the contents of 
@var{file} are added recursively;
 designates a flat file and @var{recursive?} is true, its contents are added, 
and its
 permission bits are kept.
 
+When @var{recursive?} is true, call @code{(@var{select?} @var{file}
address@hidden)} for each directory entry, where @var{file} is the entry's
+absolute file name and @var{stat} is the result of @code{lstat}; exclude
+entries for which @var{select?} does not return true.
+
 This is the declarative counterpart of the @code{interned-file} monadic
 procedure (@pxref{The Store Monad, @code{interned-file}}).
 @end deffn
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 8e604ff..2bf1013 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -189,18 +189,21 @@ cross-compiling.)"
 ;; absolute file name.  We keep it in a promise to compute it lazily and avoid
 ;; repeated 'stat' calls.
 (define-record-type <local-file>
-  (%%local-file file absolute name recursive?)
+  (%%local-file file absolute name recursive? select?)
   local-file?
   (file       local-file-file)                    ;string
   (absolute   %local-file-absolute-file-name)     ;promise string
   (name       local-file-name)                    ;string
-  (recursive? local-file-recursive?))             ;Boolean
+  (recursive? local-file-recursive?)              ;Boolean
+  (select?    local-file-select?))                ;string stat -> Boolean
+
+(define (true file stat) #t)
 
 (define* (%local-file file promise #:optional (name (basename file))
-                      #:key recursive?)
+                      #:key recursive? (select? true))
   ;; This intermediate procedure is part of our ABI, but the underlying
   ;; %%LOCAL-FILE is not.
-  (%%local-file file promise name recursive?))
+  (%%local-file file promise name recursive? select?))
 
 (define (absolute-file-name file directory)
   "Return the canonical absolute file name for FILE, which lives in the
@@ -222,6 +225,10 @@ 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.
 
+When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
+where FILE is the entry's absolute file name and STAT is the result of
+'lstat'; exclude entries for which SELECT? does not return true.
+
 This is the declarative counterpart of the 'interned-file' monadic procedure."
   (%local-file file
                (delay (absolute-file-name file (current-source-directory)))
@@ -235,12 +242,13 @@ This is the declarative counterpart of the 
'interned-file' monadic procedure."
 (define-gexp-compiler (local-file-compiler (file local-file?) system target)
   ;; "Compile" FILE by adding it to the store.
   (match file
-    (($ <local-file> file (= force absolute) name recursive?)
+    (($ <local-file> file (= force absolute) name recursive? select?)
      ;; Canonicalize FILE so that if it's a symlink, it is resolved.  Failing
      ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling
      ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would
      ;; just throw an error, both of which are inconvenient.
-     (interned-file absolute name #:recursive? recursive?))))
+     (interned-file absolute name
+                    #:recursive? recursive? #:select? select?))))
 
 (define-record-type <plain-file>
   (%plain-file name content references)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index db0ffd2..f504b92 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -33,7 +33,8 @@
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
-  #:use-module (ice-9 popen))
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 ftw))
 
 ;; Test the (guix gexp) module.
 
@@ -132,6 +133,21 @@
       (lambda ()
         (false-if-exception (delete-file link))))))
 
+(test-assertm "local-file, #:select?"
+  (mlet* %store-monad ((select? -> (lambda (file stat)
+                                     (member (basename file)
+                                             '("guix.scm" "tests"
+                                               "gexp.scm"))))
+                       (file -> (local-file ".." "directory"
+                                            #:recursive? #t
+                                            #:select? select?))
+                       (dir (lower-object file)))
+    (return (and (store-path? dir)
+                 (equal? (scandir dir)
+                         '("." ".." "guix.scm" "tests"))
+                 (equal? (scandir (string-append dir "/tests"))
+                         '("." ".." "gexp.scm"))))))
+
 (test-assert "one plain file"
   (let* ((file     (plain-file "hi" "Hello, world!"))
          (exp      (gexp (display (ungexp file))))