git: Add 'commit-difference'.

* guix/git.scm (commit-closure, commit-difference): New procedures.
* guix/tests/git.scm, tests/git.scm: New files.
* Makefile.am (dist_noinst_DATA): Add guix/tests/git.scm.
(SCM_TESTS): Add tests/git.scm.

5 files changed, 242 insertions, 1 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index 228685a69f..22aac2c402 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -90,6 +90,7 @@
    (eval . (put 'eventually 'scheme-indent-function 1))
 
    (eval . (put 'call-with-progress-reporter 'scheme-indent-function 1))
+   (eval . (put 'with-temporary-git-repository 'scheme-indent-function 2))
 
    ;; This notably allows '(' in Paredit to not insert a space when the
    ;; preceding symbol is one of these.
diff --git a/Makefile.am b/Makefile.am
index f71ea77671..658f03bd54 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -307,7 +307,10 @@ STORE_MODULES =					\
 MODULES += $(STORE_MODULES)
 
 # Internal modules with test suite support.
-dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
+dist_noinst_DATA =				\
+  guix/tests.scm				\
+  guix/tests/http.scm				\
+  guix/tests/git.scm
 
 # Auxiliary files for packages.
 AUX_FILES =						\
@@ -391,6 +394,7 @@ SCM_TESTS =					\
   tests/file-systems.scm			\
   tests/gem.scm				\
   tests/gexp.scm				\
+  tests/git.scm					\
   tests/glob.scm				\
   tests/gnu-maintenance.scm			\
   tests/grafts.scm				\
diff --git a/guix/git.scm b/guix/git.scm
index 92a7353b5a..d7dddde3a7 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -28,6 +28,7 @@
   #:use-module (guix utils)
   #:use-module (guix records)
   #:use-module (guix gexp)
+  #:use-module (guix sets)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
@@ -37,8 +38,10 @@
   #:export (%repository-cache-directory
             honor-system-x509-certificates!
 
+            with-repository
             update-cached-checkout
             latest-repository-commit
+            commit-difference
 
             git-checkout
             git-checkout?
@@ -341,6 +344,43 @@ Log progress and checkout info to LOG-PORT."
 
 
 ;;;
