;;; km-magit.el --- Magit extensions

;; Copyright (C) 2012-2020 Kyle Meyer <kyle@kyleam.com>

;; Author: Kyle Meyer <kyle@kyleam.com>
;; URL: https://git.kyleam.com/emacs.d

;; This program 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 program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Code:

(require 'avy)
(require 'bug-reference)
(require 'cl-lib)
(require 'git-rebase)
(require 'km-util)
(require 'magit)
(require 'projectile)
(require 'seq)

;;;###autoload
(defun km/magit-status (&optional default-display)
  "Like `magit-status', but change the meaning of the prefix argument.
If DEFAULT-DISPLAY is non-nil, use
`magit-display-buffer-traditional' as the value for
`magit-display-buffer-function'."
  (interactive "P")
  (let ((magit-display-buffer-function (if default-display
                                           #'magit-display-buffer-traditional
                                         magit-display-buffer-function))
        (current-prefix-arg nil))
    (call-interactively #'magit-status)))

(defun km/magit-auto-commit ()
  "Commit all changes with \"auto\" commit message.
This can be useful for non-source code repos (e.g., Org mode note
files) or commiting incomplete changes that will be extended into
a proper commit."
  (interactive)
  (magit-run-git "commit" "--all" "--message=auto"))

(defun km/magit-update-or-auto-commit (&optional no-directory)
  (interactive "P")
  (let ((files (delete-dups (nconc (magit-unstaged-files)
                                   (magit-staged-files)))))
    (cl-case (length files)
      (0 (user-error "No tracked files with changes"))
      (1
       (magit-run-git "commit" "--all" "--message"
                      (concat (funcall (if no-directory
                                           #'file-name-nondirectory
                                         #'identity)
                                       (car files))
                              ": Update")))
      (t
       (km/magit-auto-commit)))))

;;;###autoload
(defun km/magit-show-commit-at-point (&optional choose-project)
  "Show the commit at point.
Prompt for the project name in any of these cases: 1) the prefix
argument CHOOSE-PROJECT is non-nil, 2) there is no current
project, or 3) an commit object for the hash at point doesn't
exist in the current project."
  (interactive "P")
  (if (save-excursion (skip-chars-backward "[[:xdigit:]]")
                      ;; Handle git-describe's *-g<hexsha>.
                      (when (and (equal (char-after (- (point) 1)) ?g)
                                 (equal (char-after (- (point) 2)) ?-))
                        (forward-char -2))
                      (looking-at (rx (or word-boundary "-g")
                                      (group (repeat 4 40 xdigit))
                                      word-boundary)))
      (let* ((hash (match-string-no-properties 1))
             (project
              (and (or choose-project
                       (not (projectile-project-p))
                       (not (magit-rev-verify (concat hash "^{commit}"))))
                   (completing-read "Project: "
                                    (projectile-relevant-known-projects))))
             (default-directory (or project default-directory)))
        (magit-show-commit hash (car (magit-diff-arguments))))
    (user-error "No hash found at point")))

;;;###autoload
(defun km/magit-commit-extend-with-file ()
  "Add the changes in the current file to the last commit."
  (interactive)
  (let ((file (or (magit-current-file)
                  (user-error "No current file"))))
    (cond ((magit-anything-staged-p)
           (user-error "There are already staged changes"))
          ((member file (nconc (magit-untracked-files)
                               (magit-unstaged-files)))
           (magit-with-toplevel (magit-stage-file file))
           (magit-commit-extend))
          (t
           (message "No changes to %s" file)))))

;;;###autoload
(defun km/magit-commit-wip-with-file ()
  "Make a WIP commit for the current file.
Unlike `magit-wip-*' commands, this commit is made to the current
branch."
  (interactive)
  (let ((file (or (magit-current-file)
                  (user-error "No current file"))))
    (cond ((magit-anything-staged-p)
           (user-error "There are already staged changes"))
          ((member file (nconc (magit-untracked-files)
                               (magit-unstaged-files)))
           (magit-with-toplevel (magit-stage-file file))
           (magit-run-git "commit" (concat "--message=WIP " file)))
          (t
           (message "No changes to %s" file)))))

(defun km/magit-ff-merge-upstream ()
  "Perform a fast-forward merge of the upstream branch.
\n(git merge --no-edit --ff-only <upstream>)"
  (interactive)
  (magit-merge-plain (or (magit-get-upstream-branch)
                         (user-error "No upstream branch"))
                     '("--ff-only")))

(defun km/magit-ff-merge-push ()
  "Perform a fast-forward merge of the push branch.
\n(git merge --no-edit --ff-only <push>)"
  (interactive)
  (magit-merge-plain (or (magit-get-push-branch)
                         (user-error "No push branch"))
                     '("--ff-only")))

;;;###autoload
(defun km/magit-merge-pull-message (rev)
  "Generate a PR merge message for REV.

The PR message can take two forms:

  1) Merge branch '<local>' [#<pr>]
  2) Merge pull request #<pr> from <remote>/<branch>

The first is used if REV is the name of a local branch, and the
second if REV is the name of a remote branch.

This assumes that you are pulling PRs into your 'refs/pull/'
namespace."
  (when-let ((name (magit-rev-name rev "refs/pull/*"))
             (pr (and (string-match "\\`pull/.+/\\([0-9]+\\)\\'" name)
                      (match-string 1 name))))
    (cond ((magit-local-branch-p rev)
           (format "Merge branch '%s' [#%s]" rev pr))
          ((magit-remote-branch-p rev)
           (format "Merge pull request #%s from %s" pr rev)))))

(defun km/magit-toggle-remote-skip (remote)
  "Toggle REMOTE.skipFetchAll value."
  (interactive (list (magit-read-remote "Remote")))
  (let* ((keys (list "remote" remote "skipFetchAll"))
         (skipped-p (apply #'magit-get-boolean keys)))
    (apply #'magit-set (and (not skipped-p) "true") keys)
    (message "%sabled %s" (if skipped-p "En" "Dis") remote)))

(defun km/magit-branch-rename (old new &optional force)
  "Like `magit-branch-rename', but use old branch as initial prompt."
  (interactive
   (let ((branch (magit-read-local-branch "Rename branch")))
     (list branch
           (magit-read-string-ns (format "Rename branch '%s' to" branch)
                                 branch)
           current-prefix-arg)))
  (unless (string= old new)
    (magit-run-git "branch" (if force "-M" "-m") old new)))

(defun km/magit-branch-copy (old new &optional force)
  (interactive
   (let ((branch (magit-read-local-branch "Copy branch")))
     (list branch
           (magit-read-string-ns (format "Copy branch '%s' to" branch)
                                 branch)
           current-prefix-arg)))
  (unless (string= old new)
    (magit-run-git "branch" (if force "-C" "-c") old new)))

(defun km/magit-checkout-master ()
  "Check out master branch.
\n(git checkout master)"
  (interactive)
  (magit-run-git "checkout" "master"))

(defun km/magit-checkout-detached (branch)
  "Check out commit pointed to by BRANCH."
  (interactive (list (magit-read-branch "Branch")))
  (magit-run-git "checkout" (concat branch "^0")))

(defun km/magit-branch-and-checkout-from-current (branch)
  "Create and check out BRANCH at the current branch.
This is equivalent to running `magit-branch-and-checkout' with
START-POINT set to the current branch.
\n(git checkout -b BRANCH)"
  (interactive (list (magit-read-string "Branch name" nil nil
                                        (when-let ((b (magit-get-current-branch)))
                                          (concat b "-tmp")))))
  (magit-run-git "checkout" "-b" branch))

(defun km/magit-branch--get-versions (branch suffix)
  (let ((version-re (rx (group (one-or-more digit)) string-end)))
    (delq nil
          (mapcar
           (lambda (s)
             (unless (string= branch s)
               (if (string-match version-re s)
                   (string-to-number
                    (match-string-no-properties 1 s))
                 (error "bug: version re should always match"))))
           (km/magit-branch-get-set branch suffix)))))

(defun km/magit-branch-checkpoint (&optional suffix)
  "Create a backup branch for the current branch.
Name it as '<current-branch>__cp<n>', where <n> is incremented
to form a refname that doesn't already exist.  With the prefix
argument SUFFIX, prompt for a suffix to use instead of
'v'."
  (interactive (list (and current-prefix-arg
                          (magit-read-string-ns "Backup suffix"))))
  (setq suffix (or suffix "cp"))
  (let* ((current (or (magit-get-current-branch)
                      (user-error "No current branch")))
         (versions (km/magit-branch--get-versions current suffix)))
    (magit-run-git
     "branch" "--copy"
     (format "%s__%s%d"
             current
             suffix
             (if (null versions) 1 (1+ (apply #'max versions)))))))

(defun km/magit-branch-version ()
  (interactive)
  (km/magit-branch-checkpoint "v"))

(defun km/magit-branch-archive (branches)
  "Move BRANCHES from refs/heads/ to refs/archive/."
  (interactive
   (list (or (magit-region-values 'branch)
             (list
              (magit-completing-read
               "Branch to archive" (magit-list-refnames "refs/heads")
               nil 'require nil nil
               (or (magit-branch-at-point) (magit-get-previous-branch)))))))
  (setq branches
        (mapcar (lambda (branch)
                  (cons
                   (replace-regexp-in-string "refs/heads/" "" branch)
                   (concat (and (not (string-prefix-p "refs/heads/" branch))
                                "refs/heads/")
                           branch)))
                branches))
  (pcase-dolist (`(,branch-short . ,branch-full) branches)
    (let ((new (replace-regexp-in-string "refs/heads/"
                                         "refs/archive/"
                                         branch-full)))
      (if (zerop (magit-call-git "update-ref" new branch-full))
          (progn
            (magit--rename-reflog-file branch-full new)
            (magit-call-git "branch" "-D" branch-short))
        (error "update-ref call failed"))))
  (magit-refresh)
  (message (concat "Archived "
                   (let ((num-branches (length branches)))
                     (if (= num-branches 1)
                         (caar branches)
                       (format "%d branches" num-branches))))))

(defun km/magit-match-versioned (member)
  (string-match (rx (group (one-or-more (not space)))
                    "__"
                    (group (one-or-more (not (any space digit))))
                    (one-or-more digit)
                    string-end)
                member))

(defun km/magit-branch-get-set (member &optional suffix)
  (let* ((rx-form (if (km/magit-match-versioned member)
                      `(and string-start
                            ,(match-string 1 member)
                            "__"
                            ,(match-string 2 member)
                            (one-or-more digit)
                            string-end)
                    `(and string-start
                          ,member
                          (zero-or-more
                           "__"
                           ,(or suffix '(one-or-more (not space)))
                           (one-or-more digit))
                          string-end)))
         (re (rx-to-string rx-form 'no-group)))
    (cl-remove-if-not (lambda (b) (string-match-p re b))
                      (magit-list-local-branch-names))))

(defun km/magit-branch--set-action (action fn member)
  (when-let ((branch-set (km/magit-branch-get-set member)))
    (when (y-or-n-p (concat "  "
                            (mapconcat #'identity branch-set "\n  ")
                            "\n" action "? "))
      (funcall fn branch-set))))

(defun km/magit-branch-delete-set (member)
  "Delete a set of branches identified by MEMBER."
  (interactive
   (list (magit-completing-read
          "Delete set with member" (magit-list-refnames "refs/heads")
          nil 'require nil nil
          (or (magit-branch-at-point) (magit-get-previous-branch)))))
  (km/magit-branch--set-action
   "Delete"
   (lambda (branch-set) (magit-run-git "branch" "-D" branch-set))
   member))

(defun km/magit-branch-archive-set (member)
  "Archive a set of branches identified by MEMBER."
  (interactive
   (list (magit-completing-read
          "Archive set with member" (magit-list-refnames "refs/heads")
          nil 'require nil nil
          (or (magit-branch-at-point) (magit-get-previous-branch)))))
  (km/magit-branch--set-action
   "Archive"
   #'km/magit-branch-archive
   member))

(defun km/magit-mode-bury-all-windows (&optional kill-buffer)
  "Run `magit-mode-quit-window' until no longer in Magit buffer."
  (interactive "P")
  (while (derived-mode-p 'magit-mode)
    (magit-mode-bury-buffer kill-buffer)))

(defun km/magit-log-select-guess-fixup-commit (&optional ntop)
  "Guess a commit based on fixup/squash commmits.
Consider NTOP commits (default is 5) when searching for 'fixup!'
and 'squash!' titles."
  (interactive (list (or (and current-prefix-arg
                              (prefix-numeric-value current-prefix-arg))
                         5)))
  (let ((msg-fn (lambda ()
                  (magit-rev-format
                   "%s" (oref (magit-current-section) value))))
        msgs commit-pts)
    (save-excursion
      (goto-char (point-min))
      ;; Get fixup and squash messages.
      (while (re-search-forward (rx " " (or "fixup" "squash") "! ")
                                (line-end-position (1+ ntop))
                                t)
        (let ((msg (funcall msg-fn)))
          (and msg
               (string-match (rx string-start (or "fixup" "squash") "! "
                                 (group (one-or-more not-newline)))
                             msg)
               (push (cons (match-string-no-properties 1 msg) (line-end-position))
                     msgs))))
      (when (not msgs)
        (user-error "No fixup or squash commits found"))
      ;; Find earliest commit.
      (pcase-dolist (`(,msg . ,search-beg) msgs)
        (goto-char search-beg)
        (catch 'found
          (while (search-forward msg nil t)
            (when (string= msg (funcall msg-fn))
              (push (line-beginning-position) commit-pts)
              (throw 'found t))))))
    (if commit-pts
        (goto-char (apply #'max commit-pts))
      (message "No matching commits found"))))

;;;###autoload
(defun km/magit-reset-file (rev file &optional checkout)
  "Reset FILE from revision REV.

If prefix argument CHECKOUT is non-nil, check out FILE from REV
instead.

\(git reset REV -- FILE)
\(git checkout REV -- FILE)"
  (interactive
   (let ((rev (magit-read-branch-or-commit "Revision" magit-buffer-revision)))
     (list rev (magit-read-file-from-rev rev "File") current-prefix-arg)))
  (magit-with-toplevel
    (magit-run-git (if checkout "checkout" "reset")
                   rev "--" file)))

;;;###autoload
(defun km/magit-pin-file (&optional other-rev)
  "Pin this file to the current revision.

Visit the current file and current revision with
`magit-find-file'.  Position point as in the original buffer.
This may not correspond to same content if text before point has
changed since the current commit.

If OTHER-REV is non-nil, prompt for another revision instead of
the current.  If buffer is already a revision buffer, then find
the working tree copy instead.  In both these cases, point may
not land in a reasonable location depending on how the content of
the file has changed."
  (interactive "P")
  (magit-with-toplevel
    (let* ((line (+ (if (bolp) 1 0) (count-lines 1 (point))))
           (col (current-column))
           (rev (cond (other-rev
                       (magit-read-branch-or-commit "Find file from revision"))
                      ((not magit-buffer-file-name)
                       (or (magit-get-current-branch)
                           (magit-rev-parse "HEAD")))))
           (fname (file-relative-name
                   (or (buffer-file-name (buffer-base-buffer))
                       magit-buffer-file-name
                       (user-error "Buffer not visiting file")))))
      (if rev (magit-find-file rev fname) (find-file fname))
      (goto-char (point-min))
      (forward-line (1- line))
      (move-to-column col))))

;;;###autoload
(defun km/magit-revfile-reset (&optional checkout)
  "Reset to revision from current revfile.
If CHECKOUT is non-nil, check out file instead."
  (interactive "P")
  (unless (and magit-buffer-refname magit-buffer-file-name)
    (user-error "Not in Magit revfile buffer"))
  (magit-with-toplevel
    (magit-run-git (if checkout "checkout" "reset")
                   magit-buffer-refname "--" magit-buffer-file-name)))

;;;###autoload
(defun km/magit-find-recently-changed-file (&optional n)
  "Find a file that changed from \"HEAD~N..HEAD\".
N defaults to 20."
  (interactive (list (and current-prefix-arg
                          (prefix-numeric-value current-prefix-arg))))
  (setq n (or n 10))
  (magit-with-toplevel
    (find-file (magit-completing-read
                "File"
                (magit-changed-files (format "HEAD~%s..HEAD" n))
                nil t))))

(defun km/magit-find-commit-file (commit)
  "Find a file that changed in COMMIT."
  (interactive (list (or (magit-branch-or-commit-at-point)
                         magit-buffer-revision
                         (magit-read-branch-or-commit "Commit"))))
  (let ((files (magit-changed-files (format "%s~..%s" commit commit))))
    (find-file
     (cl-case (length files)
       (0 (user-error "No changed files in %s" commit))
       (1 (car files))
       (t (magit-completing-read "File" files nil t))))))

(defun km/magit-insert-staged-file (&optional no-directory)
  "Select a staged file to insert.

This is useful for referring to file names in commit messages.
By default, the path for the file name is relative to the top
directory of the repository.  Remove the directory component from
the file name if NO-DIRECTORY is non-nil.

If there are no staged files, look instead at files that changed
in HEAD.  These rules will usually offer the files of interest
while commiting, but this is not the case if you are amending a
commit with the \"--only\" flag and have staged files (i.e., this
command will still offer the staged files)."
  (interactive "P")
  (magit-with-toplevel
    (let* ((files (or (magit-staged-files)
                      (magit-changed-files "HEAD^..HEAD")))
           (file (cl-case (length files)
                   (1 (car files))
                   (0 (error "No files found"))
                   (t
                    (completing-read "Staged file: " files nil t)))))
      (insert (if no-directory (file-name-nondirectory file) file)))))

(defun km/magit-shorten-hash (hash &optional n)
  (magit-rev-parse (format "--short=%s" (or n (magit-abbrev-length))) hash))

;;;###autoload
(defun km/magit-shorten-hash-at-point (&optional n)
  "Shorten the hash at point to N characters.

N defaults to `magit-abbrev-length'.  If the commit belongs to
the current repo and the hash is ambiguous, the hash is extended
as needed.

To explicitly set the hash length, use a numeric prefix
argument."
  (interactive (list (or (and current-prefix-arg
                              (prefix-numeric-value current-prefix-arg))
                         (magit-abbrev-length))))
  (cond
   ((< n 4)
    (user-error "Hash must be at least 4 characters"))
   ((>= n 40)
    (user-error "Full hashes are 40 characters"))
   ((> n 30)
    (message "That doesn't seem incredibly useful, but OK")))
  (let ((offset (- (skip-chars-backward "[[:xdigit:]]"))))
    (if (looking-at "\\b[[:xdigit:]]\\{5,40\\}\\b")
        (let ((hash-len (- (match-end 0) (match-beginning 0)))
              (hash (match-string 0)))
          (when (< hash-len n)
            (user-error "Desired hash length is greater than current"))
          (replace-match (or (km/magit-shorten-hash hash n)
                             ;; We're not in a repo.
                             (substring hash 0 n))
                         'fixedcase)
          (when (< offset n)
            (skip-chars-backward "[[:xdigit:]]")
            (goto-char (+ (point) offset))))
      (goto-char (+ (point) offset))
      (user-error "No hash found at point"))))

(defun km/magit-describe (rev)
  "Run 'git describe' on REV."
  (interactive
   (list (or (when-let ((section (magit-current-section)))
               (cond
                ((memq (oref section type) '(commit branch))
                 (oref section value))
                ((derived-mode-p 'magit-revision-mode)
                 magit-buffer-revision)))
             (magit-read-branch-or-commit "Revision"))))
  (when-let ((desc (and rev (magit-git-string "describe" rev))))
    (kill-new (message "%s" desc))))

(defun km/magit-rev-ancestor-p (rev-a rev-b)
  "Report whether REV-A is the ancestor of REV-B."
  (interactive
   (let* ((rev-a (magit-read-branch-or-commit "Ancestor candidate")))
     (list rev-a (magit-read-other-branch-or-commit
                  (format "Is %s the ancestor of" rev-a)
                  rev-a))))
  (message "%s is %san ancestor of %s" rev-a
           (if (magit-git-success "merge-base" "--is-ancestor"
                                  rev-a rev-b)
               "" "NOT ")
           rev-b))

(defun km/magit-refs-toggle-tags ()
  "Toggle showing tags in `magit-refs-mode'.
This only affects the current buffer and is useful if you do not
show tags by default."
  (interactive)
  (let ((pos (point)))
    (if (memq 'magit-insert-tags magit-refs-sections-hook)
        (kill-local-variable 'magit-refs-sections-hook)
      (setq-local magit-refs-sections-hook
                  (append magit-refs-sections-hook
                          '(magit-insert-tags))))
    (magit-refresh-buffer)
    (goto-char pos)))

(defun km/magit-revision-insert-related-refs ()
  (interactive)
  (let ((magit-revision-insert-related-refs t))
    (magit-refresh)))

(defun km/magit-log-flip-revs ()
  "Swap the two revisions in a log's range."
  (interactive)
  (let ((range (car magit-buffer-revisions)))
    (if (and range
             (derived-mode-p 'magit-log-mode)
             (string-match magit-range-re range))
        (progn
          (setf (car magit-buffer-revisions)
                (concat (match-string 3 range)
                        (match-string 2 range)
                        (match-string 1 range)))
          (magit-refresh))
      (user-error "No range to swap"))))

(defun km/magit-cherry-flip-revs ()
  (interactive)
  (let ((r magit-buffer-refname)
        (u magit-buffer-upstream))
    (setq magit-buffer-upstream r)
    (setq magit-buffer-refname u))
  (magit-refresh))

(defun km/magit-flip-revs ()
  (interactive)
  (cond ((derived-mode-p 'magit-diff-mode)
         (call-interactively #'magit-diff-flip-revs))
        ((derived-mode-p 'magit-log-mode)
         (call-interactively #'km/magit-log-flip-revs))
        ((derived-mode-p 'magit-cherry-mode)
         (call-interactively #'km/magit-cherry-flip-revs))))

(defun km/magit-log-modify-range ()
  "Change the range for the current log buffer."
  (interactive)
  (unless (derived-mode-p 'magit-log-mode)
    (user-error "Not in log buffer"))
  (setf (car magit-buffer-revisions)
        (read-string "Range: " (car magit-buffer-revisions)))
  (magit-refresh))

(defun km/magit-cherry-insert-in-upstream ()
  (insert ?\n)
  (magit-insert-section (cherries)
    (magit-insert-heading "In upstream:")
    (magit-git-wash (apply-partially 'magit-log-wash-log 'cherry)
      "cherry" "-v" "--abbrev"
      magit-buffer-refname magit-buffer-upstream)))

(defun km/magit-cherry-toggle-upstream-section ()
  (interactive)
  (let ((pos (point)))
    (if (memq #'km/magit-cherry-insert-in-upstream magit-cherry-sections-hook)
        (kill-local-variable 'magit-cherry-sections-hook)
      (setq-local magit-cherry-sections-hook
                  (append magit-cherry-sections-hook
                          '(km/magit-cherry-insert-in-upstream))))
    (magit-refresh-buffer)
    (goto-char pos)))

(defun km/magit-diff-visit-file (&optional prev-rev other-window)
  "Like `magit-diff-visit-file', but change REV^ visiting behavior.

If prefix argument PREV-REV is non-nil, visit the file for REV^
instead of REV.  `magit-diff-visit-previous-blob' is
unconditionally disabled.  If not in `magit-revision-mode', the
prefix argument has no effect.

OTHER-WINDOW corresponds to `magit-diff-visit-file's OTHER-WINDOW
argument.  Interactively, this can be accessed using the command
`km/magit-diff-visit-file-other-window'."
  (interactive "P")
  (let ((magit-diff-visit-previous-blob nil)
        (magit-buffer-revision (if (and prev-rev
                                        (derived-mode-p 'magit-revision-mode))
                                   (concat magit-buffer-revision "^")
                                 magit-buffer-revision))
        (current-prefix-arg (and other-window (list 4))))
    (call-interactively #'magit-diff-visit-file)))

(defun km/magit-diff-visit-file-other-window (&optional prev-rev)
  (interactive "P")
  (km/magit-diff-visit-file prev-rev t))

(defun km/magit-log-current (&optional args files)
  "Like `magit-log-current', but if head is detached, use \"HEAD\"."
  (interactive (magit-log-arguments))
  (magit-log-current (list (or (magit-get-current-branch) "HEAD"))
                     args files))

(defun km/magit-log-dwim (&optional args files)
  (interactive (magit-log-arguments))
  (let ((range
         (or (and (use-region-p)
                  (prog1 (buffer-substring-no-properties
                          (region-beginning) (region-end))
                    (deactivate-mark)))
             (magit-section-case
               ((unpushed unpulled)
                (oref it value))
               (tag
                (concat (oref it value) ".."))
               (branch
                (let ((current (magit-get-current-branch))
                      (atpoint (oref it value))
                      (upstream (magit-get-upstream-branch))
                      (push (magit-get-push-branch)))
                  (cond ((equal atpoint current)
                         (and upstream (concat upstream "..")))
                        ((equal atpoint push)
                         (concat push ".."))
                        (t
                         (concat ".." atpoint))))))
             (when-let ((rev (and (derived-mode-p 'magit-revision-mode)
                                  magit-buffer-revision)))
               (and (magit-rev-verify (concat rev "^2"))
                    (concat rev "^-1"))))))
    (if range
        (magit-log-setup-buffer (list range) args files)
      (call-interactively #'magit-log-current))))

;;;###autoload
(defun km/magit-log-occurrence (beg end)
  "Run `git log -S<content (BEG..END)> HEAD'."
  (interactive "r")
  (with-current-buffer
      (magit-setup-buffer #'magit-log-mode nil
        (magit-buffer-revisions (list "HEAD"))
        (magit-buffer-log-args
         (cons (format "-S%s" (buffer-substring-no-properties beg end))
               (cl-delete "-S" (car (magit-log-arguments))
                          :test 'string-prefix-p)))
        (magit-buffer-log-files nil))
    (magit-log-goto-same-commit)
    (current-buffer)))

;;;###autoload
(defun km/magit-log-topic (branch)
  "Run `git log --reverse [...] @{upstream}..BRANCH'."
  (interactive (list (magit-read-branch "Topic branch")))
  (with-current-buffer
      (magit-log-setup-buffer
       (list (format "%s..%s"
                     (or (let ((upstream (concat branch "@{u}")))
                           (and (magit-rev-verify upstream)
                                upstream))
                         "master")
                     branch))
       (let ((args (car (magit-log-arguments))))
         (cl-pushnew "--reverse" args)
         args)
       nil t)
    ;; Could avoid `magit-log-setup-buffer', but this is good enough.
    (goto-char (point-min))))

(defun km/magit-cherry-dwim ()
  (interactive)
  (pcase-let ((`(,head . ,upstream)
               (if (eq major-mode 'magit-log-mode)
                   (let ((range magit-buffer-revisions))
                     (and range
                          (string-match magit-range-re range)
                          (cons (match-string 3 range)
                                (match-string 1 range))))
                 (let ((section (magit-current-section))
                       (current-branch (magit-get-current-branch)))
                   (pcase (list (oref section type)
                                (oref section value))
                     (`(unpushed "@{upstream}..")
                      (cons current-branch (magit-get-upstream-branch)))
                     (`(unpulled "..@{upstream}")
                      (cons (magit-get-upstream-branch) current-branch))
                     ;; Don't try to match "@{push}" because
                     ;; `magit-insert-unpulled-from-pushremote' and
                     ;; `magit-insert-unpulled-from-pushremote' avoid it to
                     ;; be compatible with all push.default settings.
                     (`(unpushed ,_)
                      (cons current-branch (magit-get-push-branch)))
                     (`(unpulled ,_)
                      (cons (magit-get-push-branch) current-branch)))))))
    (if (and head upstream)
        (magit-cherry head upstream)
      (call-interactively #'magit-cherry))))

(defun km/magit--insert-count-lines (rev counts)
  (pcase-let ((`(,n-behind ,n-ahead) counts))
    (when (> n-ahead 0)
      (magit-insert-section (unpushed (concat rev ".."))
        (magit-insert-heading
          (format "%3s ahead of %s"
                  (propertize (number-to-string n-ahead)
                              'face 'magit-diffstat-added)
                  rev))))
    (when (> n-behind 0)
      (magit-insert-section (unpulled (concat ".." rev))
        (magit-insert-heading
          (format "%3s behind   %s"
                  (propertize (number-to-string n-behind)
                              'face 'magit-diffstat-removed)
                  rev))))))

(defun km/magit-insert-remote-counts ()
  "Insert a section showing number of unpushed and unpulled commits.

This function is a lightweight replacement of four
`magit-status-sections-hook' functions:
`magit-insert-unpulled-from-upstream',
`magit-insert-unpulled-from-pushremote',
`magit-insert-unpushed-to-upstream', and
`magit-insert-unpushed-to-pushremote'.

Unlike the above functions, this function does not insert a log
of unpulled or unpushed commits, but instead inserts a combined
section that only reports the number of commits in each
category."
  (when (magit-get-current-branch)
    (let* ((up-counts (and (magit-git-success "rev-parse" "@{upstream}")
                           (magit-rev-diff-count "@{upstream}" "")))
           ;; Unlike `magit-insert-unpushed-to-pushremote' and
           ;; `magit-insert-unpulled-from-pushremote', just use
           ;; "@{push}".  This drops support for the push-remote if
           ;; push.default isn't set to a compatible value.  See
           ;; Magit's 6505f4cd.
           (pu-counts (and (magit-git-success "rev-parse" "@{push}")
                           (magit-rev-diff-count "@{push}" "")))
           (up-any (and up-counts (or (> (car up-counts) 0)
                                      (> (cadr up-counts) 0))))
           (pu-any (and pu-counts (or (> (car pu-counts) 0)
                                      (> (cadr pu-counts) 0)))))
      (when (or up-any pu-any)
        (magit-insert-section (remote-counts)
          (magit-insert-heading "Remote counts")
          (when up-any
            (km/magit--insert-count-lines "@{upstream}" up-counts))
          (when (and pu-any (not (and up-any
                                      (equal (magit-rev-name "@{upstream}")
                                             (magit-rev-name "@{push}")))))
            (km/magit--insert-count-lines "@{push}" pu-counts)))))))

(magit-define-section-jumper magit-jump-to-remote-counts
  "Remote counts" remote-counts)

(defun km/magit-add-pull-refspec-to-origin ()
  "Configure repository to pull refs/pull/*/head from 'origin'."
  (interactive)
  (let* ((keys (list "remote" "origin" "fetch"))
         (existing (apply #'magit-get-all keys))
         (rs "+refs/pull/*/head:refs/pull/origin/*"))
    (unless (member rs existing)
      (apply #'magit-set-all
             (append existing (list rs))
             keys))))

(defun km/magit-list-containing-tags (rev)
  (interactive (list (magit-read-branch-or-commit "Revision")))
  (let ((magit-process-popup-time 0))
    (magit-run-git-async "for-each-ref" (format "--contains=%s" rev)
                         "--sort=v:refname" "refs/tags")))

(defun km/magit-patch-create-from-upstream (&optional args)
  (interactive (list (transient-args 'magit-patch-create)))
  (if-let ((upstream (magit-get-upstream-branch)))
      (apply #'magit-run-git "format-patch" upstream args)
    (user-error "No upstream branch")))

(defun km/magit-tweak-patch-series-summary ()
  "Restyle \"My Name (N):\" heading.
Drop author for single author series by `user-full-name',
appending [M/N] to each entry."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (search-forward "*** BLURB HERE ***")
    (let ((author-regexp (rx line-start word (zero-or-more not-newline)
                             "(" (one-or-more digit) "):" line-end)))
      ;; Don't proceed if there looks to be more than one author.
      (unless (and (re-search-forward author-regexp nil t)
                   (re-search-forward author-regexp nil t))
        (let ((buffer-read-only nil))
          (save-excursion
            (goto-char (point-min))
            (when-let ((total (and (re-search-forward
                                    (rx line-start (eval user-full-name) " ("
                                        (group (one-or-more digit))
                                        "):" line-end)
                                    nil t)
                                   (match-string 1)))
                       (prefix (format "[%%%dd/%s] " (length total) total))
                       (idx 1))
              (delete-region (line-beginning-position) (1+ (line-end-position)))
              (while (and (not (eobp))
                          (not (looking-at-p "^$")))
                (goto-char (line-beginning-position))
                (skip-chars-forward " ")
                (insert (format prefix idx))
                (cl-incf idx)
                (forward-line)))))))))

(defun km/magit-patch-create-series (&optional args)
  (interactive (list (transient-args 'magit-patch-create)))
  ;; Note: I never use a pathspec when formatting a patch, so I'm
  ;; being lazy here and not doing proper processing of file
  ;; arguments.  The string operations below will fail if files are
  ;; specified.
  (when (magit-anything-modified-p t)
    (user-error "There are uncommitted changes"))
  (setq args (seq-remove
              (lambda (a) (string-match-p "\\`--base=" a))
              args))
  (let* ((current (magit-get-current-branch))
         (upstream (or (magit-get-upstream-branch current)
                       (user-error "No upstream branch")))
         (patch-branch (concat "patches/" current)))
    (if (not (magit-local-branch-p patch-branch))
        (magit-branch-and-checkout patch-branch current)
      (magit-update-ref (concat "refs/heads/" patch-branch)
                        (concat "reset: moving back to " current)
                        current)
      (magit-branch-checkout patch-branch))
    (apply #'magit-run-git "format-patch"
           upstream (concat "--base=" upstream) args)
    (let* ((patches (or (seq-filter
                         (lambda (f) (string-suffix-p ".patch" f))
                         (magit-untracked-files))
                        (error "There should be patches")))
           (cover (seq-find
                   (lambda (f)
                     (string-match-p
                      (rx string-start
                          (zero-or-one "v" (one-or-more digit) "-")
                          (one-or-more "0") "-")
                      f))
                   patches)))
      (magit-call-git "add" patches)
      (magit-run-git "commit" "-mpatches")
      (when cover
        (with-temp-buffer
          (insert-file-contents cover)
          (km/magit-tweak-patch-series-summary)
          (write-region nil nil cover))
        (magit-call-git "commit" "-mtweak cover" "--" cover))
      (find-file-other-window (or cover (car patches)))
      (goto-char (point-min))
      (re-search-forward
       (if cover
           (rx "Subject: ["
               (zero-or-more (not (any "]" "\n")))
               "PATCH"
               (zero-or-more (not (any "]" "\n")))
               "]" (one-or-more space))
         "^---$"))
      (setq buffer-read-only nil)
      (auto-fill-mode 1)
      (flyspell-mode 1))))

;;;###autoload
(defun km/magit-dump-diff-to-buffer (&optional arg)
  "Like `magit-patch-save', but dump output to a buffer."
  ;; Note: Nearly all of this is just copied from `magit-patch-save'.
  (interactive "P")
  (require 'magit-patch)
  (unless (derived-mode-p 'magit-diff-mode)
    (user-error "Only diff buffers can be saved as patches"))
  (let ((rev magit-buffer-range)
        (typearg magit-buffer-typearg)
        (args magit-buffer-diff-args)
        (files magit-buffer-diff-files))
    (cond ((eq magit-patch-save-arguments 'buffer)
           (when arg
             (setq args nil)))
          ((eq (car-safe magit-patch-save-arguments) 'exclude)
           (unless arg
             (setq args (-difference args (cdr magit-patch-save-arguments)))))
          ((not arg)
           (setq args magit-patch-save-arguments)))
    (with-current-buffer
        (generate-new-buffer
         (replace-regexp-in-string
          "^\\*" "*diff dump: "
          (funcall magit-generate-buffer-name-function
                   major-mode (magit-buffer-value))))
      (magit-git-insert "diff" rev "-p" typearg args "--" files)
      (pop-to-buffer (current-buffer)))))

;;;###autoload
(defun km/magit-dump-patch-to-buffer ()
  (interactive)
  (require 'magit-patch)
  (unless (derived-mode-p 'magit-revision-mode)
    (user-error "Not revision buffer"))
  (let ((rev magit-buffer-revision))
    (with-current-buffer
        (generate-new-buffer
         (replace-regexp-in-string
          "^\\*" "*patch dump: "
          (funcall magit-generate-buffer-name-function
                   major-mode (magit-buffer-value))))
      (magit-git-insert "format-patch" "--stdout" (concat rev "^-1"))
      (pop-to-buffer (current-buffer)))))


;;; Copy functions

(defvar km/magit-copy-functions
  '(km/magit-copy-commit-summary-from-header
    km/magit-copy-commit-message
    km/magit-copy-region-commits
    km/magit-copy-region-hunk
    km/magit-copy-hunk)
  "Functions tried by `km/magit-copy-as-kill'.
These will be given one argument (the current prefix value) and
should succeed by copying and returning non-nil or fail by
returning nil.")

;;;###autoload
(defun km/magit-copy-commit-summary (commit)
  "Copy a citation for the COMMIT at point.
Format the reference as '<hash>, (<subject>, <date>)'.  If there
is no commit at point or with a prefix argument, prompt for
COMMIT."
  (interactive
   (let ((atpoint (or (and magit-blame-mode (oref (magit-current-blame-chunk) orig-rev))
                      (magit-branch-or-commit-at-point)
                      (magit-tag-at-point))))
     (list (or (and (not current-prefix-arg) atpoint)
               (magit-read-branch-or-commit "Commit" atpoint)))))
  (if (magit-rev-verify (concat commit "^{commit}"))
      (kill-new
       (message
        "%s"
        (replace-regexp-in-string
         ;; Drop trailing period, if any, from the subject.
         (rx (group ".") ", "
             (repeat 4 digit) "-" (repeat 2 digit) "-" (repeat 2 digit)
             ")" string-end)
         ""
         ;; Using `magit-git-string' instead of `magit-rev-format' to
         ;; pass --date flag.
         (magit-git-string "show" "-s" "--date=short" "--format=reference"
                           commit "--")
         t t 1)))
    (user-error "%s does not exist" commit)))

(defun km/magit-copy-commit-summary-from-header (&optional _)
  (when (magit-section-match 'headers)
    (km/magit-copy-commit-summary magit-buffer-revision)))

(defun km/magit-copy-region-commits (&optional read-separator)
  (when-let ((commit (magit-region-values 'commit)))
    (deactivate-mark)
    (kill-new
     (message
      "%s"
      (mapconcat #'identity
                 commit
                 (if read-separator (read-string "Separator: ") ", "))))))

(defun km/magit-copy--truncated-message (msg)
  (let ((msg-lines (split-string msg "[\n\r]+" 'omit-nulls)))
    (message "%s" (cl-case (length msg-lines)
                    (0 msg)
                    (1 (car msg-lines))
                    (t (concat (car msg-lines) "[...]"))))))

(defun km/magit-copy-commit-message (&optional _)
  (when (magit-section-match 'commit-message)
    (let* ((section (magit-current-section))
           (msg (buffer-substring-no-properties (oref section start)
                                                (oref section end))))
      (kill-new msg)
      (km/magit-copy--truncated-message msg))))

(defun km/magit-copy-region-hunk (&optional no-column)
  (when (and (magit-section-internal-region-p)
             (magit-section-match 'hunk))
    (deactivate-mark)
    (let ((text (buffer-substring-no-properties
                 (region-beginning) (region-end))))
      (setq text (if no-column
                     (replace-regexp-in-string "^[ \\+\\-]" "" text)
                   text))
      (kill-new text)
      (km/magit-copy--truncated-message text))))

(defun km/magit-copy-hunk (&optional _)
  (when (magit-section-match 'hunk)
    (let ((section (magit-current-section)))
      (kill-new (buffer-substring-no-properties
                 (save-excursion (goto-char (oref section start))
                                 (1+ (point-at-eol)))
                 (oref section end)))
      (message "Copied hunk: %s" (oref section value)))))

(defun km/magit-copy-as-kill ()
  "Try `km/magit-copy-functions' before calling `magit-copy-section-value'.
With a prefix argument of -1, always call `magit-copy-section-value'
Otherwise, the current prefix argument is passed to each hook
function."
  (interactive)
  (or (and (/= (prefix-numeric-value current-prefix-arg) -1)
           (run-hook-with-args-until-success
            'km/magit-copy-functions current-prefix-arg))
      (magit-copy-section-value nil)))


;;; GitHub links

(defun km/magit-github-url-from-bugref ()
  ;; `bug-reference-url-format' may be defined in an untracked
  ;; `.dir-locals.el`, so do this from the main worktree.
  (when-let ((wtree (caar (magit-list-worktrees)))
             (url
              (with-temp-buffer
                (let ((default-directory (file-name-as-directory wtree)))
                  (hack-dir-local-variables-non-file-buffer)
                  bug-reference-url-format))))
    (and url
         (string-match "\\`https://github.com/[^/]+/[^/]+" url)
         (match-string 0 url))))

(defun km/magit-github-url-from-origin ()
  (when-let ((origin (magit-get "remote.origin.url")))
    (and (string-match (rx "git@github.com:"
                           (group (one-or-more (not (any "."))))
                           (zero-or-one ".git"))
                       origin)
         (concat "https://github.com/" (match-string 1 origin)))))

(defun km/magit-github-url ()
  (or (km/magit-github-url-from-bugref)
      (km/magit-github-url-from-origin)))

(defun km/magit-github-file-link ()
  (let ((ln (lambda (loc)
              (save-restriction
                (1+ (count-lines (point-min) loc))))))
    (when-let ((rev (or magit-buffer-revision
                        (magit-rev-parse "HEAD")))
               (fname (magit-file-relative-name))
               (lines (if (use-region-p)
                          (prog1 (format "%s-L%s"
                                         (funcall ln (region-beginning))
                                         (1- (funcall ln (region-end))))
                            (deactivate-mark))
                        (funcall ln (point)))))
      (format "%s/blob/%s/%s#L%s"
              (or (km/magit-github-url) "")
              rev fname lines))))

(defun km/magit-github-commit-link ()
  (when-let ((rev (or (and (eq major-mode 'magit-revision-mode)
                           magit-buffer-revision)
                      (and (derived-mode-p 'magit-mode)
                           (let ((sec (magit-current-section)))
                             (and (eq (oref sec type) 'commit)
                                  (oref sec value)))))))
    (format "%s/commit/%s"
            (or (km/magit-github-url) "")
            (magit-rev-parse rev))))

(defun km/magit-github-diff-link ()
  (when (derived-mode-p 'magit-diff-mode)
    (when (and magit-buffer-range
               (string-match magit-range-re magit-buffer-range))
      ;; This always converts to commits IDs.  It could try to map
      ;; refnames to the appropriate GitHub link (including remotes
      ;; to forks), but I don't have much need for it at the moment.
      (let ((rev1 (magit-rev-parse (match-string 1 magit-buffer-range)))
            (rev2 (magit-rev-parse (match-string 3 magit-buffer-range))))
        (format "%s/compare/%s...%s"
                (or (km/magit-github-url) "")
                rev1 rev2)))))

(defun km/magit-copy-github-link ()
  "Copy a GitHub link from the current file or Magit buffer.

Note: There are probably a number of packages that provide more
complete support for this sort of functionality.  This is just a
simple solution that works for me."
  (interactive)
  (kill-new
   (message "%s"
            (or (km/magit-github-file-link)
                (km/magit-github-commit-link)
                (km/magit-github-diff-link)
                (user-error "Don't know how to make a link from here")))))

(defun km/magit-open-github-pr ()
  (interactive)
  (browse-url
   (format "%s/compare/master...kyleam:%s?expand=1"
           (or (km/magit-github-url)
               (user-error "Couldn't determine GitHub URL"))
           (let ((current (magit-get-current-branch)))
             (if (member (concat "kyleam/" current)
                         (magit-list-refnames "refs/remotes/kyleam"))
                 current
               (magit-read-remote-branch "PR branch" "kyleam"))))))


;;; Git Rebase mode

(defun km/git-rebase--clean-subject (s)
  (replace-regexp-in-string
   (concat "\\`" (regexp-opt '("fixup! " "squash! "))) "" s))

(defmacro km/git-rebase-on-each (end &rest body)
  "Run BODY on each commit action line from point to END.
The current line will be bound to `rebase-line'.  BODY should
restore point to the current line."
  (declare (indent 1) (debug (form body)))
  (let ((bound (cl-gensym)))
    `(let ((,bound ,end)
           rebase-line)
       (while (and (setq rebase-line (git-rebase-current-line))
                   (not (or (and ,bound (> (point) ,bound))
                            (eobp))))
         (when (oref rebase-line action-type)
           ,@body)
         (forward-line)))))

(defun km/git-rebase-fixup-duplicates (beg end &optional squash)
  "Mark sequential lines with same subject as fixup commits.
With an active region, limit to lines that the region touches.
If prefix argument SQUASH is non-nil, mark for squashing instead
of fixing up."
  (interactive (nconc (km/region-or-buffer-line-bounds)
                      (list current-prefix-arg)))
  (unless (markerp end)
    (setq end (copy-marker end)))
  (save-excursion
    (goto-char beg)
    (let ((prefix (if squash "squash" "fixup"))
          line prev-subj subj)
      (km/git-rebase-on-each end
        (with-slots (action-type target trailer) rebase-line
          (if (eq action-type 'commit)
              (progn
                (setq subj (km/git-rebase--clean-subject trailer))
                (when (equal subj prev-subj)
                  (let ((inhibit-read-only t))
                    (delete-region (point-at-bol) (point-at-eol))
                    (insert prefix " " target " " subj)))
                (setq prev-subj subj))
            (setq prev-subj nil)
            (setq subj nil)))))))

(defun km/git-rebase-join-repeats (beg end &optional arg)
  "Move repeated subject lines after line of first occurrence.

If region is active, limit to lines that the region touches.

Warning: This will happily cross --rebase-merges branch points.

By default, repeated lines are marked for fixing up.
With a \\[universal-argument], mark them for squashing instead.
With a \\[universal-argument] \\[universal-argument], do not mark them at all."
  (interactive (nconc (km/region-or-buffer-line-bounds)
                      (list current-prefix-arg)))
  (save-excursion
    (goto-char beg)
    (let (roots dups)
      (km/git-rebase-on-each end
        (when (eq (oref rebase-line action-type) 'commit)
          (let ((subj (km/git-rebase--clean-subject
                       (oref rebase-line trailer))))
            (push (list subj rebase-line (copy-marker (point-at-eol)))
                  (if (assoc subj roots) dups roots)))))
      (pcase-dolist (`(,subj ,line ,marker) dups)
        (goto-char (1+ (nth 2 (assoc subj roots))))
        (let ((inhibit-read-only t))
          (with-slots (action target trailer) line
            (insert action " " target " " trailer "\n"))
          (goto-char marker)
          (delete-region (point-at-bol) (1+ (point-at-eol)))))
      (unless (equal arg (list 16))
        (km/git-rebase-fixup-duplicates beg end (equal arg (list 4)))))))

(defun km/git-rebase--move-line (new-pos)
  (let ((ln-beg (point-at-bol))
        (ln-end (1+ (point-at-eol))))
    (goto-char new-pos)
    (let ((inhibit-read-only t))
      (insert (delete-and-extract-region ln-beg ln-end)))
    (forward-line -1)))

(defun km/git-rebase--collect-lines ()
  (let ((current-ln (point-at-bol))
        pt candidates)
    (save-excursion
      (save-restriction
        (narrow-to-region (window-start) (window-end))
        (goto-char (point-min))
        (km/git-rebase-on-each nil
          (when (eq (oref rebase-line action-type) 'commit)
            (setq pt (point-at-bol))
            (unless (= pt current-ln)
              (push pt candidates))))
        ;; Offer first empty line after last commit as candidate so
        ;; the current commit can be moved to the end.
        (unless (> current-ln (car candidates))
          (goto-char (car candidates))
          (push (1+ (point-at-eol)) candidates))
        (nreverse candidates)))))

(defun km/git-rebase-move-commit ()
  "Move the commit on current line above selected line."
  (interactive)
  (unless (eq (oref (git-rebase-current-line) action-type)
              'commit)
    (user-error "Not on commit line"))
  (avy-with km/git-rebase-move-commit
    (setq avy-action #'km/git-rebase--move-line)
    (avy-process
     (km/git-rebase--collect-lines)
     #'avy--overlay-post)))

(provide 'km-magit)
;;; km-magit.el ends here