From 6554be68b43d5b240c8075cdbb479c66a9780f59 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@gnu.org>
Date: Sun, 29 Jan 2017 00:34:48 +0100
Subject: 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 +------------------------------------
 1 file changed, 1 insertion(+), 36 deletions(-)

(limited to 'gnu/packages/package-management.scm')

diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index 26802e0c62..8291740998 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?))))
-- 
cgit v1.2.3