git-explode.scm

#!/usr/bin/env -S guile -L . -e '(@ (git-explode) main)'

git-explode

Commits unstaged changes from the current worktree into the repo one hunk at a
time. I made this in order to automatically bisect linux kernel configurations,
and it may be most useful with similer deltas, ie. those consisting of several
dozen or hundred single-line changes which allow _each_ individual hunk of a
diff to produce a potentially valid state.

If ran when the last commit matches it's own commit pattern, git-explode will
resume counting where it presumably left off, and will commit any existing
staged changes under the assumption that they comprise the next hunk.

This was initially written as an `expect' script, but I've lost / haven't got
time right now to resurface that (arguably more portable) original.

!# 

;;; ----- Modules -----
(define-module (git-explode)
  #:use-module (git)
  #:use-module (git commit)
  #:use-module (git repository)
  #:use-module (ice-9 regex)
  #:export (git-explode))

;;; ----- TEMP WORKAROUND -----
;; I've submitted a pull-request to fix this upstream.
(use-modules (rnrs bytevectors) (system foreign) (ice-9 match)
             (git bindings) (git types) (git reference))
(module-define! (resolve-module '(git repository)) 'repository-index
                (let ((proc (libgit2->procedure* "git_repository_index" '(* *))))
                  (lambda (repository)
                    (let ((out (make-double-pointer)))
                      ;; (proc (repository->pointer repository))
                      (proc out (repository->pointer repository))
                      (pointer->index (dereference-pointer out))))))

;;; ----- Functions -----
(define (status:success? status)
  (zero? (status:exit-val status)))

;; Misc. git repo helpers
(define (repository-head-commit repo)
  (let ((head-commit-oid (reference-target (repository-head repo))))
    (commit-lookup repo head-commit-oid)))

(define (repository-worktree-dirty? repo)
  "Returns #t if repository REPO has un-staged changes in it's working tree."
  (let* ((index (repository-index repo))
         (diff (diff-index-to-workdir repo index)))
    (not (string-null? (diff->string diff)))))

(define (repository-index-dirty? repo)
  "Returns #t if repository REPO has un-commited changes in it's index."
  ;; We don't define head-commit-* as globals becaue the index state may need
  ;; to be refreshed from disk.
  (let* ((tree (commit-tree (repository-head-commit repo)))
         (index (repository-index repo))
         (diff (diff-tree-to-index repo tree index)))
    (not (string-null? (diff->string diff)))))

;; Functions with side-effects
(define (stage-next-hunk repo)
  "Spams 'git add -p' with 's' to break commits into the smallest possible
  hunks, then stages the first 'sub-hunk' and exits."
  ;; The 'right' way to do this might look something like this, but libgit2
  ;; can't split hunks up as finely as git and guile-git doesn't have a binding
  ;; for git_commit_create yet:
  ;;   (let* ((index (repository-index %repo))
  ;;          (diff (diff-index-to-workdir %repo index))
  ;;          (_ (const 0))
  ;;          (hunk-cb
  ;;            (lambda (delta hunk)
  ;;              () ;; git_commit_create
  ;;              0  ;; return code
  ;;             )))
  ;;     (diff-foreach diff _ _ hunk-cb _))
  (if (not (repository-worktree-dirty? repo))
      (error "no unstaged changes to stage")
      (system "printf '%s\\n' s s s s s y q \| git add -p")))

(define (commit-next-hunk repo i)
  ;; Does not refresh when repo state is updated.
  ;; (if (not (repository-index-dirty? %repo))
  ;;     (error "no staged changes to commit"))
  (system* "git" (string-append "--git-dir=" (repository-directory repo))
           "commit" "-m" (string-append "git-explode: hunk #"
                                        (number->string i))))

;; Control Flow
(define (git-explode repo)
  (let* ((match (string-match "git-explode: hunk #"
                              (commit-summary (repository-head-commit repo))))
         (last-hunk (if match (string->number (match:suffix match))
                        0)))

    ;; Resume gracefully if interupted between stage & commit
    (if (repository-index-dirty? repo)
        (if match (begin (commit-next-hunk repo last-hunk)
                         (set! last-hunk (+ last-hunk 1)))
            (error "unrecognised changes staged in index")))

    ;; Stage hunks one-by-one
    (let git-explode* ((iter last-hunk))
      (if (and (repository-worktree-dirty? repo)
               (status:success? (stage-next-hunk repo))
               (status:success? (commit-next-hunk repo iter)))
          (git-explode* (+ iter 1))))))

;;; ----- __main__ -----
(define (main args)
  ;; TODO: Make arg optional, fall back to current directory
  (let ((repo (repository-open (cadr args))))
    (git-explode repo)))