;; sy-git.el --- A couple of nice git tools   -*- Emacs-Lisp -*-

;; Copyright (C) 2015 - 2017 Steve Youngs

;; Author:     Steve Youngs <steve@sxemacs.org>
;; Maintainer: Steve Youngs <steve@sxemacs.org>
;; Created:    <2015-07-05>
;; Time-stamp: <Wednesday Mar 18, 2020 22:01:48 steve>
;; Homepage:   http://git.sxemacs.org/slh
;; Keywords:   git, tools, convenience

;; This file is part of SLH (Steve's Lisp Hacks).

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;;
;; 3. Neither the name of the author nor the names of any contributors
;;    may be used to endorse or promote products derived from this
;;    software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; Commentary:
;; 
;;   This is the beginnings of some convenience tools to use with git
;;   from within SXEmacs.
;;
;;   Presently, all that is here is a 'add-log' function that
;;   lets you write commit logs in a similar format to that of
;;   `add-change-log-entry'.  It is globally bound to `C-x G a'.
;;   See: `sy-git-add-log-entry'.
;;
;;   [2017-10-16 08:59]: Added rudimentary support for git-diff,
;;   git-blame, and git-log.  For examining changes you can use
;;   either plain `diff-mode' with `sy-git-diff', or Ediff with
;;   `sy-git-ediff'.

;;; Todo:
;;
;;     o Implement a variation of `patch-to-change-log'.
;;        [2017-10-15 15:09]: Turns out that this isn't really needed
;;        as you can invoke `sy-git-add-log-entry' directly from a diff.

;;; Code:
;; Need VC, ediff, and diff-mode
(vc-load-vc-hooks)
(add-to-list 'vc-handled-backends 'GIT)
(require 'ediff)
(require 'diff-mode)

;;; Eyecandy
(eval-and-compile
  (condition-case nil
      (require 'working)
    (error
     (progn
       (defmacro working-status-forms (message donestr &rest forms)
	 "Contain a block of code during which a working status is shown."
	 (list 'let (list (list 'msg message) (list 'dstr donestr)
			  '(ref1 0))
	       (cons 'progn forms)))
  
       (defun working-status (&optional percent &rest args)
	 "Called within the macro `working-status-forms', show the status."
	 (message "%s%s" (apply 'format msg args)
		  (if (eq percent t) (concat "... " dstr)
		    (format "... %3d%%"
			    (or percent
				(floor (* 100.0 (/ (float (point))
						   (point-max)))))))))
       (put 'working-status-forms 'lisp-indent-function 2)))))

(defvar sy-git-log-font-lock-keywords
  '(;;
    ;; Headers
    ("^commit .*$"
     (0 font-lock-warning-face))
    (#r"^\(Author\(Date\)?:\|Commit\(Date\)?:\|Date:\|Merge:\)"
       (1 gnus-header-content))
    ;; date
    (#r"Date:\(.*$\)"
       (1 change-log-date-face))
    ;; name/email
    (#r":\s-+\(.*\)\s-+<\(.*\)>"
       (1 change-log-name-face)
       (2 change-log-email-face))
    ;; file name
    (#r"^\s-+\* \([^ ,:(]+\)"
       (1 change-log-file-face))
    ;; Function or variable names.
    ("(\\([^) ,:\n]+\\)"
     (1 change-log-list-face)
     ("\\=, *\\([^) ,:\n]+\\)" nil nil
      (1 change-log-list-face)))
    ;; Signed-off
    (#r"\(Signed-off\|Reviewed\|Reported\|Acked\)-by:\|Cc:"
       (0 gnus-header-content))))

;;; Globals
(defvar sy-gitbin (executable-find "git")
  "The git binary.")

