;;; vc-timemachine.el --- Walk through revisions of a file  -*- lexical-binding:t -*-

;; Copyright (C) 2023 Free Software Foundation, Inc.

;; 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/>.

;;; Credits:
;;
;;  Peter Stiernström - wrote the original, git-only version
;;  John Yates        - refactored Peter's code for the VC environment

;;; Commentary:
;;
;; A timemachine buffer is a sliding read-only window over the distinct
;; revisions of a single file on a VCS branch.  To create a timemachine:
;;
;;    (vc-prefix-map ",")   vc-tm-revision-head
;;
;; Timemachine implements prefix-free minor mode vc-tm-mode:
;;
;;    "," . vc-tm-revision-head
;;    "~" . vc-tm-revision-select
;;    "g" . vc-tm-revision-i
;;    "n" . vc-tm-revision-next
;;    "p" . vc-tm-revision-previous
;;    "q" . vc-tm-quit
;;    "s" . vc-tm-revision-complete-subject
;;    "w" . vc-tm-abbreviated-revision-to-kill-ring
;;    "W" . vc-tm-revision-to-kill-ring
;;
;; To support timemachine functionality a VCS backend needs to implement:
;;
;;   - tm-revisions (file)
;;
;; And ideally:
;;
;;   - tm-map-line (file from-revision from-line to-revision from-is-older)
;;
;; For more details see the large comment at the front of vc.el.

;;; Todo:
;;
;; * implement missing blame
;; * implement missing show-commit
;; * vc-tm-create: when called from a revision buffer, should jump to that revision
;; * vc-tm--time-machine: confirm revision is present in tmbuf--branch-revisions

;;; Code:

(require 'vc)

(defgroup vc-timemachine nil
  "Time-machine functionality for VC backends."
  :group 'vc
  :version "30.1")

(defcustom vc-tm-date-format
  "%a %I:%M %p %Y-%m-%d"
  "Revision creation date format (emphasis on easy date comparison)."
  :type 'string
  :group 'vc-timemachine
  :version "30.1")

(defcustom vc-tm-echo-area t
  "When non-nil show revision details in the echo-area while navigating commits."
  :type 'boolean
  :group 'vc-timemachine
  :version "30.1")

(defcustom vc-tm-echo-area-detail 'subject
  "What to display when `vc-tm-echo-area` is t.
Available values are:
`ID`      : The revision's ID (commit hash)
`subject` : The revision's commit message subject line"
  :type '(radio (const :tag "Revision ID (commit hash)" commit)
                (const :tag "Revision message subject line" subject))
  :group 'vc-timemachine
  :version "30.1")

(defface vc-tm-echo-area-detail-face
  '((((class color) (background dark))
     :foreground "yellow")
    (((class color) (background light))
     :foreground "yellow4"))
  "Face to use when displaying details in the echo-area."
  :group 'vc-timemachine
  :version "30.1")

(defcustom vc-tm-echo-area-author t
  "Prepend author to echo-area details."
  :type 'boolean
  :group 'vc-timemachine
  :version "30.1")

(defface vc-tm-echo-area-author-face
  '((((class color) (background dark))
     :foreground "orange")
    (((class color) (background light))
     :foreground "DarkOrange4"))
  "Face to use when displaying author as part of details in the echo-area."
  :group 'vc-timemachine
  :version "30.1")

(defcustom vc-tm-abbreviation-length 12
  "Number of chars from full revision id to use for abbreviation."
  :type 'integer
  :group 'vc-timemachine
  :version "30.1")

(defcustom vc-tm-quit-to-invoking-buffer t
  "Switch to invoking buffer on ‘vc-tm-quit’."
  :type 'boolean
  :group 'vc-timemachine
  :version "30.1")

(defvar-local vc--time-machine nil
  "Cache a TM hint on various buffers.")
(put 'vc--time-machine 'permanent-local t)

(defvar-local tmbuf--abs-file nil
  "Absolute path to file being traversed by this time-machine.")
(put 'tmbuf--abs-file 'permanent-local t)
(defvar-local tmbuf--backend nil
  "The VC backend being used by this time-machine")
