#!/bin/sh
# -*-scheme-*-
exec guile -s "$0" "$@"
!#

(use-modules (git)
             (guix git))

(define %repo "/tmp/guix-fork")

(define h1 "72745172d155e489936f694d6b9013cb76272370")
(define h2 "6d60d7ccba5a8e06c17d55a1772fa7f4529b5eff")
(define h3 "c3db650680f995f0556d3ddce567cdc1c33e4603")

;;; r has to still be defined when the commit-relation is called.  There is *no*
;;; error, but it always returns 'unrelated.  Quite a footgun.
(define r (repository-open %repo))
(define c1 (commit-lookup r (string->oid h1)))
(define c2 (commit-lookup r (string->oid h2)))
(define c3 (commit-lookup r (string->oid h3)))

(define (git-C dir . args)
  (apply system* "git" "-C" dir args))

(define (shelling-commit-relation old new)
  (let ((h-old (oid->string (commit-id old)))
        (h-new (oid->string (commit-id new))))
    (cond ((eq? old new)
           'self)
          ;; In real code, git-C should probably return #t (for 0), #f (for 1)
          ;; or raise (for anything else).
          ((zero? (git-C %repo "merge-base" "--is-ancestor" h-old h-new))
           'ancestor)
          ((zero? (git-C %repo "merge-base" "--is-ancestor" h-new h-old))
           'descendant)
          (else
           'unrelated))))

;;; Make sure it actually works.
(let ((tests `((,c1 . ,c1)
               (,c1 . ,c2)
               (,c2 . ,c1)
               (,c1 . ,c3))))
  (for-each (λ (c)
              (format #t "Guix: ~a\nGit:  ~a\n\n"
                      (commit-relation (car c) (cdr c))
                      (shelling-commit-relation (car c) (cdr c))))
            tests))

(define (time proc)
  (let* ((start (get-internal-run-time))
         (_ (proc))
         (end   (get-internal-run-time)))
    (exact->inexact (* 1000 (/ (- end start) internal-time-units-per-second)))))

(format #t "Guix: ~ams\nGit:  ~ams\n"
        (time (λ () (commit-relation c1 c2)))
        (time (λ () (shelling-commit-relation c1 c2))))