ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

git: Add 'commit-difference'.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2019-09-14 17:54:06 +02:00
parent a78dcb3d59
commit 873f6f1334
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
5 changed files with 242 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -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.

6
Makefile.am
View file

@ -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 \

40
guix/git.scm
View file

@ -28,6 +28,7 @@ (define-module (guix git)
#: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 @@ (define-module (guix git)
#:export (%repository-cache-directory
honor-system-x509-certificates!
with-repository
update-cached-checkout
latest-repository-commit
commit-difference
git-checkout
git-checkout?
@ -339,6 +342,43 @@ (define (print-git-error port key args default-printer)
(set-exception-printer! 'git-error print-git-error)
;;;
;;; 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.

97
guix/tests/git.scm Normal file
View file

@ -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)))

99
tests/git.scm Normal file
View file

@ -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")