+;;; Commit difference.
+;;;
+
+(define (commit-closure commit)
+  "Return the closure of COMMIT as a set."
+  (let loop ((commits (list commit))
+             (visited (setq)))
+    (match commits
+      (()
+       visited)
+      ((head . tail)
+       (if (set-contains? visited head)
+           (loop tail visited)
+           (loop (append (commit-parents head) tail)
+                 (set-insert head visited)))))))
+
+(define (commit-difference new old)
+  "Return the list of commits between NEW and OLD, where OLD is assumed to be
+an ancestor of NEW.
+
+Essentially, this computes the set difference between the closure of NEW and
+that of OLD."
+  (let loop ((commits (list new))
+             (result '())
+             (visited (commit-closure old)))
+    (match commits
+      (()
+       (reverse result))
+      ((head . tail)
+       (if (set-contains? visited head)
+           (loop tail result visited)
+           (loop (append (commit-parents head) tail)
+                 (cons head result)
+                 (set-insert head visited)))))))
+
+
+;;;
 ;;; Checkouts.
 ;;;
 
diff --git a/guix/tests/git.scm b/guix/tests/git.scm
new file mode 100644
index 0000000000..52abe77c83
--- /dev/null
+++ b/guix/tests/git.scm
@@ -0,0 +1,97 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix tests git)
+  #:use-module (git)
+  #:use-module (guix utils)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 control)
+  #:export (git-command
+            with-temporary-git-repository
+            find-commit))
+
+(define git-command
+  (make-parameter "git"))
+
+(define (populate-git-repository directory directives)
+  "Initialize a new Git checkout and repository in DIRECTORY and apply
+DIRECTIVES.  Each element of DIRECTIVES is an sexp like:
+
+  (add \"foo.txt\" \"hi!\")
+
+Return DIRECTORY on success."
+
+  ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do
+  ;; all this, so resort to the "git" command.
+  (define (git command . args)
+    (apply invoke (git-command) "-C" directory
+           command args))
+
+  (mkdir-p directory)
+  (git "init")
+
+  (let loop ((directives directives))
+    (match directives
+      (()
+       directory)
+      ((('add file contents) rest ...)
+       (let ((file (string-append directory "/" file)))
+         (mkdir-p (dirname file))
+         (call-with-output-file file
+           (lambda (port)
+             (display contents port)))
+         (git "add" file)
+         (loop rest)))
+      ((('commit text) rest ...)
+       (git "commit" "-m" text)
+       (loop rest))
+      ((('branch name) rest ...)
+       (git "branch" name)
+       (loop rest))
+      ((('checkout branch) rest ...)
+       (git "checkout" branch)
+       (loop rest))
+      ((('merge branch message) rest ...)
+       (git "merge" branch "-m" message)
+       (loop rest)))))
+
+(define (call-with-temporary-git-repository directives proc)
+  (call-with-temporary-directory
+   (lambda (directory)
+     (populate-git-repository directory directives)
+     (proc directory))))
+
+(define-syntax-rule (with-temporary-git-repository directory
+                                                   directives exp ...)
+  "Evaluate EXP in a context where DIRECTORY contains a checkout populated as
+per DIRECTIVES."
+  (call-with-temporary-git-repository directives
+                                      (lambda (directory)
+                                        exp ...)))
+
+(define (find-commit repository message)
+  "Return the commit in REPOSITORY whose message includes MESSAGE, a string."
+  (let/ec return
+    (fold-commits (lambda (commit _)
+                    (and (string-contains (commit-message commit)
+                                          message)
+                         (return commit)))
+                  #f
+                  repository)
+    (error "commit not found" message)))
diff --git a/tests/git.scm b/tests/git.scm
new file mode 100644
index 0000000000..8ba10ece51
--- /dev/null
+++ b/tests/git.scm
@@ -0,0 +1,99 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-git)
+  #:use-module (git)
+  #:use-module (guix git)
+  #:use-module (guix tests git)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-64))
+
+;; Test the (guix git) tools.
+
+(test-begin "git")
+
+;; 'with-temporary-git-repository' relies on the 'git' command.
+(unless (which (git-command)) (test-skip 1))
+(test-assert "commit-difference, linear history"
+  (with-temporary-git-repository directory
+      '((add "a.txt" "A")
+        (commit "first commit")
+        (add "b.txt" "B")
+        (commit "second commit")
+        (add "c.txt" "C")
+        (commit "third commit")
+        (add "d.txt" "D")
+        (commit "fourth commit"))
+    (with-repository directory repository
+      (let ((commit1 (find-commit repository "first"))
+            (commit2 (find-commit repository "second"))
+            (commit3 (find-commit repository "third"))
+            (commit4 (find-commit repository "fourth")))
+        (and (lset= eq? (commit-difference commit4 commit1)
+                    (list commit2 commit3 commit4))
+             (lset= eq? (commit-difference commit4 commit2)
+                    (list commit3 commit4))
+             (equal? (commit-difference commit3 commit2)
+                     (list commit3))
+
+             ;; COMMIT4 is not an ancestor of COMMIT1 so we should get the
+             ;; empty list.
+             (null? (commit-difference commit1 commit4)))))))
+
+(unless (which (git-command)) (test-skip 1))
+(test-assert "commit-difference, fork"
+  (with-temporary-git-repository directory
+      '((add "a.txt" "A")
+        (commit "first commit")
+        (branch "devel")
+        (checkout "devel")
+        (add "devel/1.txt" "1")
+        (commit "first devel commit")
+        (add "devel/2.txt" "2")
+        (commit "second devel commit")
+        (checkout "master")
+        (add "b.txt" "B")
+        (commit "second commit")
+        (add "c.txt" "C")
+        (commit "third commit")
+        (merge "devel" "merge")
+        (add "d.txt" "D")
+        (commit "fourth commit"))
+    (with-repository directory repository
+      (let ((master1 (find-commit repository "first commit"))
+            (master2 (find-commit repository "second commit"))
+            (master3 (find-commit repository "third commit"))
+            (master4 (find-commit repository "fourth commit"))
+            (devel1  (find-commit repository "first devel"))
+            (devel2  (find-commit repository "second devel"))
+            (merge   (find-commit repository "merge")))
+        (and (equal? (commit-difference master4 merge)
+                     (list master4))
+             (lset= eq? (commit-difference master3 master1)
+                    (list master3 master2))
+             (lset= eq? (commit-difference devel2 master1)
+                    (list devel2 devel1))
+
+             ;; The merge occurred between MASTER2 and MASTER4 so here we
+             ;; expect to see all the commits from the "devel" branch in
+             ;; addition to those on "master".
+             (lset= eq? (commit-difference master4 master2)
+                    (list master4 merge master3 devel1 devel2)))))))
+
+(test-end "git")