/monky.el

Large files files are truncated, but you can click here to view the full file

;;; monky.el --- Control Hg from Emacs.  -*- lexical-binding: t; -*-

;; Copyright (C) 2011 Anantha Kumaran.

;; Author: Anantha kumaran <ananthakumaran@gmail.com>
;; URL: http://github.com/ananthakumaran/monky
;; Version: 0.2
;; Keywords: tools

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

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

;;; Commentary:

;;; Code:

(require 'cl)
(require 'cl-lib)
(require 'bindat)
(require 'ediff)
(require 'subr-x)
(require 'view)
(require 'tramp)

(defgroup monky nil
  "Controlling Hg from Emacs."
  :prefix "monky-"
  :group 'tools)

(defcustom monky-hg-executable "hg"
  "The name of the Hg executable."
  :group 'monky
  :type 'string)

(defcustom monky-hg-standard-options '("--config" "diff.git=Off" "--config" "ui.merge=:merge")
  "Standard options when running Hg."
  :group 'monky
  :type '(repeat string))

(defcustom monky-hg-process-environment '("TERM=dumb" "HGPLAIN=" "LANGUAGE=C")
  "Default environment variables for hg."
  :group 'monky
  :type '(repeat string))

;; TODO
(defcustom monky-save-some-buffers t
  "Non-nil means that \\[monky-status] will save modified buffers before running.
Setting this to t will ask which buffers to save, setting it to 'dontask will
save all modified buffers without asking."
  :group 'monky
  :type '(choice (const :tag "Never" nil)
                 (const :tag "Ask" t)
                 (const :tag "Save without asking" dontask)))

(defcustom monky-revert-item-confirm t
  "Require acknowledgment before reverting an item."
  :group 'monky
  :type 'boolean)

(defcustom monky-log-edit-confirm-cancellation nil
  "Require acknowledgment before canceling the log edit buffer."
  :group 'monky
  :type 'boolean)

(defcustom monky-process-popup-time -1
  "Popup the process buffer if a command takes longer than this many seconds."
  :group 'monky
  :type '(choice (const :tag "Never" -1)
                 (const :tag "Immediately" 0)
                 (integer :tag "After this many seconds")))

(defcustom monky-log-cutoff-length 100
  "The maximum number of commits to show in the log buffer."
  :group 'monky
  :type 'integer)

(defcustom monky-log-infinite-length 99999
  "Number of log used to show as maximum for `monky-log-cutoff-length'."
  :group 'monky
  :type 'integer)

(defcustom monky-log-auto-more t
  "Insert more log entries automatically when moving past the last entry.

Only considered when moving past the last entry with `monky-goto-next-section'."
  :group 'monky
  :type 'boolean)

(defcustom monky-incoming-repository "default"
  "The repository from which changes are pulled from by default."
  :group 'monky
  :type 'string)

(defcustom monky-outgoing-repository ""
  "The repository to which changes are pushed to by default."
  :group 'monky
  :type 'string)

(defcustom monky-process-type nil
  "How monky spawns Mercurial processes.
Monky can either spawn a new Mercurial process for each request or
use Mercurial's command server feature to run several commands in a
single process instances. While the former is more robust, the latter
is usually faster if Monky runs several commands."
  :group 'monky
  :type '(choice (const :tag "Single processes" :value nil)
                 (const :tag "Use command server" :value cmdserver)))

(defcustom monky-pull-args ()
  "Extra args to pass to pull."
  :group 'monky
  :type '(repeat string))

(defcustom monky-repository-paths nil
  "*Paths where to find repositories.  For each repository an alias is defined, which can then be passed to `monky-open-repository` to open the repository.

Lisp-type of this option: The value must be a list L whereas each
element of L is a 2-element list: The first element is the full
path of a directory \(string) and the second element is an
arbitrary alias \(string) for this directory which is then
displayed instead of the underlying directory."
  :group 'monky
  :initialize 'custom-initialize-default
  :set (function (lambda (symbol value)
                   (set symbol value)
                   (if (and (boundp 'ecb-minor-mode)
                            ecb-minor-mode
			    (functionp 'ecb-update-directories-buffer))
		       (ecb-update-directories-buffer))))
  :type '(repeat (cons :tag "Path with alias"
		       (string :tag "Alias")
		       (directory :tag "Path"))))

(defun monky-root-dir-descr (dir)
  "Return the name of dir if it matches a path in monky-repository-paths, otherwise return nil"
  (catch 'exit
    (dolist (root-dir monky-repository-paths)
      (let ((base-dir
	     (concat
	      (replace-regexp-in-string
	       "/$" ""
	       (replace-regexp-in-string
		"^\~" (getenv "HOME")
		(cdr root-dir)))
	      "/")))
	(when (equal base-dir dir)
	  (throw 'exit (cons (car root-dir)
			     base-dir)))))))

(defun monky-open-repository ()
  "Prompt for a repository path or alias, then display the status
buffer.  Aliases are set in monky-repository-paths."
  (interactive)
  (let* ((rootdir (condition-case nil
		      (monky-get-root-dir)
		    (error nil)))
	 (default-repo (or (monky-root-dir-descr rootdir) rootdir))
	 (msg (if default-repo
		  (concat "repository (default " (car default-repo) "): ")
		"repository: "))
	 (repo-name (completing-read msg (mapcar 'car monky-repository-paths)))
	 (repo (or (assoc repo-name monky-repository-paths) default-repo)))
    (when repo (monky-status (cdr repo)))))

(defgroup monky-faces nil
  "Customize the appearance of Monky"
  :prefix "monky-"
  :group 'faces
  :group 'monky)

(defface monky-header
  '((t :weight bold))
  "Face for generic header lines.

Many Monky faces inherit from this one by default."
  :group 'monky-faces)

(defface monky-section-title
  '((((class color) (background light)) :foreground "DarkGoldenrod4" :inherit monky-header)
    (((class color) (background  dark)) :foreground "LightGoldenrod2" :inherit monky-header))
  "Face for section titles."
  :group 'monky-faces)

(defface monky-branch
  '((t :weight bold :inherit monky-header))
  "Face for the current branch."
  :group 'monky-faces)

(defface monky-diff-title
  '((t :inherit (monky-header)))
  "Face for diff title lines."
  :group 'monky-faces)

(defface monky-diff-hunk-header
  '((((class color) (background light))
     :background "grey80"
     :foreground "grey30")
    (((class color) (background dark))
     :background "grey25"
     :foreground "grey70"))
  "Face for diff hunk header lines."
  :group 'monky-faces)

(defface monky-diff-add
  '((((class color) (background light))
     :background "#cceecc"
     :foreground "#22aa22")
    (((class color) (background dark))
     :background "#336633"
     :foreground "#cceecc"))
  "Face for lines in a diff that have been added."
  :group 'monky-faces)

(defface monky-diff-none
  '((t))
  "Face for lines in a diff that are unchanged."
  :group 'monky-faces)

(defface monky-diff-del
  '((((class color) (background light))
     :background "#eecccc"
     :foreground "#aa2222")
    (((class color) (background dark))
     :background "#663333"
     :foreground "#eecccc"))
  "Face for lines in a diff that have been deleted."
  :group 'monky-faces)

(defface monky-commit-id
  '((((class color) (background light))
     :foreground "firebrick")
    (((class color) (background dark))
     :foreground "tomato"))
  "Face for commit IDs: SHA1 codes and commit numbers."
  :group 'monky-faces)

(defface monky-log-sha1
  '((t :inherit monky-commit-id))
  "Face for the sha1 element of the log output."
  :group 'monky-faces)

(defface monky-log-message
  '((t))
  "Face for the message element of the log output."
  :group 'monky-faces)

(defface monky-log-author
  '((((class color) (background light))
     :foreground "navy")
    (((class color) (background dark))
     :foreground "cornflower blue"))
  "Face for author shown in log buffer."
  :group 'monky-faces)

(defface monky-log-head-label-local
  '((((class color) (background light))
     :box t
     :background "Grey85"
     :foreground "LightSkyBlue4")
    (((class color) (background dark))
     :box t
     :background "Grey13"
     :foreground "LightSkyBlue1"))
  "Face for local branch head labels shown in log buffer."
  :group 'monky-faces)

(defface monky-log-head-label-tags
  '((((class color) (background light))
     :box t
     :background "LemonChiffon1"
     :foreground "goldenrod4")
    (((class color) (background dark))
     :box t
     :background "LemonChiffon1"
     :foreground "goldenrod4"))
  "Face for tag labels shown in log buffer."
  :group 'monky-faces)

(defface monky-queue-patch
  '((t :weight bold :inherit (monky-header highlight)))
  "Face for patch name"
  :group 'monky-faces)

(defface monky-log-head-label-bookmarks
  '((((class color) (background light))
     :box t
     :background "IndianRed1"
     :foreground "IndianRed4")
    (((class color) (background dark))
     :box t
     :background "IndianRed1"
     :foreground "IndianRed4"))
  "Face for bookmark labels shown in log buffer."
  :group 'monky-faces)

(defface monky-log-head-label-phase
  '((((class color) (background light))
     :box t
     :background "light green"
     :foreground "dark olive green")
    (((class color) (background dark))
     :box t
     :background "light green"
     :foreground "dark olive green"))
  "Face for phase label shown in log buffer."
  :group 'monky-faces)

(defface monky-log-date
  '((t :weight bold :inherit monky-header))
  "Face for date in log."
  :group 'monky-faces)

(defface monky-queue-active
  '((((class color) (background light))
     :box t
     :background "light green"
     :foreground "dark olive green")
    (((class color) (background dark))
     :box t
     :background "light green"
     :foreground "dark olive green"))
  "Face for active patch queue"
  :group 'monky-faces)

(defface monky-queue-positive-guard
  '((((class color) (background light))
     :box t
     :background "light green"
     :foreground "dark olive green")
    (((class color) (background dark))
     :box t
     :background "light green"
     :foreground "dark olive green"))
  "Face for queue postive guards"
  :group 'monky-faces)

(defface monky-queue-negative-guard
  '((((class color) (background light))
     :box t
     :background "IndianRed1"
     :foreground "IndianRed4")
    (((class color) (background dark))
     :box t
     :background "IndianRed1"
     :foreground "IndianRed4"))
  "Face for queue negative guards"
  :group 'monky-faces)

(defvar monky-mode-hook nil
  "Hook run by `monky-mode'.")

;;; User facing configuration

(put 'monky-mode 'mode-class 'special)

;;; Compatibilities

(eval-when-compile
  (when (< emacs-major-version 23)
    (defvar line-move-visual nil)))

;;; Utilities

(defmacro monky-with-process-environment (&rest body)
  (declare (indent 0)
           (debug (body)))
  `(let ((process-environment (append monky-hg-process-environment
                                      process-environment)))
     ,@body))

(defmacro monky-with-refresh (&rest body)
  "Refresh monky buffers after evaluating BODY.

It is safe to call the functions which uses this macro inside of
this macro.  As it is time consuming to refresh monky buffers,
this macro enforces refresh to occur exactly once by pending
refreshes inside of this macro.  Nested calls of this
macro (possibly via functions) does not refresh buffers multiple
times.  Instead, only the outside-most call of this macro
refreshes buffers."
  (declare (indent 0)
           (debug (body)))
  `(monky-refresh-wrapper (lambda () ,@body)))

(defun monky-completing-read (&rest args)
  (apply (if (null ido-mode)
             'completing-read
           'ido-completing-read)
         args))

(defun monky-start-process (&rest args)
  (monky-with-process-environment
    (apply (if (functionp 'start-file-process)
               'start-file-process
             'start-process) args)))

(defun monky-process-file-single (&rest args)
  (monky-with-process-environment
    (apply 'process-file args)))


;; Command server
(defvar monky-process nil)
(defvar monky-process-buffer-name "*monky-process*")
(defvar monky-process-client-buffer nil)

(defvar monky-cmd-process nil)
(defvar monky-cmd-process-buffer-name "*monky-cmd-process*")
(defvar monky-cmd-process-input-buffer nil)
(defvar monky-cmd-process-input-point nil)
(defvar monky-cmd-error-message nil)
(defvar monky-cmd-hello-message nil
  "Variable to store parsed hello message.")

;; TODO: does this need to be permanent? If it's only used in monky buffers (not source file buffers), it shouldn't be.
(defvar-local monky-root-dir nil)
(put 'monky-root-dir 'permanent-local t)

(defun monky-cmdserver-sentinel (proc _change)
  (unless (memq (process-status proc) '(run stop))
    (delete-process proc)))

(defun monky-cmdserver-read-data (size)
  (with-current-buffer (process-buffer monky-cmd-process)
    (while (< (point-max) size)
      (accept-process-output monky-cmd-process 0.1 nil t))
    (let ((str (buffer-substring (point-min) (+ (point-min) size))))
      (delete-region (point-min) (+ (point-min) size))
      (goto-char (point-min))
      (vconcat str))))

(defun monky-cmdserver-read ()
  "Read one channel and return cons (CHANNEL . RAW-DATA)."
  (let* ((data (bindat-unpack '((channel byte) (len u32))
                              (monky-cmdserver-read-data 5)))
         (channel (bindat-get-field data 'channel))
         (len (bindat-get-field data 'len)))
    (cons channel (monky-cmdserver-read-data len))))

(defun monky-cmdserver-unpack-int (data)
  (bindat-get-field (bindat-unpack '((field u32)) data) 'field))

(defun monky-cmdserver-unpack-string (data)
  (bindat-get-field (bindat-unpack `((field str ,(length data))) data) 'field))

(defun monky-cmdserver-write (data)
  (process-send-string monky-cmd-process
                       (concat (bindat-pack '((len u32))
                                            `((len . ,(length data))))
                               data)))

(defun monky-cmdserver-start ()
  (unless monky-root-dir
    (let (monky-process monky-process-type)
      (setq monky-root-dir (monky-get-root-dir))))

  (let ((dir monky-root-dir)
        (buf (get-buffer-create monky-cmd-process-buffer-name))
        (default-directory monky-root-dir)
        (process-connection-type nil))
    (with-current-buffer buf
      (setq buffer-read-only nil)
      (setq buffer-file-coding-system 'no-conversion)
      (set-buffer-multibyte nil)
      (erase-buffer)
      (setq view-exit-action
            #'(lambda (buffer)
                (with-current-buffer buffer
                  (bury-buffer))))
      (setq default-directory dir)
      (let ((monky-cmd-process (monky-start-process
                                "monky-hg" buf "sh" "-c"
                                (format "%s --config extensions.mq= serve --cmdserver pipe 2> /dev/null" monky-hg-executable))))
        (set-process-coding-system monky-cmd-process 'no-conversion 'no-conversion)
        (set-process-sentinel monky-cmd-process #'monky-cmdserver-sentinel)
        (setq monky-cmd-hello-message
              (monky-cmdserver-parse-hello (monky-cmdserver-read)))
        monky-cmd-process))))

(defun monky-cmdserver-parse-hello (hello-message)
  "Parse hello message to get encoding information."
  (let ((channel (car hello-message))
        (text (cdr hello-message)))
    (if (eq channel ?o)
        (progn
          (mapcar
           (lambda (s)
             (string-match "^\\([a-z0-9]+\\) *: *\\(.*\\)$" s)
             (let ((field-name (match-string 1 s))
                   (field-data (match-string 2 s)))
               (cons (intern field-name) field-data)))
           (split-string (monky-cmdserver-unpack-string text) "\n")))
      (error "unknown channel %c for hello message" channel))))

(defun monky-cmdserver-get-encoding (&optional default)
  "Get encoding stored in `monky-cmd-hello-message'."
  (let ((e (assoc 'encoding monky-cmd-hello-message)))
    (if e
        (cond
         ((string-equal (downcase (cdr e)) "ascii")
          'us-ascii)
         (t
          (intern (downcase (cdr e)))))
      default)))

(defun monky-cmdserver-runcommand (&rest cmd-and-args)
  (setq monky-cmd-error-message nil)
  (with-current-buffer (process-buffer monky-cmd-process)
    (setq buffer-read-only nil)
    (erase-buffer))
  (process-send-string monky-cmd-process "runcommand\n")
  (monky-cmdserver-write (mapconcat #'identity cmd-and-args "\0"))
  (let* ((inhibit-read-only t)
         (start (point))
         (result
          (catch 'finished
            (while t
              (let* ((result (monky-cmdserver-read))
                     (channel (car result))
                     (text (cdr result)))
                (cond
                 ((eq channel ?o)
                  (insert (monky-cmdserver-unpack-string text)))
                 ((eq channel ?r)
                  (throw 'finished
                         (monky-cmdserver-unpack-int text)))
                 ((eq channel ?e)
                  (setq monky-cmd-error-message
                        (concat monky-cmd-error-message text)))
                 ((memq channel '(?I ?L))
                  (with-current-buffer monky-cmd-process-input-buffer
                    (let* ((max (if (eq channel ?I)
                                    (point-max)
                                  (save-excursion
                                    (goto-char monky-cmd-process-input-point)
                                    (line-beginning-position 2))))
                           (maxreq (monky-cmdserver-unpack-int text))
                           (len (min (- max monky-cmd-process-input-point)
                                     maxreq))
                           (end (+ monky-cmd-process-input-point len)))
                      (monky-cmdserver-write
                       (buffer-substring monky-cmd-process-input-point end))
                      (setq monky-cmd-process-input-point end))))
                 (t
                  (setq monky-cmd-error-message
                        (format "Unsupported channel: %c" channel)))))))))
    (decode-coding-region start (point)
                          (monky-cmdserver-get-encoding 'utf-8))
    result))

(defun monky-cmdserver-process-file (program infile buffer display &rest args)
  "Same as `process-file' but uses the currently active hg command-server."
  (if (or infile display)
      (apply #'monky-process-file-single program infile buffer display args)
    (let ((stdout (if (consp buffer) (car buffer) buffer))
          (stderr (and (consp buffer) (cadr buffer))))
      (if (eq stdout t) (setq stdout (current-buffer)))
      (if (eq stderr t) (setq stderr stdout))
      (let ((result
             (if stdout
                 (with-current-buffer stdout
                   (apply #'monky-cmdserver-runcommand args))
               (with-temp-buffer
                 (apply #'monky-cmdserver-runcommand args)))))
        (cond
         ((bufferp stderr)
          (when monky-cmd-error-message
            (with-current-buffer stderr
              (insert monky-cmd-error-message))))
         ((stringp stderr)
          (with-temp-file stderr
            (when monky-cmd-error-message
              (insert monky-cmd-error-message)))))
        result))))

(defun monky-process-file (&rest args)
  "Same as `process-file' in the current hg environment.
This function either calls `monky-cmdserver-process-file' or
`monky-process-file-single' depending on whether the hg
command-server should be used."
  (apply (cond
          (monky-cmd-process #'monky-cmdserver-process-file)
          ;; ((eq monky-process-type 'cmdserver)
          ;;  (error "No process started (forget `monky-with-process`?)"))
          (t #'monky-process-file-single))
         args))

(defmacro monky-with-process (&rest body)
  (declare (indent 0)
	   (debug (body)))
  `(let ((outer (not monky-cmd-process)))
     (when (and outer (eq monky-process-type 'cmdserver))
       (setq monky-cmd-process (monky-cmdserver-start)))
     (unwind-protect
	 (progn ,@body)
       (when (and monky-cmd-process outer (eq monky-process-type 'cmdserver))
	 (delete-process monky-cmd-process)
	 (setq monky-cmd-process nil)))))



(defvar monky-bug-report-url "http://github.com/ananthakumaran/monky/issues")
(defun monky-bug-report (str)
  (message "Unknown error: %s\nPlease file a bug at %s"
           str monky-bug-report-url))

(defun monky-string-starts-with-p (string prefix)
  (eq (compare-strings string nil (length prefix) prefix nil nil) t))

(defun monky-trim-line (str)
  (if (string= str "")
      nil
    (if (equal (elt str (- (length str) 1)) ?\n)
        (substring str 0 (- (length str) 1))
      str)))

(defun monky-delete-line (&optional end)
  "Delete the text in current line.
If END is non-nil, deletes the text including the newline character"
  (let ((end-point (if end
                       (1+ (point-at-eol))
                     (point-at-eol))))
    (delete-region (point-at-bol) end-point)))

(defun monky-split-lines (str)
  (if (string= str "")
      nil
    (let ((lines (nreverse (split-string str "\n"))))
      (if (string= (car lines) "")
          (setq lines (cdr lines)))
      (nreverse lines))))

(defun monky-put-line-property (prop val)
  (put-text-property (line-beginning-position) (line-beginning-position 2)
                     prop val))

(defun monky-parse-args (command)
  (require 'pcomplete)
  (car (with-temp-buffer
         (insert command)
         (pcomplete-parse-buffer-arguments))))

(defun monky-prefix-p (prefix list)
  "Return non-nil if PREFIX is a prefix of LIST.
PREFIX and LIST should both be lists.

If the car of PREFIX is the symbol '*, then return non-nil if the cdr of PREFIX
is a sublist of LIST (as if '* matched zero or more arbitrary elements of LIST)"
  (or (null prefix)
      (if (eq (car prefix) '*)
          (or (monky-prefix-p (cdr prefix) list)
              (and (not (null list))
                   (monky-prefix-p prefix (cdr list))))
        (and (not (null list))
             (equal (car prefix) (car list))
             (monky-prefix-p (cdr prefix) (cdr list))))))

(defun monky-wash-sequence (func)
  "Run FUNC until end of buffer is reached.

FUNC should leave point at the end of the modified region"
  (while (and (not (eobp))
              (funcall func))))

(defun monky-goto-line (line)
  "Like `goto-line' but doesn't set the mark."
  (save-restriction
    (widen)
    (goto-char 1)
    (forward-line (1- line))))

;;; Key bindings

(defvar monky-mode-map
  (let ((map (make-keymap)))
    (suppress-keymap map t)
    (define-key map (kbd "n") 'monky-goto-next-section)
    (define-key map (kbd "p") 'monky-goto-previous-section)
    (define-key map (kbd "RET") 'monky-visit-item)
    (define-key map (kbd "TAB") 'monky-toggle-section)
    (define-key map (kbd "SPC") 'monky-show-item-or-scroll-up)
    (define-key map (kbd "DEL") 'monky-show-item-or-scroll-down)
    (define-key map (kbd "g") 'monky-refresh)
    (define-key map (kbd "$") 'monky-display-process)
    (define-key map (kbd ":") 'monky-hg-command)
    (define-key map (kbd "l l") 'monky-log-current-branch)
    (define-key map (kbd "l a") 'monky-log-all)
    (define-key map (kbd "l r") 'monky-log-revset)
    (define-key map (kbd "b") 'monky-branches)
    (define-key map (kbd "Q") 'monky-queue)
    (define-key map (kbd "q") 'monky-quit-window)

    (define-key map (kbd "M-1") 'monky-section-show-level-1-all)
    (define-key map (kbd "M-2") 'monky-section-show-level-2-all)
    (define-key map (kbd "M-3") 'monky-section-show-level-3-all)
    (define-key map (kbd "M-4") 'monky-section-show-level-4-all)
    map))

(defvar monky-status-mode-map
  (let ((map (make-keymap)))
    (define-key map (kbd "s") 'monky-stage-item)
    (define-key map (kbd "S") 'monky-stage-all)
    (define-key map (kbd "u") 'monky-unstage-item)
    (define-key map (kbd "U") 'monky-unstage-all)
    (define-key map (kbd "a") 'monky-commit-amend)
    (define-key map (kbd "c") 'monky-log-edit)
    (define-key map (kbd "e") 'monky-ediff-item)
    (define-key map (kbd "y") 'monky-bookmark-create)
    (define-key map (kbd "C") 'monky-checkout)
    (define-key map (kbd "M") 'monky-merge)
    (define-key map (kbd "B") 'monky-backout)
    (define-key map (kbd "P") 'monky-push)
    (define-key map (kbd "f") 'monky-pull)
    (define-key map (kbd "k") 'monky-discard-item)
    (define-key map (kbd "m") 'monky-resolve-item)
    (define-key map (kbd "x") 'monky-unresolve-item)
    (define-key map (kbd "X") 'monky-reset-tip)
    (define-key map (kbd "A") 'monky-addremove-all)
    (define-key map (kbd "L") 'monky-rollback)
    map))

(defvar monky-log-mode-map
  (let ((map (make-keymap)))
    (define-key map (kbd "e") 'monky-log-show-more-entries)
    (define-key map (kbd "C") 'monky-checkout-item)
    (define-key map (kbd "M") 'monky-merge-item)
    (define-key map (kbd "B") 'monky-backout-item)
    (define-key map (kbd "i") 'monky-qimport-item)
    map))

(defvar monky-blame-mode-map
  (let ((map (make-keymap)))
    map))

(defvar monky-branches-mode-map
  (let ((map (make-keymap)))
    (define-key map (kbd "C") 'monky-checkout-item)
    (define-key map (kbd "M") 'monky-merge-item)
    map))

(defvar monky-commit-mode-map
  (let ((map (make-keymap)))
    map))

(defvar monky-queue-mode-map
  (let ((map (make-keymap)))
    (define-key map (kbd "u") 'monky-qpop-item)
    (define-key map (kbd "U") 'monky-qpop-all)
    (define-key map (kbd "s") 'monky-qpush-item)
    (define-key map (kbd "S") 'monky-qpush-all)
    (define-key map (kbd "r") 'monky-qrefresh)
    (define-key map (kbd "R") 'monky-qrename-item)
    (define-key map (kbd "k") 'monky-qremove-item)
    (define-key map (kbd "N") 'monky-qnew)
    (define-key map (kbd "f") 'monky-qfinish-item)
    (define-key map (kbd "F") 'monky-qfinish-applied)
    (define-key map (kbd "d") 'monky-qfold-item)
    (define-key map (kbd "G") 'monky-qguard-item)
    (define-key map (kbd "o") 'monky-qreorder)
    (define-key map (kbd "A") 'monky-addremove-all)
    map))

(defvar monky-pre-log-edit-window-configuration nil)
(defvar monky-log-edit-client-buffer nil)
(defvar monky-log-edit-operation nil)
(defvar monky-log-edit-info nil)

(defvar monky-log-edit-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "C-c C-c") 'monky-log-edit-commit)
    (define-key map (kbd "C-c C-k") 'monky-log-edit-cancel-log-message)
    (define-key map (kbd "C-x C-s")
      (lambda ()
        (interactive)
        (message "Not saved. Use C-c C-c to finalize this %s." monky-log-edit-operation)))
    map))

;;; Sections

(defvar-local monky-top-section nil)
(defvar monky-old-top-section nil)
(defvar monky-section-hidden-default nil)

;; A buffer in monky-mode is organized into hierarchical sections.
;; These sections are used for navigation and for hiding parts of the
;; buffer.
;;
;; Most sections also represent the objects that Monky works with,
;; such as files, diffs, hunks, commits, etc.  The 'type' of a section
;; identifies what kind of object it represents (if any), and the
;; parent and grand-parent, etc provide the context.

(defstruct monky-section
  parent children beginning end type title hidden info)

(defun monky-set-section-info (info &optional section)
  (setf (monky-section-info (or section monky-top-section)) info))


(defun monky-new-section (title type)
  "Create a new section with title TITLE and type TYPE in current buffer.

If not `monky-top-section' exist, the new section will be the new top-section
otherwise, the new-section will be a child of the current top-section.

If TYPE is nil, the section won't be highlighted."
  (let* ((s (make-monky-section :parent monky-top-section
                                :title title
                                :type type
                                :hidden monky-section-hidden-default))
         (old (and monky-old-top-section
                   (monky-find-section (monky-section-path s)
                                       monky-old-top-section))))
    (if monky-top-section
        (push s (monky-section-children monky-top-section))
      (setq monky-top-section s))
    (if old
        (setf (monky-section-hidden s) (monky-section-hidden old)))
    s))

(defmacro monky-with-section (title type &rest body)
  "Create a new section of title TITLE and type TYPE and evaluate BODY there.

Sections create into BODY will be child of the new section.
BODY must leave point at the end of the created section.

If TYPE is nil, the section won't be highlighted."
  (declare (indent 2)
           (debug (symbolp symbolp body)))
  (let ((s (make-symbol "*section*")))
    `(let* ((,s (monky-new-section ,title ,type))
            (monky-top-section ,s))
       (setf (monky-section-beginning ,s) (point))
       ,@body
       (setf (monky-section-end ,s) (point))
       (setf (monky-section-children ,s)
             (nreverse (monky-section-children ,s)))
       ,s)))

(defmacro monky-create-buffer-sections (&rest body)
  "Empty current buffer of text and monky's section, and then evaluate BODY."
  (declare (indent 0)
           (debug (body)))
  `(let ((inhibit-read-only t))
     (erase-buffer)
     (let ((monky-old-top-section monky-top-section))
       (setq monky-top-section nil)
       ,@body
       (when (null monky-top-section)
         (monky-with-section 'top nil
           (insert "(empty)\n")))
       (monky-propertize-section monky-top-section)
       (monky-section-set-hidden monky-top-section
                                 (monky-section-hidden monky-top-section)))))

(defun monky-propertize-section (section)
  "Add text-property needed for SECTION."
  (put-text-property (monky-section-beginning section)
                     (monky-section-end section)
                     'monky-section section)
  (dolist (s (monky-section-children section))
    (monky-propertize-section s)))

(defun monky-find-section (path top)
  "Find the section at the path PATH in subsection of section TOP."
  (if (null path)
      top
    (let ((secs (monky-section-children top)))
      (while (and secs (not (equal (car path)
                                   (monky-section-title (car secs)))))
        (setq secs (cdr secs)))
      (and (car secs)
           (monky-find-section (cdr path) (car secs))))))

(defun monky-section-path (section)
  "Return the path of SECTION."
  (if (not (monky-section-parent section))
      '()
    (append (monky-section-path (monky-section-parent section))
            (list (monky-section-title section)))))

(defun monky-insert-section (section-title-and-type buffer-title washer cmd &rest args)
  "Run CMD and put its result in a new section.

SECTION-TITLE-AND-TYPE is either a string that is the title of the section
or (TITLE . TYPE) where TITLE is the title of the section and TYPE is its type.

If there is no type, or if type is nil, the section won't be highlighted.

BUFFER-TITLE is the inserted title of the section

WASHER is a function that will be run after CMD.
The buffer will be narrowed to the inserted text.
It should add sectioning as needed for monky interaction

CMD is an external command that will be run with ARGS as arguments"
  (monky-with-process
    (let* ((body-beg nil)
           (section-title (if (consp section-title-and-type)
                              (car section-title-and-type)
                            section-title-and-type))
           (section-type (if (consp section-title-and-type)
                             (cdr section-title-and-type)
                           nil))
           (section (monky-with-section section-title section-type
                      (if buffer-title
                          (insert (propertize buffer-title 'face 'monky-section-title) "\n"))
                      (setq body-beg (point))
                      (apply 'monky-process-file cmd nil t nil args)
                      (if (not (eq (char-before) ?\n))
                          (insert "\n"))
                      (if washer
                          (save-restriction
                            (narrow-to-region body-beg (point))
                            (goto-char (point-min))
                            (funcall washer)
                            (goto-char (point-max)))))))
      (when (= body-beg (point))
        (monky-cancel-section section))
      section)))

(defun monky-cancel-section (section)
  (delete-region (monky-section-beginning section)
                 (monky-section-end section))
  (let ((parent (monky-section-parent section)))
    (if parent
        (setf (monky-section-children parent)
              (delq section (monky-section-children parent)))
      (setq monky-top-section nil))))

(defun monky-current-section ()
  "Return the monky section at point."
  (monky-section-at (point)))

(defun monky-section-at (pos)
  "Return the monky section at position POS."
  (or (get-text-property pos 'monky-section)
      monky-top-section))

(defun monky-find-section-after (pos secs)
  "Find the first section that begins after POS in the list SECS."
  (while (and secs
              (not (> (monky-section-beginning (car secs)) pos)))
    (setq secs (cdr secs)))
  (car secs))

(defun monky-find-section-before (pos secs)
  "Find the last section that begins before POS in the list SECS."
  (let ((prev nil))
    (while (and secs
                (not (> (monky-section-beginning (car secs)) pos)))
      (setq prev (car secs))
      (setq secs (cdr secs)))
    prev))

(defun monky-next-section (section)
  "Return the section that is after SECTION."
  (let ((parent (monky-section-parent section)))
    (if parent
        (let ((next (cadr (memq section
                                (monky-section-children parent)))))
          (or next
              (monky-next-section parent))))))

(defvar-local monky-submode nil)
(defvar-local monky-refresh-function nil)
(defvar-local monky-refresh-args nil)

(defun monky-goto-next-section ()
  "Go to the next monky section."
  (interactive)
  (let* ((section (monky-current-section))
         (next (or (and (not (monky-section-hidden section))
                        (monky-section-children section)
                        (monky-find-section-after (point)
                                                  (monky-section-children
                                                   section)))
                   (monky-next-section section))))
    (cond
     ((and next (eq (monky-section-type next) 'longer))
      (when monky-log-auto-more
        (monky-log-show-more-entries)
        (monky-goto-next-section)))
     (next
      (goto-char (monky-section-beginning next))
      (if (memq monky-submode '(log blame))
          (monky-show-commit next)))
     (t (message "No next section")))))

(defun monky-prev-section (section)
  "Return the section that is before SECTION."
  (let ((parent (monky-section-parent section)))
    (if parent
        (let ((prev (cadr (memq section
                                (reverse (monky-section-children parent))))))
          (cond (prev
                 (while (and (not (monky-section-hidden prev))
                             (monky-section-children prev))
                   (setq prev (car (reverse (monky-section-children prev)))))
                 prev)
                (t
                 parent))))))


(defun monky-goto-previous-section ()
  "Goto the previous monky section."
  (interactive)
  (let ((section (monky-current-section)))
    (cond ((= (point) (monky-section-beginning section))
           (let ((prev (monky-prev-section (monky-current-section))))
             (if prev
                 (progn
                   (if (memq monky-submode '(log blame))
                       (monky-show-commit prev))
                   (goto-char (monky-section-beginning prev)))
               (message "No previous section"))))
          (t
           (let ((prev (monky-find-section-before (point)
                                                  (monky-section-children
                                                   section))))
             (if (memq monky-submode '(log blame))
                 (monky-show-commit (or prev section)))
             (goto-char (monky-section-beginning (or prev section))))))))


(defun monky-section-context-type (section)
  (if (null section)
      '()
    (let ((c (or (monky-section-type section)
                 (if (symbolp (monky-section-title section))
                     (monky-section-title section)))))
      (if c
          (cons c (monky-section-context-type
                   (monky-section-parent section)))
        '()))))

(defun monky-hg-section (section-title-and-type buffer-title washer &rest args)
  (apply #'monky-insert-section
         section-title-and-type
         buffer-title
         washer
         monky-hg-executable
         (append monky-hg-standard-options args)))

(defun monky-section-set-hidden (section hidden)
  "Hide SECTION if HIDDEN is not nil, show it otherwise."
  (setf (monky-section-hidden section) hidden)
  (let ((inhibit-read-only t)
        (beg (save-excursion
               (goto-char (monky-section-beginning section))
               (forward-line)
               (point)))
        (end (monky-section-end section)))
    (if (< beg end)
        (put-text-property beg end 'invisible hidden)))
  (if (not hidden)
      (dolist (c (monky-section-children section))
        (monky-section-set-hidden c (monky-section-hidden c)))))

(defun monky-toggle-section ()
  "Toggle hidden status of current section."
  (interactive)
  (let ((section (monky-current-section)))
    (when (monky-section-parent section)
      (goto-char (monky-section-beginning section))
      (monky-section-set-hidden section (not (monky-section-hidden section))))))

(defun monky-section-show-level-1-all ()
  "Collapse all the sections in the monky status buffer."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (while (not (eobp))
      (let ((section (monky-current-section)))
	(monky-section-set-hidden section t))
      (forward-line 1))))

(defun monky-section-show-level-2-all ()
  "Show all the files changes, but not their contents."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (while (not (eobp))
      (let ((section (monky-current-section)))
	(if (memq (monky-section-type section) (list 'hunk 'diff))
	    (monky-section-set-hidden section t)
	  (monky-section-set-hidden section nil)))
      (forward-line 1))))

(defun monky-section-show-level-3-all ()
  "Expand all file contents and line numbers, but not the actual changes."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (while (not (eobp))
      (let ((section (monky-current-section)))
	(if (memq (monky-section-type section) (list 'hunk))
	    (monky-section-set-hidden section t)
	  (monky-section-set-hidden section nil)))
      (forward-line 1))))

(defun monky-section-show-level-4-all ()
  "Expand all sections."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (while (not (eobp))
      (let ((section (monky-current-section)))
	(monky-section-set-hidden section nil))
      (forward-line 1))))

;;; Running commands

(defun monky-set-mode-line-process (str)
  (let ((pr (if str (concat " " str) "")))
    (save-excursion
      (monky-for-all-buffers (lambda ()
                               (setq mode-line-process pr))))))

(defun monky-process-indicator-from-command (comps)
  (if (monky-prefix-p (cons monky-hg-executable monky-hg-standard-options)
                      comps)
      (setq comps (nthcdr (+ (length monky-hg-standard-options) 1) comps)))
  (car comps))

(defun monky-run* (cmd-and-args
		   &optional logline noerase noerror nowait input)
  (if (and monky-process
           (get-buffer monky-process-buffer-name))
      (error "Hg is already running"))
  (let ((cmd (car cmd-and-args))
        (args (cdr cmd-and-args))
        (dir default-directory)
        (buf (get-buffer-create monky-process-buffer-name))
        (successp nil))
    (monky-set-mode-line-process
     (monky-process-indicator-from-command cmd-and-args))
    (setq monky-process-client-buffer (current-buffer))
    (with-current-buffer buf
      (view-mode 1)
      (set (make-local-variable 'view-no-disable-on-exit) t)
      (setq view-exit-action
            (lambda (buffer)
              (with-current-buffer buffer
                (bury-buffer))))
      (setq buffer-read-only t)
      (let ((inhibit-read-only t))
        (setq default-directory dir)
        (if noerase
            (goto-char (point-max))
          (erase-buffer))
        (insert "$ " (or logline
                         (mapconcat #'identity cmd-and-args " "))
                "\n")
        (cond (nowait
               (setq monky-process
                     (let ((process-connection-type nil))
                       (apply 'monky-start-process cmd buf cmd args)))
               (set-process-sentinel monky-process 'monky-process-sentinel)
               (set-process-filter monky-process 'monky-process-filter)
               (when input
                 (with-current-buffer input
                   (process-send-region monky-process
                                        (point-min) (point-max))
                   (process-send-eof monky-process)
                   (sit-for 0.1 t)))
               (cond ((= monky-process-popup-time 0)
                      (pop-to-buffer (process-buffer monky-process)))
                     ((> monky-process-popup-time 0)
                      (run-with-timer
                       monky-process-popup-time nil
                       (function
                        (lambda (buf)
                          (with-current-buffer buf
                            (when monky-process
                              (display-buffer (process-buffer monky-process))
                              (goto-char (point-max))))))
                       (current-buffer))))
               (setq successp t))
	      (monky-cmd-process
	       (let ((monky-cmd-process-input-buffer input)
		     (monky-cmd-process-input-point (and input
						         (with-current-buffer input
						           (point-min)))))
		 (setq successp
		       (equal (apply #'monky-cmdserver-runcommand (cdr cmd-and-args)) 0))
		 (monky-set-mode-line-process nil)
		 (monky-need-refresh monky-process-client-buffer)))
              (input
               (with-current-buffer input
                 (setq default-directory dir)
                 (setq monky-process
                       ;; Don't use a pty, because it would set icrnl
                       ;; which would modify the input (issue #20).
                       (let ((process-connection-type nil))
                         (apply 'monky-start-process cmd buf cmd args)))
                 (set-process-filter monky-process 'monky-process-filter)
                 (process-send-region monky-process
                                      (point-min) (point-max))
                 (process-send-eof monky-process)
                 (while (equal (process-status monky-process) 'run)
                   (sit-for 0.1 t))
                 (setq successp
                       (equal (process-exit-status monky-process) 0))
                 (setq monky-process nil))
               (monky-set-mode-line-process nil)
               (monky-need-refresh monky-process-client-buffer))
              (t
               (setq successp
                     (equal (apply 'monky-process-file-single cmd nil buf nil args) 0))
               (monky-set-mode-line-process nil)
               (monky-need-refresh monky-process-client-buffer))))
      (or successp
          noerror
          (error
           (or monky-cmd-error-message
	       (monky-abort-message (get-buffer monky-process-buffer-name))
               "Hg failed")))
      successp)))


(defun monky-process-sentinel (process event)
  (let ((msg (format "Hg %s." (substring event 0 -1)))
        (successp (string-match "^finished" event)))
    (with-current-buffer (process-buffer process)
      (let ((inhibit-read-only t))
        (goto-char (point-max))
        (insert msg "\n")
        (message msg)))
    (when (not successp)
      (let ((msg (monky-abort-message (process-buffer process))))
        (when msg
          (message msg))))
    (setq monky-process nil)
    (monky-set-mode-line-process nil)
    (if (buffer-live-p monky-process-client-buffer)
        (with-current-buffer monky-process-client-buffer
          (monky-with-refresh
            (monky-need-refresh monky-process-client-buffer))))))

(defun monky-abort-message (buffer)
  (with-current-buffer buffer
    (save-excursion
      (goto-char (point-min))
      (when (re-search-forward
             (concat "^abort: \\(.*\\)" paragraph-separate) nil t)
        (match-string 1)))))

;; TODO password?

(defun monky-process-filter (proc string)
  (save-current-buffer
    (set-buffer (process-buffer proc))
    (let ((inhibit-read-only t))
      (goto-char (process-mark proc))
      (insert string)
      (set-marker (process-mark proc) (point)))))


(defun monky-run-hg (&rest args)
  (monky-with-refresh
    (monky-run* (append (cons monky-hg-executable
                              monky-hg-standard-options)
                        args))))

(defun monky-run-hg-sync (&rest args)
  (message "Running %s %s"
           monky-hg-executable
           (mapconcat #'identity args " "))
  (monky-run* (append (cons monky-hg-executable
			    monky-hg-standard-options)
		      args)))

(defun monky-run-hg-async (&rest args)
  (message "Running %s %s"
           monky-hg-executable
           (mapconcat #'identity args " "))
  (monky-run* (append (cons monky-hg-executable
                            monky-hg-standard-options)
                      args)
              nil nil nil t))

(defun monky-run-async-with-input (input cmd &rest args)
  (monky-run* (cons cmd args) nil nil nil t input))

(defun monky-display-process ()
  "Display output from most recent hg command."
  (interactive)
  (unless (get-buffer monky-process-buffer-name)
    (user-error "No Hg commands have run"))
  (display-buffer monky-process-buffer-name))

(defun monky-hg-command (command)
  "Perform arbitrary Hg COMMAND."
  (interactive "sRun hg like this: ")
  (let ((args (monky-parse-args command))
        (monky-process-popup-time 0))
    (monky-with-refresh
      (monky-run* (append (cons monky-hg-executable
                                monky-hg-standard-options)
                          args)
                  nil nil nil t))))

;;; Actions

(defmacro monky-section-case (opname &rest clauses)
  "Make different action depending of current section.

HEAD is (SECTION INFO &optional OPNAME),
  SECTION will be bind to the current section,
  INFO will be bind to the info's of the current section,
  OPNAME is a string that will be used to describe current action,

CLAUSES is a list of CLAUSE, each clause is (SECTION-TYPE &BODY)
where SECTION-TYPE describe section where BODY will be run.

This returns non-nil if some section matches.  If the
corresponding body return a non-nil value, it is returned,
otherwise it return t.

If no section matches, this returns nil if no OPNAME was given
and throws an error otherwise."

  (declare (indent 1)
           (debug (form &rest (sexp body))))
  (let ((section (make-symbol "*section*"))
        (type (make-symbol "*type*"))
        (context (make-symbol "*context*")))
    `(let* ((,section (monky-current-section))
            (,type (monky-section-type ,section))
            (,context (monky-section-context-type ,section)))
       (cond ,@(mapcar (lambda (clause)
                         (let ((prefix (car clause))
                               (body (cdr clause)))
                           `(,(if (eq prefix t)
                                  `t
                                `(monky-prefix-p ',(reverse prefix) ,context))
                             (or (progn ,@body)
                                 t))))
                       clauses)
             ,@(when opname
                 `(((not ,type)
                    (user-error "Nothing to %s here" ,opname))
                   (t
                    (error "Can't %s as %s"
                           ,opname
                           ,type))))))))

(defmacro monky-section-action (opname &rest clauses)
  "Refresh monky buffers after executing action defined in CLAUSES.

See `monky-section-case' for the definition of HEAD and CLAUSES and
`monky-with-refresh' for how the buffers are refreshed."
  (declare (indent 1)
           (debug (form &rest (sexp body))))
  `(monky-with-refresh
     (monky-section-case ,opname ,@clauses)))

(defun monky-visit-item (&optional other-window)
  "Visit current item.
With a prefix argument, visit in other window."
  (interactive (list current-prefix-arg))
  (let ((ff (if other-window 'find-file-other-window 'find-file)))
    (monky-section-action "visit"
      ((file)
       (funcall ff (monky-section-info (monky-current-section))))
      ((diff)
       (funcall ff (monky-diff-item-file (monky-current-section))))
      ((hunk)
       (let ((file (monky-diff-item-file (monky-hunk-item-diff (monky-current-section))))
             (line (monky-hunk-item-target-line (monky-current-section))))
         (funcall ff file)
         (goto-char (point-min))
         (forward-line (1- line))))
      ((commit)
       (monky-show-commit (monky-section-info (monky-current-section))))
      ((longer)
       …

Large files files are truncated, but you can click here to view the full file