futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

git: Add 'commit-descendant?'.

Browse Source 
* guix/git.scm (commit-descendant?): New procedure.
* tests/git.scm ("commit-descendant?"): New test.
This commit is contained in:
Ludovic Courtès 2022-01-28 16:59:30 +01:00
parent 36cb04df96
commit 87d49346f3
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 74 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
guix/git.scm
View File

@ -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 @@
#: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 @@
latest-repository-commit
commit-difference
commit-relation
commit-descendant?
remote-refs
@ -623,6 +625,26 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
(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.

52
tests/git.scm
View File

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