anything-git-status-from-zle.el

;;; anything-git-status-from-zle
;;; Powered by the rubikitch's anything-zsh-history-from-zle
;;; http://d.hatena.ne.jp/rubikitch/20091208/anythingzsh
;;; Thank you very much rubikitch!

(require 'anything-menu)

(defgroup anything-git-status nil
  "anything-git-status"
  :prefix "anything-git-status-"
  :group 'anything-git-status)

(defvar anything-git-status-tab-width 8)

(eval-when-compile
  (require 'ansi-color)
  (defun ags/git-color-name->face-spec (color)
    (with-temp-buffer
      (call-process-shell-command
       (format "git config --get-color %s" color) nil (current-buffer))
      (insert color "\n")
      (get-text-property
       0 'face
       (ansi-color-apply (buffer-substring (point-min) (point-max)))))))

(defvar anything-git-status-header-face
  (eval-when-compile (ags/git-color-name->face-spec "color.status.header")))
(defvar anything-git-status-added-face
  (eval-when-compile (ags/git-color-name->face-spec "color.status.added")))
(defvar anything-git-status-changed-face
  (eval-when-compile (ags/git-color-name->face-spec "color.status.changed")))
(defvar anything-git-status-untracked-face
  (eval-when-compile (ags/git-color-name->face-spec "color.status.untracked")))

(defvar ags-status-buffer " *any git status*")

(defun ags/git-status->any-cand-buffer (dir)
  (with-current-buffer (get-buffer-create ags-status-buffer)
    (setq tab-width anything-git-status-tab-width)
    (erase-buffer)
    (ags/git-status-insert dir (current-buffer))
    (anything-candidate-buffer (current-buffer))))

(defun ags/git-status-insert (dir buf)
  (with-current-buffer buf
    (let ((default-directory dir))
      (unless (zerop (call-process-shell-command "git status" nil t))
        (error "Error git status exited abnormally"))
      (ags/highlight-maybe (current-buffer)))))

(defun ags/highlight-maybe (buf)
  (labels ((hi-header-maybe (face)
             (when face
               (put-text-property (point-min)
                                  (progn
                                    (goto-char (point-max))
                                    (unless (looking-at "^#")
                                      (re-search-backward "^#")
                                      (goto-char (point-at-eol)))
                                    (point))
                                  'face face)))
           (hi-section (section face)
             (goto-char (point-min))
             (when (re-search-forward section nil t)
               (re-search-forward "^#$")
               (forward-line)
               (while (and (not (eobp)) (looking-at "^#\t"))
                 (put-text-property (1+ (point-at-bol)) (point-at-eol)
                                    'face face)
                 (forward-line))
               (forward-line)))
           (hi-sections-maybe (specs)
             (loop for (pat . face) in specs do
                   (anything-aif (symbol-value face)
                       (hi-section pat it)))))
    (with-current-buffer buf
      (hi-header-maybe anything-git-status-header-face)
      (hi-sections-maybe
       '(("^# Changes to be committed:" . anything-git-status-added-face)
         ("^# Changed but not updated:" . anything-git-status-changed-face)
         ("^# Untracked files:" . anything-git-status-untracked-face))))))

(defun anything-git-status-1 (dir)
  (anything-menu
   `(((name . "Git Status")
      (init . ,(apply-partially 'ags/git-status->any-cand-buffer dir))
      (candidates-in-buffer)
      (get-line . buffer-substring)
      (pattern-transformer . ags/pattern-transformer)
      (display-to-real . ags/display-to-real)
      (action
       ("Paste" . identity)
       ("Edit" . ags/edit)
       ("Paste Marked Candidates" . ags/values)
       ("Edit Marked Candidates" . ags/edit-values))
      (action-transformer ags/at-sort-marked-maybe
                          ags/at-write-result)
      (header-line . ,(apply-partially 'ags/header-line dir))))
   nil nil nil "^#\t" "*anything git status*" nil))

(defun ags/pattern-transformer (pat)
  "If PAT is meaningful then transform it to ignore other than the pathnames in the `git status` output. This assumes the anything-match-plugin.el presence.

`git status` outputs a tab character before a pathname each time."
  (if (string-match (rx bol (0+ space) eol) pat) pat (format "%s ^#\t" pat)))

(defun ags/display-to-real (disp)
  (when (string-match "^#\t" disp)
    (let ((s (substring-no-properties disp)))
      (if (string-match (rx (1+ space (group (1+ (not blank))) eol)) s)
          (match-string 1 s)
        s))))

(defun ags/values (_c)
  (mapconcat 'identity
             (nreverse
              (delq nil (mapcar 'ags/display-to-real
                                (anything-marked-candidates))))
             " "))

(defun ags/edit-values (_) (ags/edit (ags/values nil)))

(defun ags/edit (v)
  (switch-to-buffer "*anything git status edit*")
  (erase-buffer)
  (setq buffer-undo-list nil)
  (anything-git-status-edit-mode)
  (insert v)
  (recursive-edit)
  (buffer-string))

(define-derived-mode anything-git-status-edit-mode fundamental-mode
  "Press C-c C-c to exit!"
  "Edit git command line"
  (define-key anything-git-status-edit-mode-map
      "\C-c\C-c" 'anything-git-status-edit-exit))

(defun anything-git-status-edit-exit ()
  (interactive)
  (exit-recursive-edit))

(defun ags/header-line (dir)
  (flet ((shorten-home-path (dir)
           (let ((xcell (car (anything-c-shorten-home-path (list dir)))))
             (if (consp xcell) (car xcell) xcell))))
    (format "%s (%s)"
            (directory-file-name (shorten-home-path dir))
            (with-current-buffer ags-status-buffer
              (goto-char (point-min))
              (buffer-substring-no-properties
               (line-beginning-position) (line-end-position))))))

(defun ags/at-write-result (as _s)
  (flet ((compose (&rest fns)
           (apply-partially (lambda (fns &rest args)
                              (anything-compose args (reverse fns)))
                            fns)))
    (loop for (disp . fn) in as
          collect (cons disp (compose 'ags/write-result fn)))))

(defvar anything-git-status-marked-action-up-vote-p t)

(defun ags/at-sort-marked-maybe (as _s)
  (if (and anything-git-status-marked-action-up-vote-p
           (anything-marked-candidates))
      (flet ((string-markedaction-p (s)
               (if (string-match "Marked Candidates" s) 1 0)))
        (let ((markedaction-greater-p
               (lambda (a b)
                 (> (string-markedaction-p a) (string-markedaction-p b)))))
          (sort* (copy-list as) markedaction-greater-p :key 'car)))
    as))

;; (save-window-excursion (flet ((am/set-frame ()) (am/close-frame ())) (anything-git-status-1 (expand-file-name "~/tmp/test/"))))

(defconst use-ags/am-setframe (gensym))

(defmacro with-ags/am-setframe-semantics (setframe &rest body)
  (let ((gsetframe (gensym)) (gclose (gensym)) (gset (gensym)))
    `(let ((,gsetframe ,setframe))
       (if (not (eq ,gsetframe use-ags/am-setframe))
           (let* (,gclose
                  (,gset (lambda () (setq ,gclose (funcall ,gsetframe)))))
             (flet ((am/set-frame () (funcall ,gset))
                    (am/close-frame () (funcall ,gclose)))
               ,@body))
         ,@body))))

(defalias 'ags/write-result 'am/write-result)

(defun anything-git-status-base (dir setframe)
  (let ((orig-any-display-func
         (symbol-function 'anything-default-display-buffer)))
    (flet ((anything-default-display-buffer (buf)
             (with-current-buffer buf
               (setq tab-width anything-git-status-tab-width))
             (funcall orig-any-display-func buf)))
      (with-ags/am-setframe-semantics setframe
        (anything-git-status-1 (file-name-as-directory dir))))))

(defun ags/close-frame-tty ()
  (switch-to-buffer ags-status-buffer)
  (goto-char (point-min))
  (dotimes (_ (window-height)) (insert "\n"))
  (goto-char (point-max))
  (forward-line -1)
  (recenter -1)
  (sit-for 0) ;; show the git status buffer as if `git status`ed
  (delete-frame))

(defun anything-git-status-from-zle-tty (dir)
  (interactive)
  (anything-git-status-base dir (lambda () 'ags/close-frame-tty)))

(defun anything-git-status-from-zle (dir)
  (interactive)
  (anything-git-status-base dir use-ags/am-setframe))

anything-git-status.zsh

_ags-just-one-space () {
  if [[ $BUFFER == "" ]]; then
    return
  fi

  zle vi-forward-blank-word
  zle set-mark-command

  zle vi-backward-blank-word
  if [[ $RBUFFER[2] != " " ]]; then
    zle vi-forward-blank-word-end
  fi
  zle forward-char

  zle kill-region
  zle magic-space
}
zle -N _ags-just-one-space

anything-git-status-result () {
  local tmpfile="/tmp/.am-tmp-file"
  if [[ -f $tmpfile ]]; then
    zle _ags-just-one-space
    zle -U "$(cat $tmpfile)"
    rm -f $tmpfile
  fi
}
zle -N anything-git-status-result

anything-git-status-tty () {
  zle -R "git status..."
  emacsclient -t --eval "(flet ((xterm-title-update ())) (anything-git-status-from-zle-tty ${(qqq)PWD}))"
  zle redisplay
  zle anything-git-status-result
}
zle -N anything-git-status-tty

anything-git-status () {
  emacsclient --eval "(anything-git-status-from-zle ${(qqq)PWD})" > /dev/null
  zle anything-git-status-result
}
zle -N anything-git-status

# bindkey "^[g" anything-git-status-tty
# bindkey "^[G" anything-git-status-tty
# bindkey "^[g" anything-git-status
# bindkey "^[G" anything-git-status