(put 'tmbuf--backend 'permanent-local t)
(defvar-local tmbuf--branch-index nil
  "Zero-base index into tmbuf--branch-revisions.")
(put 'tmbuf--branch-revisions 'permanent-local t)
(defvar-local tmbuf--branch-revisions nil
  "When non-nil, a vector of revision-info lists.")
(put 'tmbuf--branch-revisions 'permanent-local t)
(defvar-local tmbuf--source-buffer nil
  "A non-time-machine buffer for which this time-machine was created.")
(put 'tmbuf--source-buffer 'permanent-local t)

(defun vc-tm--time-machine ()
  "Return a valid time-machine for the current buffer."
  (if tmbuf--backend
      (current-buffer)
    (let ((revision vc-tm--revision) ;; caller could be a revision buffer
          (source (current-buffer)))
      (set-buffer (or (buffer-base-buffer) source))
      (vc-ensure-vc-buffer)

      (let* ((parent vc-parent-buffer)
             (abs-file (buffer-file-name))
             (backend  (vc-backend abs-file))
             (work-rev (vc-working-revision abs-file))
             (tmbuf vc--time-machine))

        ;; ensure that there is a revision with which to work.
        (unless revision
          (setq revision work-rev)
          (setq source (current-buffer)))

        ;; Validate any current time-machine buffer.
        (when tmbuf
          (with-current-buffer tmbuf
            (unless (and (equal abs-file tmbuf--abs-file)
                         (equal backend  tmbuf--backend)
                         ;; TODO: confirm that revision is in tmbuf--branch-revisions.
                         )
              ;; Discard an unvalidate TM buffer.
              (setq tmbuf nil))))

        ;; Create a fresh TM buffer if needed.
        (unless tmbuf
          (with-current-buffer (setq tmbuf (get-buffer-create "*nascent TM*"))
            (setq vc-parent-buffer parent)
            (setq vc--time-machine tmbuf)
            (setq vc-tm--revision revision)
            (setq tmbuf--abs-file abs-file)
            (setq tmbuf--backend backend)
            (setq tmbuf--source-buffer source)
            (setq tmbuf--branch-index 0)
            (setq tmbuf--branch-revisions
                  (with-temp-buffer
                    (prog2
                        (message "Enumerating revisions...")
                        (let* ((vec (cl-coerce (vc-call-backend backend 'tm-revisions abs-file) 'vector))
                               (branch (nreverse vec)))
                          branch)
                      (message "Enumerating revisions...done"))))))

        (set-buffer tmbuf)
        tmbuf))))

;;;###autoload
(defun vc-tm-revision-head ()
  "Show work file's current revision on checked-out branch."
  (interactive)
  (with-current-buffer (vc-tm--time-machine)
    (vc-tm--switch-to-revision 1)))

(defun vc-tm-revision-next ()
  "Show work file's next revision on checked-out branch."
  (interactive)
  (with-current-buffer (vc-tm--time-machine)
    (vc-tm--switch-to-revision tmbuf--branch-index)))

(defun vc-tm-revision-previous ()
  "Show work file's previous revision on checked-out branch."
  (interactive)
  (with-current-buffer (vc-tm--time-machine)
    (vc-tm--switch-to-revision (+ tmbuf--branch-index 2))))

(defun vc-tm-revision-i (number)
  "Show work file's N'th most recent revision on checked-out branch (1 being HEAD)."
  (interactive "nEnter revision position: ")
  (with-current-buffer (vc-tm--time-machine)
    (vc-tm--switch-to-revision number)))

(defun vc-tm-revision-complete-subject ()
  "Show work file's revision via subject completion on checked-out branch."
  (interactive)
  (let* ((s (completing-read
             "Commit subject: "
             (mapcar (apply-partially #'nth 2) tmbuf--branch-revisions))))
    (vc-tm--switch-to-revision
     (cl-loop for revision-number from 1
              for info across tmbuf--branch-revisions
              if (equal s (nth 2 info)) return revision-number
              finally (error "Subject not found")))))

(defun vc-tm--switch-to-revision (to-number)
  "Show work file's revision at position TO-NUMBER on checked-out branch."
  (let ((branch-length (length tmbuf--branch-revisions))
        (to-index (1- to-number))
        (calling-window-buffer (window-buffer))
        (cursor-win-pos))
    (with-current-buffer calling-window-buffer
      (setq cursor-win-pos (vc-tm--get-cursor-win-position)))
    (cond
     ((< to-number 1)
      (error "%s" "This is the HEAD revision; there are none newer"))
     ((>= to-index branch-length)
      (error "There is no revision %d (the oldest revision is %d)"
             to-number branch-length))
     (t
      (let* ((new-revision-info (vc-tm--tmbuf-revision-info to-index))
             (new-revision (car new-revision-info))
             (abbrev-rev (vc-tm--abbreviate new-revision))
             (date (nth 1 new-revision-info))
             (n-of-m (format " [%d/%d %s]" to-number branch-length date))
             ;; Use the file-name from new-revision-info to reveal renames.
             (file-name (file-name-nondirectory (nth 4 new-revision-info)))
             (tmbuf (current-buffer))
             (from-line (line-number-at-pos))
             (to-line from-line))
        (when vc-tm--revision
          (unless (= tmbuf--branch-index to-index)
            (setq to-line (vc-tm--map-line from-line to-index))))
        (vc-find-revision tmbuf--abs-file new-revision tmbuf--backend tmbuf)
        ;; Reuse timemachine windows, otherwise create them in some other-window.
        (if (eq calling-window-buffer tmbuf)
            (switch-to-buffer tmbuf)
          (switch-to-buffer-other-window tmbuf))
        (vc-tm-mode +1)
        (forward-line (- to-line (line-number-at-pos)))
        (vc-tm--set-cursor-win-position cursor-win-pos)
        (setq tmbuf--branch-index to-index)

        (rename-buffer (concat file-name " " abbrev-rev) t)
        (setq mode-line-buffer-identification
              (list (propertized-buffer-identification "%12b") n-of-m))

        (when vc-tm-echo-area
          (vc-tm--show-echo-area-details new-revision-info))))
      (vc-tm--erm-workaround))))


(defun vc-tm--map-line (from-line to-index)
  "Return a suggested new current-line after a revision jump."
  ;; Newer and older are first guesses; subsequently they may get swapped.
  (let* ((to-info (vc-tm--tmbuf-revision-info to-index))
         (to-revision (car to-info))
         (from-revision vc-tm--revision)
         (from-is-older (< tmbuf--branch-index to-index))
         (backend tmbuf--backend)
         (abs-file tmbuf--abs-file))
    (with-temp-buffer
      (vc-call-backend backend 'tm-map-line abs-file
                       from-revision from-line to-revision from-is-older))))

(defun vc-default-tm-map-line (_backend _rel-file _from-revision from-line
                                     _to-revision _from-is-older)
  "Default `map-line' implementation.
It merely returns FROM-LINE."
  from-line)

(defun vc-tm--show-echo-area-details (revision-info)
  "Show details for REVISION-INFO in echo-area."
  (let* ((date (nth 1 revision-info))
         (author (if vc-tm-show-author (concat " | " (nth 3 revision-info)) ""))
         (sha-or-subject (if (eq vc-tm-echo-area-detail 'commit) (car revision-info) (nth 2 revision-info))))
    (message "%s%s: %s"
             date
             (propertize author 'face 'vc-tm-echo-area-author-face)
             (propertize sha-or-subject 'face 'vc-tm-echo-area-detail-face))))

(defun vc-tm-format-date (date)
  "Return date formatted per the user's vc-tm-date-format."
  (format-time-string vc-tm-date-format (date-to-time date)))

(declare-function erm-reset-buffer "ext:enh-ruby-mode")

(defun vc-tm--erm-workaround ()
  "Workaround for enhanced ruby mode not detecting revision change."
  (when (eq major-mode 'enh-ruby-mode)
    (ignore-errors (erm-reset-buffer))))

(defun vc-tm--get-cursor-win-position ()
  "Return the cursor visual line number w.r.t. the current window first line."
  (let* ((win-point-min (save-excursion (move-to-window-line 0) (point)))
         (cur-pos (count-screen-lines win-point-min (point))))
    cur-pos))

(defun vc-tm--set-cursor-win-position (POS)
  "Set the cursor position to the POS visual line w.r.t. the window first line."
  (recenter POS))

(defun vc-tm--abbreviate (revision)
  "Return REVISION abbreviated to `vc-tm-abbreviation-length' chars."
  (if (length< revision vc-tm-abbreviation-length)
      revision
    (substring revision 0 vc-tm-abbreviation-length)))

(defun vc-tm-revision-to-kill-ring ()
  "Kill the current revisions abbreviated commit hash."
  (interactive)
  (let ((revision (vc-tm--tmbuf-revision)))
    (message revision)
    (kill-new revision)))

(defun vc-tm-abbreviated-revision-to-kill-ring ()
  "Kill the current revisions full commit hash."
  (interactive)
  (let ((revision (vc-tm--abbreviate (vc-tm--tmbuf-revision))))
    (message revision)
    (kill-new revision)))

;; (defun vc-tm-show-commit ()
;;   "Show commit for current revision."
;;   (interactive)
;;   (let ((rev (vc-tm--tmbuf-revision)))
;;     (if (fboundp 'magit-show-commit)
;;         (magit-show-commit rev)
;;       (message "You need to install magit to show commit"))))

;; (defun vc-tm-blame ()
;;   "Call ‘magit-blame’ on current revision."
;;   (interactive)
;;   (if (fboundp 'magit-blame)
;;       (let ((magit-buffer-revision (car tm--revision-info)))
;;      (magit-blame))
;;     (message "You need to install magit for blame capabilities")))

(defun vc-tm--tmbuf-revision (&optional index)
  "Return the unique revision id for this tmbuf's current revision."
  (car (vc-tm--tmbuf-revision-info index)))

(defun vc-tm--tmbuf-revision-info (&optional index)
  "Return the revision-info list for this tmbuf's current revision."
  (aref tmbuf--branch-revisions (or index tmbuf--branch-index)))

(defun vc-tm-quit ()
  "Exit the timemachine."
  (interactive)
  (let ((parent-buffer-name buffer-file-name))
    (kill-buffer)
    (let ((parent-buffer (find-buffer-visiting parent-buffer-name)))
      (when (and parent-buffer vc-tm-quit-to-invoking-buffer)
        (switch-to-buffer parent-buffer nil t)))))

(transient-define-prefix vc-tm-help ()
  "Show online help."
  ["Navigate"
   [("," "switch to HEAD revision" vc-tm-revision-head)
    ("~" "switch to selected revision id" vc-tm-revision-select)
    ("n" "switch to next revision" vc-tm-revision-next)
    ("p" "switch to previous revision" vc-tm-revision-previous)
    ("j" "switch to i'th revision" vc-tm-revision-nth)
    ("s" "switch to subject revision" vc-tm-revision-complete-subject)]]
  ["Revision ID to kill ring"
   [("w" "abbreviated revision id" vc-tm-abbreviated-revision-to-kill-ring)
    ("W" "full revision id" vc-tm-revision-to-kill-ring)]]
  ["Misc"
   [ ;; ("B" "blame current revision" vc-tm-blame)
;;  ("C" "view commit" vc-tm-show-commit)
    ("?" "show help" vc-tm-help)
    ("q" "quit" vc-tm-quit)]])

(define-minor-mode vc-tm-mode
  "VC Timemachine, feel the wings of history."
  :init-value nil
  :lighter " TM"
  :keymap
  '(("," . vc-tm-revision-head)
    ("~" . vc-tm-revision-select)
;;  ("B" . vc-tm-blame)
;;  ("C" . vc-tm-show-commit)
    ("j" . vc-tm-revision-nth)
    ("n" . vc-tm-revision-next)
    ("p" . vc-tm-revision-previous)
    ("q" . vc-tm-quit)
    ("s" . vc-tm-revision-complete-subject)
    ("S" . vc-tm-revision-complete-subject) ; in vc-mode "s" is vc-create-tag
    ("w" . vc-tm-abbreviated-revision-to-kill-ring)
    ("W" . vc-tm-revision-to-kill-ring)
    ("?" . vc-tm-help))
  :group 'vc-timemachine)

(provide 'vc-timemachine)

;;; vc-timemachine.el ends here