;;; mercurial.el --- Emacs support for the Mercurial distributed SCM

;; Copyright (C) 2005 Bryan O'Sullivan

;; Author: Bryan O'Sullivan <bos@serpentine.com>

;; $Id$

;; mercurial.el is free software; you can redistribute it and/or

;; modify it under the terms of version 2 of the GNU General Public

;; License as published by the Free Software Foundation.

;; mercurial.el 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 mercurial.el, GNU Emacs, or XEmacs; see the file COPYING

;; (`C-h C-l').  If not, write to the Free Software Foundation, Inc.,

;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

;;; Commentary:

;; This mode builds upon Emacs's VC mode to provide flexible

;; integration with the Mercurial distributed SCM tool.

;; To get going as quickly as possible, load mercurial.el into Emacs and

;; type `C-c h h'; this runs hg-help-overview, which prints a helpful

;; usage overview.

;; Much of the inspiration for mercurial.el comes from Rajesh

;; Vaidheeswarran's excellent p4.el, which does an admirably thorough

;; job for the commercial Perforce SCM product.  In fact, substantial

;; chunks of code are adapted from p4.el.

;; This code has been developed under XEmacs 21.5, and may will not

;; work as well under GNU Emacs (albeit tested under 21.2).  Patches

;; to enhance the portability of this code, fix bugs, and add features

;; are most welcome.  You can clone a Mercurial repository for this

;; package from http://www.serpentine.com/hg/hg-emacs

;; Please send problem reports and suggestions to bos@serpentine.com.

;;; Code:

(require 'advice)

(require 'cl)

(require 'diff-mode)

(require 'easymenu)

(require 'vc)

;;; XEmacs has view-less, while GNU Emacs has view.  Joy.

(condition-case nil

    (require 'view-less)

  (error nil))

(condition-case nil

    (require 'view)

  (error nil))

;;; Variables accessible through the custom system.

(defgroup mercurial nil

  "Mercurial distributed SCM."

  :group 'tools)

(defcustom hg-binary

  (dolist (path '("~/bin/hg"

		  "/usr/bin/hg"

		  "/usr/local/bin/hg"))

    (when (file-executable-p path)

      (return path)))

  "The path to Mercurial's hg executable."

  :type '(file :must-match t)

  :group 'mercurial)

(defcustom hg-mode-hook nil

  "Hook run when a buffer enters hg-mode."

  :type 'sexp

  :group 'mercurial)

(defcustom hg-global-prefix "\C-ch"

  "The global prefix for Mercurial keymap bindings."

  :type 'sexp

  :group 'mercurial)

(defcustom hg-commit-allow-empty-message nil

  "Whether to allow changes to be committed with empty descriptions."

  :type 'boolean

  :group 'mercurial)

(defcustom hg-commit-allow-empty-file-list nil

  "Whether to allow changes to be committed without any modified files."

  :type 'boolean

  :group 'mercurial)

(defcustom hg-rev-completion-limit 100

  "The maximum number of revisions that hg-read-rev will offer to complete.

This affects memory usage and performance when prompting for revisions

in a repository with a lot of history."

  :type 'integer

  :group 'mercurial)

(defcustom hg-log-limit 50

  "The maximum number of revisions that hg-log will display."

  :type 'integer

  :group 'mercurial)

(defcustom hg-update-modeline t

  "Whether to update the modeline with the status of a file after every save.

Set this to nil on platforms with poor process management, such as Windows."

  :type 'boolean

  :group 'mercurial)

;;; Other variables.

(defconst hg-running-xemacs (string-match "XEmacs" emacs-version)

  "Is mercurial.el running under XEmacs?")

(defvar hg-mode nil

  "Is this file managed by Mercurial?")

(make-variable-buffer-local 'hg-mode)

(put 'hg-mode 'permanent-local t)

(defvar hg-status nil)

(make-variable-buffer-local 'hg-status)

(put 'hg-status 'permanent-local t)

(defvar hg-output-buffer-name "*Hg*"

  "The name to use for Mercurial output buffers.")

(defvar hg-file-history nil)

(defvar hg-rev-history nil)

;;; Random constants.

(defconst hg-commit-message-start

  "--- Enter your commit message.  Type `C-c C-c' to commit. ---\n")

(defconst hg-commit-message-end

  "--- Files in bold will be committed.  Click to toggle selection. ---\n")

;;; hg-mode keymap.

(defvar hg-prefix-map

  (let ((map (copy-keymap vc-prefix-map)))

    (if (functionp 'set-keymap-name)

      (set-keymap-name map 'hg-prefix-map)); XEmacs

    map)

  "This keymap overrides some default vc-mode bindings.")

(fset 'hg-prefix-map hg-prefix-map)

(define-key hg-prefix-map "=" 'hg-diff)

(define-key hg-prefix-map "c" 'hg-undo)

(define-key hg-prefix-map "g" 'hg-annotate)

(define-key hg-prefix-map "l" 'hg-log)

(define-key hg-prefix-map "n" 'hg-commit-file)

;; (define-key hg-prefix-map "r" 'hg-update)

(define-key hg-prefix-map "u" 'hg-revert-buffer)

(define-key hg-prefix-map "~" 'hg-version-other-window)

(defvar hg-mode-map (make-sparse-keymap))

(define-key hg-mode-map "\C-xv" 'hg-prefix-map)

(add-minor-mode 'hg-mode 'hg-mode hg-mode-map)

;;; Global keymap.

(global-set-key "\C-xvi" 'hg-add)

(defvar hg-global-map (make-sparse-keymap))

(fset 'hg-global-map hg-global-map)

(global-set-key hg-global-prefix 'hg-global-map)

(define-key hg-global-map "," 'hg-incoming)

(define-key hg-global-map "." 'hg-outgoing)

(define-key hg-global-map "<" 'hg-pull)

(define-key hg-global-map "=" 'hg-diff)

(define-key hg-global-map ">" 'hg-push)

(define-key hg-global-map "?" 'hg-help-overview)

(define-key hg-global-map "A" 'hg-addremove)

(define-key hg-global-map "U" 'hg-revert)

(define-key hg-global-map "a" 'hg-add)

(define-key hg-global-map "c" 'hg-commit)

(define-key hg-global-map "f" 'hg-forget)

(define-key hg-global-map "h" 'hg-help-overview)

(define-key hg-global-map "i" 'hg-init)

(define-key hg-global-map "l" 'hg-log)

(define-key hg-global-map "r" 'hg-root)

(define-key hg-global-map "s" 'hg-status)

(define-key hg-global-map "u" 'hg-update)

;;; View mode keymap.

(defvar hg-view-mode-map

  (let ((map (copy-keymap (if (boundp 'view-minor-mode-map)

			      view-minor-mode-map

			    view-mode-map))))

    (if (functionp 'set-keymap-name)

      (set-keymap-name map 'hg-view-mode-map)); XEmacs

    map))

(fset 'hg-view-mode-map hg-view-mode-map)

(define-key hg-view-mode-map

  (if hg-running-xemacs [button2] [mouse-2])

  'hg-buffer-mouse-clicked)

;;; Commit mode keymaps.

(defvar hg-commit-mode-map (make-sparse-keymap))

(define-key hg-commit-mode-map "\C-c\C-c" 'hg-commit-finish)

(define-key hg-commit-mode-map "\C-c\C-k" 'hg-commit-abort)

(defvar hg-commit-mode-file-map (make-sparse-keymap))

(define-key hg-commit-mode-file-map

  (if hg-running-xemacs [button2] [mouse-2])

  'hg-commit-mouse-clicked)

(define-key hg-commit-mode-file-map " " 'hg-commit-toggle-file)

(define-key hg-commit-mode-file-map "\r" 'hg-commit-toggle-file)

;;; Convenience functions.

(defsubst hg-binary ()

  (if hg-binary

      hg-binary

    (error "No `hg' executable found!")))

(defsubst hg-replace-in-string (str regexp newtext &optional literal)

  "Replace all matches in STR for REGEXP with NEWTEXT string.

Return the new string.  Optional LITERAL non-nil means do a literal

replacement.

This function bridges yet another pointless impedance gap between

XEmacs and GNU Emacs."

  (if (fboundp 'replace-in-string)

      (replace-in-string str regexp newtext literal)

    (replace-regexp-in-string regexp newtext str nil literal)))

(defsubst hg-strip (str)

  "Strip leading and trailing white space from a string."

  (hg-replace-in-string (hg-replace-in-string str "[ \t\r\n]+$" "")

			"^[ \t\r\n]+" ""))

(defsubst hg-chomp (str)

  "Strip trailing newlines from a string."

  (hg-replace-in-string str "[\r\n]+$" ""))

(defun hg-run-command (command &rest args)

  "Run the shell command COMMAND, returning (EXIT-CODE . COMMAND-OUTPUT).

The list ARGS contains a list of arguments to pass to the command."

  (let* (exit-code

	 (output

	  (with-output-to-string

	    (with-current-buffer

		standard-output

	      (setq exit-code

		    (apply 'call-process command nil t nil args))))))

    (cons exit-code output)))

(defun hg-run (command &rest args)

  "Run the Mercurial command COMMAND, returning (EXIT-CODE . COMMAND-OUTPUT)."

  (apply 'hg-run-command (hg-binary) command args))

(defun hg-run0 (command &rest args)

  "Run the Mercurial command COMMAND, returning its output.

If the command does not exit with a zero status code, raise an error."

  (let ((res (apply 'hg-run-command (hg-binary) command args)))

    (if (not (eq (car res) 0))

	(error "Mercurial command failed %s - exit code %s"

	       (cons command args)

	       (car res))

      (cdr res))))

(defun hg-buffer-commands (pnt)

  "Use the properties of a character to do something sensible."

  (interactive "d")

  (let ((rev (get-char-property pnt 'rev))

	(file (get-char-property pnt 'file))

	(date (get-char-property pnt 'date))

	(user (get-char-property pnt 'user))

	(host (get-char-property pnt 'host))

	(prev-buf (current-buffer)))

    (cond

     (file

      (find-file-other-window file))

     (rev

      (hg-diff hg-view-file-name rev rev prev-buf))

     ((message "I don't know how to do that yet")))))

(defun hg-buffer-mouse-clicked (event)

  "Translate the mouse clicks in a HG log buffer to character events.

These are then handed off to `hg-buffer-commands'.

Handle frickin' frackin' gratuitous event-related incompatibilities."

  (interactive "e")

  (if hg-running-xemacs

      (progn

	(select-window (event-window event))

	(hg-buffer-commands (event-point event)))

    (select-window (posn-window (event-end event)))

    (hg-buffer-commands (posn-point (event-start event)))))

(unless (fboundp 'view-minor-mode)

  (defun view-minor-mode (prev-buffer exit-func)

    (view-mode)))

(defsubst hg-abbrev-file-name (file)

  "Portable wrapper around abbreviate-file-name."

  (if hg-running-xemacs

      (abbreviate-file-name file t)

    (abbreviate-file-name file)))

(defun hg-read-file-name (&optional prompt default)

  "Read a file or directory name, or a pattern, to use with a command."

  (let ((path (or default (buffer-file-name))))

    (if (or (not path) current-prefix-arg)

	(expand-file-name

	 (read-file-name (format "File, directory or pattern%s: "

				 (or prompt ""))

			 (and path (file-name-directory path))

			 nil nil

			 (and path (file-name-nondirectory path))

			 'hg-file-history))

      path)))

(defun hg-read-rev (&optional prompt default)

  "Read a revision or tag, offering completions."

  (let ((rev (or default "tip")))

    (if (or (not rev) current-prefix-arg)

	(let ((revs (split-string (hg-chomp

				   (hg-run0 "-q" "log" "-r"

					    (format "-%d"

						    hg-rev-completion-limit)

					    "-r" "tip"))

				  "[\n:]")))

	  (dolist (line (split-string (hg-chomp (hg-run0 "tags")) "\n"))

	    (setq revs (cons (car (split-string line "\\s-")) revs)))

	  (completing-read (format "Revision%s (%s): "

				   (or prompt "")

				   (or default "tip"))

			   (map 'list 'cons revs revs)

			   nil

			   nil

			   nil

			   'hg-rev-history

			   (or default "tip")))

      rev)))

(defmacro hg-do-across-repo (path &rest body)

  (let ((root-name (gensym "root-"))

	(buf-name (gensym "buf-")))

    `(let ((,root-name (hg-root ,path)))

       (save-excursion

	 (dolist (,buf-name (buffer-list))

	   (set-buffer ,buf-name)

	   (when (and hg-status (equal (hg-root buffer-file-name) ,root-name))

	     ,@body))))))

(put 'hg-do-across-repo 'lisp-indent-function 1)

;;; View mode bits.

(defun hg-exit-view-mode (buf)

  "Exit from hg-view-mode.

We delete the current window if entering hg-view-mode split the

current frame."

  (when (and (eq buf (current-buffer))

	     (> (length (window-list)) 1))

    (delete-window))

  (when (buffer-live-p buf)

    (kill-buffer buf)))

(defun hg-view-mode (prev-buffer &optional file-name)

  (goto-char (point-min))

  (set-buffer-modified-p nil)

  (toggle-read-only t)

  (view-minor-mode prev-buffer 'hg-exit-view-mode)

  (use-local-map hg-view-mode-map)

  (setq truncate-lines t)

  (when file-name

    (set (make-local-variable 'hg-view-file-name)

	 (hg-abbrev-file-name file-name))))

(defun hg-file-status (file)

  "Return status of FILE, or nil if FILE does not exist or is unmanaged."

  (let* ((s (hg-run "status" file))

	 (exit (car s))

	 (output (cdr s)))

    (if (= exit 0)

	(let ((state (assoc (substring output 0 (min (length output) 2))

			    '(("M " . modified)

			      ("A " . added)

			      ("R " . removed)

			      ("? " . nil)))))

	  (if state

	      (cdr state)

	    'normal)))))

(defun hg-tip ()

  (split-string (hg-chomp (hg-run0 "-q" "tip")) ":"))

(defmacro hg-view-output (args &rest body)

  "Execute BODY in a clean buffer, then quickly display that buffer.

If the buffer contains one line, its contents are displayed in the

minibuffer.  Otherwise, the buffer is displayed in view-mode.

ARGS is of the form (BUFFER-NAME &optional FILE), where BUFFER-NAME is

the name of the buffer to create, and FILE is the name of the file

being viewed."

  (let ((prev-buf (gensym "prev-buf-"))

	(v-b-name (car args))

	(v-m-rest (cdr args)))

    `(let ((view-buf-name ,v-b-name)

	   (,prev-buf (current-buffer)))

       (get-buffer-create view-buf-name)

       (kill-buffer view-buf-name)

       (get-buffer-create view-buf-name)

       (set-buffer view-buf-name)

       (save-excursion

	 ,@body)

       (case (count-lines (point-min) (point-max))

	 ((0)

	  (kill-buffer view-buf-name)

	  (message "(No output)"))

	 ((1)

	  (let ((msg (hg-chomp (buffer-substring (point-min) (point-max)))))

	    (kill-buffer view-buf-name)

	    (message "%s" msg)))

	 (t

	  (pop-to-buffer view-buf-name)

	  (hg-view-mode ,prev-buf ,@v-m-rest))))))

(put 'hg-view-output 'lisp-indent-function 1)

;;; Context save and restore across revert.

(defun hg-position-context (pos)

  "Return information to help find the given position again."

  (let* ((end (min (point-max) (+ pos 98))))

    (list pos

	  (buffer-substring (max (point-min) (- pos 2)) end)

	  (- end pos))))

(defun hg-buffer-context ()

  "Return information to help restore a user's editing context.

This is useful across reverts and merges, where a context is likely

to have moved a little, but not really changed."

  (let ((point-context (hg-position-context (point)))

	(mark-context (let ((mark (mark-marker)))

			(and mark (hg-position-context mark)))))

    (list point-context mark-context)))

(defun hg-find-context (ctx)

  "Attempt to find a context in the given buffer.

Always returns a valid, hopefully sane, position."

  (let ((pos (nth 0 ctx))

	(str (nth 1 ctx))

	(fixup (nth 2 ctx)))

    (save-excursion

      (goto-char (max (point-min) (- pos 15000)))

      (if (and (not (equal str ""))

	       (search-forward str nil t))

	  (- (point) fixup)

	(max pos (point-min))))))

(defun hg-restore-context (ctx)

  "Attempt to restore the user's editing context."

  (let ((point-context (nth 0 ctx))

	(mark-context (nth 1 ctx)))

    (goto-char (hg-find-context point-context))

    (when mark-context

      (set-mark (hg-find-context mark-context)))))

;;; Hooks.

(defun hg-mode-line (&optional force)

  "Update the modeline with the current status of a file.

An update occurs if optional argument FORCE is non-nil,

hg-update-modeline is non-nil, or we have not yet checked the state of

the file."

  (when (and (hg-root) (or force hg-update-modeline (not hg-mode)))

    (let ((status (hg-file-status buffer-file-name)))

      (setq hg-status status

	    hg-mode (and status (concat " Hg:"

					(car (hg-tip))

					(cdr (assq status

						   '((normal . "")

						     (removed . "r")

						     (added . "a")

						     (modified . "m")))))))

      status)))

(defun hg-find-file-hook ()

  (when (hg-mode-line)

    (run-hooks 'hg-mode-hook)))

(add-hook 'find-file-hooks 'hg-find-file-hook)

(defun hg-after-save-hook ()