From: Holger Peters <holger.peters@posteo.de>
To: 44367@debbugs.gnu.org
Cc: Holger Peters <holger.peters@posteo.de>
Subject: [bug#44367] [PATCH 1/2] guix: hg-download: Add hg-predicate
Date: Sun, 1 Nov 2020 10:50:24 +0100 [thread overview]
Message-ID: <9169d111edc807df292fe0566ce72f84e6d5dd44.1604223741.git.holger.peters@posteo.de> (raw)
In-Reply-To: <cover.1604223741.git.holger.peters@posteo.de>
`hg-predicate' acts for mercurial repositories as `git-predicate' acts
for git-repositories.
* guix/hg-download.scm (hg-predicate): New variable.
---
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 694105ceba..44212e295e 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? pth-lst candidate)
+ "Returns #t in case that @var{candidate} is a file is part of the given file
+ list @var{path-list}."
+ (let ((canon-candidate (canonicalize-path candidate)))
+ (let loop ((xs pth-lst))
+ (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
--
2.28.0
next prev parent reply other threads:[~2020-11-01 9:51 UTC|newest]
Thread overview: 8+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-11-01 9:47 [bug#44367] [PATCH 0/2] hg-predicate Holger Peters
2020-11-01 9:50 ` Holger Peters [this message]
2020-11-01 9:50 ` [bug#44367] [PATCH 2/2] doc: Document hg-fetch Holger Peters
2020-11-14 10:33 ` Christopher Baines
2020-11-14 10:31 ` [bug#44367] [PATCH 1/2] guix: hg-download: Add hg-predicate Christopher Baines
2020-11-07 22:16 ` [bug#44367] Rationale for hg-predicate Dr. Arne Babenhauserheide
2020-11-13 18:02 ` Holger Peters
2020-11-14 10:29 ` bug#44367: " Christopher Baines
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=9169d111edc807df292fe0566ce72f84e6d5dd44.1604223741.git.holger.peters@posteo.de \
--to=holger.peters@posteo.de \
--cc=44367@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).