@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
@@ -46,6 +46,7 @@ (define-module (guix git)
#:use-module (ice-9 ftw)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (%repository-cache-directory
@@ -60,6 +61,7 @@ (define-module (guix git)
latest-repository-commit
commit-difference
commit-relation
+ commit-descendant?
remote-refs
@@ -623,6 +625,26 @@ (define (commit-relation old new)
(if (set-contains? oldest new)
'descendant
'unrelated))))))
+
+(define (commit-descendant? new old)
+ "Return true if NEW is the descendant of one of OLD, a list of commits.
+
+When the expected result is likely #t, this is faster than using
+'commit-relation' since fewer commits need to be traversed."
+ (let ((old (list->setq old)))
+ (let loop ((commits (list new))
+ (visited (setq)))
+ (match commits
+ (()
+ #f)
+ (_
+ ;; Perform a breadth-first search as this is likely going to
+ ;; terminate more quickly than a depth-first search.
+ (let ((commits (remove (cut set-contains? visited <>) commits)))
+ (or (any (cut set-contains? old <>) commits)
+ (loop (append-map commit-parents commits)
+ (fold set-insert visited commits)))))))))
+
;;
;;; Remote operations.
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz
;;;
;;; This file is part of GNU Guix.
@@ -162,6 +162,56 @@ (define-module (test-git)
(commit-relation master1 merge)
(commit-relation merge master1))))))
+(unless (which (git-command)) (test-skip 1))
+(test-equal "commit-descendant?"
+ '((master3 master3 => #t)
+ (master1 master3 => #f)
+ (master3 master1 => #t)
+ (master2 branch1 => #f)
+ (master2 branch1 master1 => #t)
+ (branch1 master2 => #f)
+ (branch1 merge => #f)
+ (merge branch1 => #t)
+ (master1 merge => #f)
+ (merge master1 => #t))
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "first commit")
+ (branch "hack")
+ (checkout "hack")
+ (add "1.txt" "1")
+ (commit "branch commit")
+ (checkout "master")
+ (add "b.txt" "B")
+ (commit "second commit")
+ (add "c.txt" "C")
+ (commit "third commit")
+ (merge "hack" "merge"))
+ (with-repository directory repository
+ (let ((master1 (find-commit repository "first"))
+ (master2 (find-commit repository "second"))
+ (master3 (find-commit repository "third"))
+ (branch1 (find-commit repository "branch"))
+ (merge (find-commit repository "merge")))
+ (letrec-syntax ((verify
+ (syntax-rules ()
+ ((_) '())
+ ((_ (new old ...) rest ...)
+ (cons `(new old ... =>
+ ,(commit-descendant? new
+ (list old ...)))
+ (verify rest ...))))))
+ (verify (master3 master3)
+ (master1 master3)
+ (master3 master1)
+ (master2 branch1)
+ (master2 branch1 master1)
+ (branch1 master2)
+ (branch1 merge)
+ (merge branch1)
+ (master1 merge)
+ (merge master1)))))))
+
(unless (which (git-command)) (test-skip 1))
(test-equal "remote-refs"
'("refs/heads/develop" "refs/heads/master"
* guix/git.scm (commit-descendant?): New procedure. * tests/git.scm ("commit-descendant?"): New test. --- guix/git.scm | 24 +++++++++++++++++++++++- tests/git.scm | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 74 insertions(+), 2 deletions(-)