Re: Add a generalized git-file? to Guix?

[Mathieu Lirzin]

Hello,

address@hidden (Ludovic Courtès) writes:

> Mathieu Lirzin <address@hidden> skribis:
>
>> Christopher Allan Webber <address@hidden> writes:
>>
>>> 8sync now uses `git-file?' in its guix.scm, a predicate check which
>>> allows for checking out the whole local directory as a "source" for
>>> testing a package.  I borrowed it from Dave who originally adapted
>>> it from some code in Guix itself.  See:
>>>
>>>   http://git.savannah.gnu.org/cgit/8sync.git/tree/guix.scm#n62
>>>
>>> This is pretty handy; probably other projects would like to make use of
>>> it.  What do we think of making it a generally available utility?
>>
>> I would make use of it and I am in favour of adding it to Guix.
>
> I think it comes from ‘current-guix’ in package-management.scm, and yes,
> we should probably make it public.
>
> Would someone like to submit a patch?  The most difficult issue is
> finding in file in which to store it.  ;-)  Maybe git-download.scm?

Here is a patch renaming 'make-git-predicate' to 'git-predicate' and
moving it to (guix git-download).

>From f104b3745097746d6ef89b6198ec7b81e8b679f4 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <address@hidden>
Date: Sun, 29 Jan 2017 00:34:48 +0100
Subject: [PATCH] git-download: Add 'git-predicate'.

* guix/git-download.scm (git-predicate): New procedure.
* gnu/packages/package-management.scm (current-guix): Use it.
(make-git-predicate): Remove.
---
 gnu/packages/package-management.scm | 37 +------------------------------
 guix/git-download.scm               | 43 ++++++++++++++++++++++++++++++++++++-
 2 files changed, 43 insertions(+), 37 deletions(-)

diff --git a/gnu/packages/package-management.scm 
b/gnu/packages/package-management.scm
index 92787d76c..272fc6ab0 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -25,7 +25,6 @@
   #:use-module (guix utils)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system python)
-  #:use-module ((guix build utils) #:select (with-directory-excursion))
   #:use-module ((guix licenses) #:select (gpl2+ gpl3+ lgpl2.1+ asl2.0))
   #:use-module (gnu packages)
   #:use-module (gnu packages guile)
@@ -53,10 +52,6 @@
   #:use-module (gnu packages tls)
   #:use-module (gnu packages ssh)
   #:use-module (gnu packages vim)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
-  #:use-module (ice-9 popen)
-  #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match))
 
 (define (boot-guile-uri arch)
@@ -275,38 +270,8 @@ generated file."
     (_
      #t)))
 
-(define (make-git-predicate directory)
-  "Return a predicate that returns true if a file is part of the Git checkout
-living at DIRECTORY.  Upon Git failure, return #f instead of a predicate."
-  (define (parent-directory? thing directory)
-    ;; Return #t if DIRECTORY is the parent of THING.
-    (or (string-suffix? thing directory)
-        (and (string-index thing #\/)
-             (parent-directory? (dirname thing) directory))))
-
-  (let* ((pipe        (with-directory-excursion directory
-                        (open-pipe* OPEN_READ "git" "ls-files")))
-         (files       (let loop ((lines '()))
-                        (match (read-line pipe)
-                          ((? eof-object?)
-                           (reverse lines))
-                          (line
-                           (loop (cons line lines))))))
-         (status      (close-pipe pipe)))
-    (and (zero? status)
-         (lambda (file stat)
-           (match (stat:type stat)
-             ('directory
-              ;; 'git ls-files' does not list directories, only regular files,
-              ;; so we need this special trick.
-              (any (cut parent-directory? <> file) files))
-             ((or 'regular 'symlink)
-              (any (cut string-suffix? <> file) files))
-             (_
-              #f))))))
-
 (define-public current-guix
-  (let ((select? (delay (or (make-git-predicate
+  (let ((select? (delay (or (git-predicate
                              (string-append (current-source-directory)
                                             "/../.."))
                             source-file?))))
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 62e625c71..5d86ab2b6 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2017 Mathieu Lirzin <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,6 +18,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix git-download)
+  #:use-module (guix build utils)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix monads)
@@ -24,6 +26,9 @@
   #: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)
+  #:use-module (srfi srfi-1)
   #:export (git-reference
             git-reference?
             git-reference-url
@@ -32,7 +37,8 @@
 
             git-fetch
             git-version
-            git-file-name))
+            git-file-name
+            git-predicate))
 
 ;;; Commentary:
 ;;;
@@ -119,4 +125,39 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a 
generic name if #f."
   "Return the file-name for packages using git-download."
   (string-append name "-" version "-checkout"))
 
+(define (git-predicate directory)
+  "Return a predicate that returns true if a file is part of the Git checkout
+living at DIRECTORY.  Upon Git failure, return #f instead of a predicate.
+
+The returned predicate takes two arguments FILE and STAT where FILE is an
+absolute file name and STAT is the result of 'lstat'."
+  (define (parent-directory? thing directory)
+    ;; Return #t if DIRECTORY is the parent of THING.
+    (or (string-suffix? thing directory)
+        (and (string-index thing #\/)
+             (parent-directory? (dirname thing) directory))))
+
+  (let* ((pipe        (with-directory-excursion directory
+                        (open-pipe* OPEN_READ "git" "ls-files")))
+         (files       (let loop ((lines '()))
+                        (match (read-line pipe)
+                          ((? eof-object?)
+                           (reverse lines))
+                          (line
+                           (loop (cons line lines))))))
+         (status      (close-pipe pipe)))
+    (and (zero? status)
+         (lambda (file stat)
+           (match (stat:type stat)
+             ('directory
+              ;; 'git ls-files' does not list directories, only regular files,
+              ;; so we need this special trick.
+              (any (lambda (f) (parent-directory? f file))
+                   files))
+             ((or 'regular 'symlink)
+              (any (lambda (f) (string-suffix? f file))
+                   files))
+             (_
+              #f))))))
+
 ;;; git-download.scm ends here
-- 
2.11.0

Thanks.

-- 
Mathieu Lirzin
GPG: F2A3 8D7E EB2B 6640 5761  070D 0ADE E100 9460 4D37