Skip to content

Instantly share code, notes, and snippets.

Created Feb 26, 2021
What would you like to do?
Asynchronous git modeline (rough prototype)
;;; Asynchronous detailed git modeline.
;; git-ml 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.
;; This is a rough sketch. Things to do before publishing it as a package:
;; * Consider doing the checks per git directory instead of per buffer, then
;; propagating the results to all buffers which use this directory. Read
;; vc-mode's implementation -- does it do things this way or just calculate
;; the modeline for every buffer separately?
;; * Distinguish changes in the current file from changes in other files. Use
;; brackets, box, underline, etc. For example, display " master ✚1 [•1]" when
;; the current file has a staged change and there's another file with an
;; unstaged change.
;; * Handle errors by stopping the remaining processes and passing nil to
;; git-ml-render-function.
;; * Ensure that we never start the processes multiple times, even if the user
;; does many refreshes in quick succession.
;; * Use a timeout for the processes.
;; * Kill the processes when they're no longer needed because the user has
;; killed the buffer(s).
;; * Hook into magit to refresh the modeline after it executes commands.
;; * Refresh the git state in an idle timer.
;; * Document the result struct in git-ml-render-function's docstring.
;; * Consider using one of the async/await libraries. They don't seem popular
;; though, so not sure if it's a good idea.
;; * Consider turning the file into a global minor mode.
;; * Consider changing the git-ml prefix.
;; How to use:
;; 1. Add `git-ml' to your mode line, e.g. `(... vc-mode git-ml ...)'
;; 2. If you only use `vc-mode' for its modeline, you probably want to disable
;; it for git: `(setq vc-handled-backends (delq 'Git vc-handled-backends))'.
;; 3. `(git-ml-activate)'.
;; Inspiration (ideas):
;; *
;; *
;; Inspiration (implementation):
;; *
;; *
;; *
(require 'dash)
(require 'cl-lib)
(defvar git-ml-debug nil
"Whether to show debug messages.")
(defsubst git-ml--debug (format-string &rest args)
(when git-ml-debug
(apply #'message (concat "git-ml: " format-string) args)))
(defvar git-ml-check-git-action-p t
"Should we check for the git action in progress?
This requires some synchronous file accesses that may pause Emacs
if the filesystem with the repo is very slow.")
(defun git-ml--get-git-action (git-dir)
"Return the current git action in progress, or nil if there's none.
Example return values: \"rebase\", \"rebase-i\", \"cherry\".
GIT-DIR should be the path to the .git directory."
;; Logic from
;; <>.
;; I haven't found an async way to do this.
(let ((dir (expand-file-name it git-dir)))
(when (file-directory-p dir)
(and (file-regular-p (expand-file-name "rebasing" dir)) "rebase")
(and (file-regular-p (expand-file-name "applying" dir)) "am")
'("rebase-apply" "rebase" "../.dotest"))
(let ((file (expand-file-name it git-dir)))
(when (file-regular-p file)
'("rebase-merge/interactive" ".dotest-merge/interactive"))
(let ((dir (expand-file-name it git-dir)))
(when (file-directory-p dir)
'("rebase-merge" ".dotest-merge"))
(and (file-regular-p (expand-file-name "MERGE_HEAD" git-dir)) "merge")
(and (file-regular-p (expand-file-name "BISECT_LOG" git-dir)) "bisect")
(and (file-regular-p (expand-file-name "CHERRY_PICK_HEAD" git-dir))
(or (and (file-directory-p (expand-file-name "sequencer" git-dir))
(and (file-directory-p (expand-file-name "sequencer" git-dir))
(defvar git-ml nil
"Part of the modeline with git information.")
(make-variable-buffer-local 'git-ml)
;; Structs have to be defined before we try to `setf' their slots, otherwise
;; we'll get errors like `Symbol’s function definition is void: \(setf\
;; git-ml-result-action\)'.
(cl-defstruct (git-ml--state (:constructor git-ml--state-create)
(:copier nil))
(cl-defstruct (git-ml-result (:constructor git-ml-result-create)
(:copier nil))
(action nil)
(head nil)
(oid nil)
(upstream nil)
(n-commits-ahead nil)
(n-commits-behind nil)
(n-files-staged 0)
(n-files-unstaged 0)
(n-files-unmerged 0)
(n-files-untracked 0))
(defvar git-ml-render-function #'git-ml-render
"Function to use to render the git-ml variable. It will be
called with the result struct, or nil if there was an error
getting git information. It should return a string or nil.")
(defun git-ml-render (result)
(git-ml--debug "Rendering: %S" result)
(when result
" "
(when (git-ml-result-action result)
(format "[%s] " (git-ml-result-action result)))
(if (string= (git-ml-result-head result) "(detached)")
(if (string= (git-ml-result-oid result) "(initial)")
(substring (git-ml-result-oid result) 0 7))
(git-ml-result-head result))
(lambda (symbol-and-number)
(let ((symbol (car symbol-and-number))
(number (cdr symbol-and-number)))
(when (not (memq number '(nil 0)))
(concat " " symbol (number-to-string number)))))
(cons "" (git-ml-result-n-files-unstaged result))
(cons "" (git-ml-result-n-files-staged result))
(cons "" (git-ml-result-n-files-unmerged result))
(cons "?" (git-ml-result-n-files-untracked result))
(cons "" (git-ml-result-n-commits-ahead result))
(cons "" (git-ml-result-n-commits-behind result)))
(defun git-ml--maybe-finish (state result)
"If we've finished gathering information, set the modeline variable."
(cl-assert (>= (git-ml--state-remaining-processes state) 0))
(when (and (zerop (git-ml--state-remaining-processes state))
(buffer-live-p (git-ml--state-buffer state)))
(setf (buffer-local-value 'git-ml (git-ml--state-buffer state))
(funcall git-ml-render-function result))
"Rendered: %S"
(buffer-local-value 'git-ml (git-ml--state-buffer state)))))
(defun git-ml--parse-git-status (buffer result)
(with-current-buffer buffer
(goto-char (point-min))
(while (not (eobp))
(git-ml--debug "git status line: %s"
(point) (line-end-position)))
;; Optional headers, e.g. `# branch.ab +0 -0'.
((looking-at "# \\([^ ]+\\) \\(.+\\)$")
(let ((key (match-string-no-properties 1))
(value (match-string-no-properties 2)))
((string= key "branch.oid")
(setf (git-ml-result-oid result) value))
((string= key "branch.head")
(setf (git-ml-result-head result) value))
((string= key "branch.upstream")
(setf (git-ml-result-upstream result) value))
((string= key "branch.ab")
(if (string-match "^\\+\\([0-9]+\\) -\\([0-9]+\\)$" value)
(setf (git-ml-result-n-commits-ahead result)
(string-to-number (match-string-no-properties 1 value)))
(setf (git-ml-result-n-commits-behind result)
(string-to-number (match-string-no-properties 2 value))))
(error "Can't parse value for branch.ab: %s" value))))))
;; Changes, e.g. `1 .M N... 100644 (...) git-ml.el'.
((looking-at "\\(?:1\\|2\\) \\(.\\)\\(.\\) ")
(when (not (string= (match-string-no-properties 1) "."))
(cl-incf (git-ml-result-n-files-staged result)))
(when (not (string= (match-string-no-properties 2) "."))
(cl-incf (git-ml-result-n-files-unstaged result))))
;; Unmerged files, e.g. `u UU N... 100644 (...) git-ml.el'.
((looking-at "u ")
(cl-incf (git-ml-result-n-files-unmerged result)))
;; Untracked files, e.g. `? git-ml.el'.
((looking-at "\\? ")
(cl-incf (git-ml-result-n-files-untracked result))))
(defun git-ml--status-sentinel (process msg)
(when (and (eq (process-status process) 'exit)
(zerop (process-exit-status process))
(buffer-live-p (process-buffer process)))
(let ((state (process-get process 'git-ml--state-struct))
(result (process-get process 'git-ml--result-struct)))
(git-ml--parse-git-status (process-buffer process) result)
(kill-buffer (process-buffer process))
(cl-decf (git-ml--state-remaining-processes state))
(git-ml--maybe-finish state result))))
(defun git-ml--git-dir-sentinel (process msg)
(when (and (eq (process-status process) 'exit)
(zerop (process-exit-status process))
(buffer-live-p (process-buffer process)))
(let ((state (process-get process 'git-ml--state-struct))
(result (process-get process 'git-ml--result-struct)))
(with-current-buffer (process-buffer process)
(goto-char (point-max))
(when (save-match-data (looking-back "\n"))
(delete-char -1))
(let* ((git-dir (buffer-substring-no-properties (point-min) (point-max)))
(abs-git-dir (expand-file-name
git-dir (git-ml--state-process-dir state)))
(action (git-ml--get-git-action abs-git-dir)))
(setf (git-ml-result-action result) action))
(cl-decf (git-ml--state-remaining-processes state))
(git-ml--maybe-finish state result))))
(defun git-ml-refresh ()
"Refresh git state of the current buffer."
(let* ((default-directory (if (buffer-file-name)
(file-name-directory (buffer-file-name))
:buffer (current-buffer)
:process-dir default-directory
:remaining-processes (if git-ml-check-git-action-p 2 1)))
(result-struct (git-ml-result-create))
(make-process :name "git status for modeline"
:buffer " *git status for modeline*"
;; Ignore dirty submodules because we wouldn't do anything with them.
:command '("git" "status" "--porcelain=2" "--branch"
:connection-type 'pipe
:sentinel #'git-ml--status-sentinel
:noquery t))
(when git-ml-check-git-action-p
(make-process :name "git rev-parse for modeline"
:buffer " *git rev-parse for modeline*"
:command '("git" "rev-parse" "--git-dir")
:connection-type 'pipe
:sentinel #'git-ml--git-dir-sentinel
:noquery t))))
;; Will this always execute before a sentinel runs? I think so, but not sure.
(dolist (process (list status-process git-dir-process))
(when process
(process-put process 'git-ml--state-struct state-struct)
(process-put process 'git-ml--result-struct result-struct)))))
(defun git-ml-activate ()
(add-hook 'find-file-hook #'git-ml-refresh)
(add-hook 'after-save-hook #'git-ml-refresh))
(provide 'git-ml)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment