From f104b3745097746d6ef89b6198ec7b81e8b679f4 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@gnu.org>
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 <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
 ;;;
 ;;; 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