(defvar sy-git-default-binopts
  '("--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true")
  "The default options passed to every git invocation.

Screw with these at your own peril.  If you don't know what you are
doing DO NOT change them, or at the very least, DO NOT remove any of
them.")

(defun sy-git-run-buffer (buffer subcmd &rest args)
  "Run git SUBCMD with ARGS, collect output in BUFFER."
  (let ((git sy-gitbin)
	(gitopts sy-git-default-binopts)
	(coding-system-for-write (if (get-coding-system 'utf-8)
				     'utf-8
				   'binary))
	(buffer (get-buffer-create buffer)))
    ;; If called with ARGS as a list, it is now a nested list. That's
    ;; bad
    (while (listp (car args))
      (setq args (car args)))
    ;; nils are bad too
    (setq args (delq nil args))
    (setq args (and (push subcmd args)
		    (append gitopts args)))
    (apply #'call-process git nil buffer nil args)))
(put 'sy-git-run-buffer 'lisp-indent-function 1)

(defun sy-git-run-string (subcmd &rest args)
  "Return a string from output of git SUBCMD ARGS."
  (let ((git sy-gitbin)
	(gitopts sy-git-default-binopts)
	cmdline)
    ;; flatten and remove nils from ARGS
    (while (listp (car args))
      (setq args (car args)))
    (setq args (delq nil args))
    ;; build cmdline
    (push subcmd args)
    (setq cmdline (push git gitopts))
    (setq cmdline (append cmdline args))
    (setq cmdline (mapconcat #'identity cmdline " "))
    ;; run it
    (shell-command-to-string cmdline)))
(put 'sy-git-run-string 'lisp-indent-function 1)

(defun sy-git-check-hook (hook)
  "Return non-nil when HOOK script exists and is usable.

By \"usable\" we mean for `sy-git-add-log-entry'."
  (let ((hookname (file-basename hook)))
    (when (file-exists-p hook)
      (with-temp-buffer
	(insert-file-contents-literally hook)
	(goto-char (point-min))
	(cond
	 ((equal hookname "commit-msg")
	  (re-search-forward (regexp-quote "sed -i '/^#/d'") nil t))
	 ((equal hookname "post-commit")
	  (re-search-forward (regexp-quote "rm -f ${LOG}") nil t))
	 (t nil))))))

;;; diff
;; FIXME: might be nice to be able to diff against other revisions
;; aside from HEAD.
(defun sy-git-diff ()
  "Show a diff of the current file against HEAD."
  (interactive)
  (progn
    (vc-diff nil)
    (local-set-key [(control x) G a] #'sy-git-add-log-entry)))

(defun sy-git-ediff ()
  "Run ediff-buffers on the working file and the HEAD version."
  (interactive)
  (let* ((bufferA (file-basename (buffer-file-name)))
	 (bufferB (concat bufferA ".~HEAD~")))
    (progn
      (vc-version-other-window "HEAD")
      (ediff-buffers bufferA bufferB))))

;;; blame
(defun sy-git-blame-log (&optional extent)
  "*Display the log of the git commit who's sha is stored in EXTENT.

This command should only ever be called from within a Git Blame
buffer."
  (interactive)
  (unless (string-match "GIT Blame" (buffer-name))
    (error 'invalid-operation this-command
	   "Can only be called from the Blame buffer"))
  (let* ((extent (or extent
		     (extent-at (point) nil 'blame)))
	 (revstr (extent-property extent 'brev))
	 (showbuf (format "*GIT Show::%s*" revstr))
	 (gitcmd "show")
	 (args (split-string (format "--name-only %s" revstr)))
	 (cb (current-buffer)))
    (window-configuration-to-register ?l)
    (with-current-buffer (get-buffer-create showbuf)
      (erase-buffer)
      (set (make-local-variable 'font-lock-defaults)
	   '(sy-git-log-font-lock-keywords t t))
      (sy-git-run-buffer showbuf gitcmd args)
      (goto-char (point-min))
      (view-mode cb #'(lambda (showbuf)
			(kill-buffer showbuf)
			(jump-to-register ?l)
			(clear-register ?l))))
    (pop-to-buffer showbuf)
    (shrink-window-if-larger-than-buffer)))

(defun sy-git-blame-log-mouse (e)
  (interactive "e")
  (let ((extent (extent-at-event e 'blame)))
    (sy-git-blame-log extent)))

(defun sy-git-blame-show (&optional extent)
  "*Display git commit who's sha is stored in EXTENT.

This command should only ever be called from within a Git Blame
buffer."
  (interactive)
  (unless (string-match "GIT Blame" (buffer-name))
    (error 'invalid-operation this-command
	   "Can only be called from the Blame buffer"))
  (let* ((extent (or extent
		     (extent-at (point) nil 'blame)))
	 (revstr (extent-property extent 'brev))
	 (showbuf (format "*GIT Show::%s*" revstr))
	 (gitcmd "show")
	 (cb (current-buffer)))
    (window-configuration-to-register ?s)
    (with-current-buffer (get-buffer-create showbuf)
      (erase-buffer)
      (sy-git-run-buffer showbuf gitcmd revstr)
      (goto-char (point-min))
      (view-mode cb #'(lambda (showbuf)
			(kill-buffer showbuf)
			(jump-to-register ?s)
			(clear-register ?s))))
    (pop-to-buffer showbuf)
    (shrink-window-if-larger-than-buffer)))

(defun sy-git-blame-show-mouse (e)
  (interactive "e")
  (let ((extent (extent-at-event e 'blame)))
    (sy-git-blame-show extent)))

(defvar sy-git-blame-map
  (let ((map (make-sparse-keymap 'sy-git-blame-map)))
    (define-key map [s] #'sy-git-blame-show)
    (define-key map [l] #'sy-git-blame-log)
    (define-key map [button1] #'sy-git-blame-show-mouse)
    (define-key map [button2] #'sy-git-blame-log-mouse)
    map)
  "Keymap for blame extents.")

(defun sy-git-process-blame-buffer ()
  "Processes the content of the blame BUFFER.
Adds margin, extents, keymaps, etc."
  (let ((regex #r"\(^[a-f0-9]+\)\s-+[0-9]+) ")
	(hash (make-hash-table :size 1024 :test #'equal)))
    (set-specifier left-margin-width 11 (current-buffer))
    (goto-char (point-min))
    (save-excursion
      (working-status-forms "Blaming %s" "done"
	(while (re-search-forward regex nil t)
	  (working-status nil (substring (buffer-name) 12 -1))
	  (let ((blamerev (match-string 1))
		(buf (get-buffer-create "*sy-git-extents*"))
		bhelp khelp ext)
	    (delete-region (match-beginning 0) (match-end 0))
	    ;; skip uncommitted and blank lines
	    (unless (or (string= blamerev "0000000000")
			(string= blamerev "00000000")
			(zerop (length
				(buffer-substring
				 (point-at-bol) (point-at-eol)))))
	      (if (not (gethash blamerev hash))
		  ;; A new rev, set up extent
		  (progn
		    (puthash blamerev (point) hash)
		    (with-current-buffer buf
		      (erase-buffer)
		      (insert
		       (sy-git-run-string "show"
			 (split-string
			  (concat "--format=\"[Keys:s,l,b1,b2] [%h] %an "
				  "%ai%ncommit: %H%nAuthor: %an <%ae>%n"
				  "Date: %>(33)%ad%n%n %s\" --summary "
				  blamerev " |head -n8"))))
		      (goto-char (point-min))
		      (setq khelp (buffer-substring
				   (point-at-bol) (point-at-eol)))
		      (delete-region (point-at-bol) (point-at-eol))
		      (setq bhelp (buffer-string)))
		    (kill-buffer buf)
		    (setq ext (make-extent
			       (point-at-bol) (point-at-eol)))
		    (set-extent-properties
		     ext
		     `(mouse-face highlight keymap ,sy-git-blame-map
				  help-echo ,khelp balloon-help ,bhelp
				  blame t brev ,blamerev))
		    (set-extent-begin-glyph
		     ext
		     (make-glyph blamerev) 'outside-margin))
		;; A previous rev, just set extent parent
		(setq ext (make-extent (point-at-bol) (point-at-eol)))
		(set-extent-parent
		 ext (extent-at
		      (gethash blamerev hash) nil 'blame))))))
	(working-status t (substring (buffer-name) 12 -1))))))

(defun sy-git-blame ()
  "*Display git blame for the current file.

If the region is active the output will be for just the lines of the
file within the region."
  (interactive)
  (let ((gitcmd "blame")
	(cb (current-buffer))
	(gb (format "*GIT Blame::%s*"
		    (file-basename (buffer-file-name))))
	(args (list (file-basename (buffer-file-name))))
	(cmm major-mode)
	beg end)
    (when (region-active-p)
      (setq beg (line-number (region-beginning))
	    end (line-number (region-end))))
    (and beg end
	 (push (format "-L%d,%d" beg end) args))
    ;; We want -s for nicer, less verbose output and --root for
    ;; boundary commits
    (setq args (append '("-s" "--root" "--") args))
    (sy-git-run-buffer gb gitcmd args)
    (window-configuration-to-register ?G)
    (with-current-buffer gb
      (setq truncate-lines t)
      (funcall cmm)
      (sy-git-process-blame-buffer)
      (view-mode cb #'(lambda (gb)
        	      (kill-buffer gb)
        	      (jump-to-register ?G)
		      (clear-register ?G))))
    (pop-to-buffer gb)
    (shrink-window-if-larger-than-buffer)))

;;; log
(defun sy-git-log (opts)
  "*Display git log of current file.

With one prefix arg, OPTS, display the log for the entire repo.
With two prefix args, prompt for options to pass to git-log.

The default options used are: `--shortstat', except when two prefix
args are used and then the only options used are those the user
supplies."
  (interactive "P")
  (let ((cb (current-buffer))
	(gb "*GIT Log::%s*")
	(gitcmd "log")
	args)
    (case (car opts)
      ;; 1 prefix arg, log for whole repo
      (4 (setq args '("--shortstat")
	       gb (format gb "Whole Repo")))
      ;; 2 prefix args, prompt for options
      (16 (setq args (split-string (read-string "Git Log options: "))
		gb (format gb "Custom")))
      ;; default, show log of current file
      (otherwise (setq args (list "--shortstat"
				  (file-basename (buffer-file-name)))
		       gb (format gb (file-basename
				      (buffer-file-name))))))
    (sy-git-run-buffer gb gitcmd args)
    (window-configuration-to-register ?L)
    (with-current-buffer gb
      (set (make-local-variable 'font-lock-defaults)
	   '(sy-git-log-font-lock-keywords t t))
      (goto-char (point-min))
      (view-mode cb #'(lambda (gb)
		       (kill-buffer gb)
		       (jump-to-register ?L)
		       (clear-register ?L))))
    (pop-to-buffer gb)
    (shrink-window-if-larger-than-buffer)))

;;; add-log
(defun sy-git-add-log-entry (&optional newlog)
  "*A wrapper for `add-change-log-entry'.

Optional prefix argument, NEWLOG, forces a new log file to be
created. Use this if you need to start over.

To commit your changes with the log that this function creates use:

  git commit -F ++log

This function allows you to create git commit logs in a similar format
to that used by `add-change-log-entry'.  Some commented instructions
are added to the top of the log which you should either delete yourself
prior to committing, or have a hook do it automatically \(preferred\).

Hooks: 
2 hooks will make using this function a lot simpler and automatic.
A 'commit-msg' hook, and a 'post-commit' hook.  They reside in
'$repo/.git/hooks/'.

Example commit-msg:

  #!/bin/sh
  # Delete lines beginning with '#'.
  sed -i '/^#/d' \"$1\" || {
      echo >&2 Commit aborted by commit-msg hook
      exit 1
  }
  # End commit-msg

Example post-commit:

  #!/bin/sh
  # Delete log file after successful commit.
  LOG=$(git rev-parse --show-toplevel)/++log
  [ -f ${LOG} ] && rm -f ${LOG}
  # End post-commit

"
  (interactive "p")
  (let* ((topd (substring (sy-git-run-string "rev-parse"
			    "--show-toplevel") 0 -1))
	 (logfile (expand-file-name "++log" topd))
	 (hookd (paths-construct-path `(,topd ".git" "hooks")))
	 (msg-hook (expand-file-name "commit-msg" hookd))
	 (commit-hook (expand-file-name "post-commit" hookd))
	 (add-log-full-name (substring (sy-git-run-string "config"
					 "user.name") 0 -1))
	 (add-log-mailing-address (substring (sy-git-run-string "config"
					       "user.email") 0 -1))
	 (add-log-keep-changes-together t)
	 (header (concat
		  (format-time-string "%Y-%m-%d")
		  "  "
		  add-log-full-name "  <"
		  add-log-mailing-address ">\n"))
	 (newhead
	  (concat
	   "# Copyright -- to fool `add-change-log-entry'
### Instructions:
#
# Put your short one-line summary on the first blank line after these.
# Make sure that there is a blank line between your summary and the rest
# of your changes log.
#
###"
	   (if (sy-git-check-hook msg-hook)
	       "\n# Lines beginning with '#' will be automatically deleted."
	     "\n# You MUST delete these lines before committing.")
	   (unless (sy-git-check-hook commit-hook)
	     "\n# No post-commit hook. Manually delete this log after you commit.")
	   "\n###"))
	 )
    (and current-prefix-arg		; User wants to start over
	 (file-exists-p logfile)
	 (ignore-errors
	   (delete-file logfile)))
    ;; It is possible that the logfile is gone but the buffer is still
    ;; active
    (and (not (file-exists-p logfile))
	 (buffer-live-p (find-buffer-visiting logfile))
	 (kill-buffer (find-buffer-visiting logfile)))
    (with-current-buffer (find-file-noselect logfile)
      (save-excursion
	(goto-char (point-min))
	(when (re-search-forward "^# Copyright" (point-at-eol) t)
	  (replace-match "Copyright"))))
    (add-change-log-entry nil logfile t nil)
    (save-excursion
      (goto-char (point-min))
      (delete-matching-lines (regexp-quote header))
      (when (re-search-forward "^Copyright" (point-at-eol) t)
	(replace-match "# Copyright"))
      (goto-char (point-min))
      (unless (search-forward newhead nil t)
        (insert newhead "\n\n\n")))))

;;; keymap/mode/hook stuffs
(defvar sy-git-mode-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-name map 'sy-git-mode-map)
    (define-key map [(control ?x) ?G ?a] #'sy-git-add-log-entry)
    (define-key map [(control ?x) ?G ?=] #'sy-git-diff)
    (define-key map [(control ?x) ?G ?d] #'sy-git-diff)
    (define-key map [(control ?x) ?G ?e] #'sy-git-ediff)
    (define-key map [(control ?x) ?G ?l] #'sy-git-log)
    (define-key map [(control ?x) ?G ?b] #'sy-git-blame)
    map)
  "Keys for use in sy-git-mode.")

(define-minor-mode sy-git-mode
  "A minor mode to pretty much do nothing but hold keymap.
\\{sy-git-mode-map}."
  :lighter " SY/Git"
  :keymap 'sy-git-mode-map)

(defun sy-git-activate-maybe ()
  "Maybe turn on `sy-git-mode'."
  (and (eq (vc-file-getprop (buffer-file-name) 'vc-backend) 'GIT)
       (sy-git-mode)))

(add-hook 'find-file-hooks #'sy-git-activate-maybe 'append)

(provide 'sy-git)
;;; sy-git.el ends here