01/02: guix: hg-download: Add hg-predicate.

[guix-commits]

cbaines pushed a commit to branch master
in repository guix.

commit 521d33cdc6965ac5ce786cedc26e247eb8b6f4ee
Author: Holger Peters <holger.peters@posteo.de>
AuthorDate: Sun Nov 1 10:50:24 2020 +0100

    guix: hg-download: Add hg-predicate.
    
    `hg-predicate' acts for mercurial repositories as `git-predicate' acts
    for git-repositories.
    
    * guix/hg-download.scm (hg-predicate): New procedure.
    
    Signed-off-by: Christopher Baines <mail@cbaines.net>
---
 guix/hg-download.scm | 38 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 37 insertions(+), 1 deletion(-)

diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 694105c..bd55946 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -26,12 +26,14 @@
   #:use-module (guix packages)
   #:autoload   (guix build-system gnu) (standard-packages)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
   #:export (hg-reference
             hg-reference?
             hg-reference-url
             hg-reference-changeset
             hg-reference-recursive?
-
+            hg-predicate
             hg-fetch))
 
 ;;; Commentary:
@@ -93,4 +95,38 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a 
generic name if #f."
                       #:recursive? #t
                       #:guile-for-build guile)))
 
+(define (hg-file-list directory)
+  "Evaluates to a list of files contained in the repository at path
+  @var{directory}"
+  (let* ((port (open-input-pipe (format #f "hg files --repository ~s" 
directory)))
+         (files (let loop ((files '()))
+                  (let ((line (read-line port)))
+                    (cond
+                     ((eof-object? line) files)
+                     (else
+                      (loop (cons line files))))))))
+    (close-pipe port)
+    (map canonicalize-path files)))
+
+(define (should-select? path-list candidate)
+  "Returns #t in case that @var{candidate} is a file that is part of the given
+@var{path-list}."
+  (let ((canon-candidate (canonicalize-path candidate)))
+    (let loop ((xs path-list))
+      (cond
+       ((null? xs)
+        ;; Directories are not part of `hg files', but `local-file' will not
+        ;; recurse if we don't return #t for directories.
+        (equal? (array-ref (lstat candidate) 13) 'directory))
+       ((string-contains candidate (car xs)) #t)
+       (else (loop (cdr xs)))))))
+
+(define (hg-predicate directory)
+  "This procedure evaluates to a predicate that reports back whether a given
+@var{file} - @var{stat} combination is part of the files tracked by
+Mercurial."
+  (let ((files (hg-file-list directory)))
+    (lambda (file stat)
+      (should-select? files file))))
+
 ;;; hg-download.scm ends here