PageRenderTime 117ms CodeModel.GetById 3ms app.highlight 89ms RepoModel.GetById 1ms app.codeStats 1ms

/monky.el

http://github.com/ananthakumaran/monky
Emacs Lisp | 3276 lines | 2749 code | 432 blank | 95 comment | 54 complexity | 863a30ac743630b265f81a214c3a9723 MD5 | raw file
   1;;; monky.el --- Control Hg from Emacs.  -*- lexical-binding: t; -*-
   2
   3;; Copyright (C) 2011 Anantha Kumaran.
   4
   5;; Author: Anantha kumaran <ananthakumaran@gmail.com>
   6;; URL: http://github.com/ananthakumaran/monky
   7;; Version: 0.2
   8;; Keywords: tools
   9
  10;; Monky is free software: you can redistribute it and/or modify it
  11;; under the terms of the GNU General Public License as published by
  12;; the Free Software Foundation, either version 3 of the License, or
  13;; (at your option) any later version.
  14
  15;; Monky is distributed in the hope that it will be useful, but
  16;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18;; General Public License for more details.
  19
  20;; You should have received a copy of the GNU General Public License
  21;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23;;; Commentary:
  24
  25;;; Code:
  26
  27(require 'cl)
  28(require 'cl-lib)
  29(require 'bindat)
  30(require 'ediff)
  31(require 'subr-x)
  32(require 'view)
  33(require 'tramp)
  34
  35(defgroup monky nil
  36  "Controlling Hg from Emacs."
  37  :prefix "monky-"
  38  :group 'tools)
  39
  40(defcustom monky-hg-executable "hg"
  41  "The name of the Hg executable."
  42  :group 'monky
  43  :type 'string)
  44
  45(defcustom monky-hg-standard-options '("--config" "diff.git=Off" "--config" "ui.merge=:merge")
  46  "Standard options when running Hg."
  47  :group 'monky
  48  :type '(repeat string))
  49
  50(defcustom monky-hg-process-environment '("TERM=dumb" "HGPLAIN=" "LANGUAGE=C")
  51  "Default environment variables for hg."
  52  :group 'monky
  53  :type '(repeat string))
  54
  55;; TODO
  56(defcustom monky-save-some-buffers t
  57  "Non-nil means that \\[monky-status] will save modified buffers before running.
  58Setting this to t will ask which buffers to save, setting it to 'dontask will
  59save all modified buffers without asking."
  60  :group 'monky
  61  :type '(choice (const :tag "Never" nil)
  62                 (const :tag "Ask" t)
  63                 (const :tag "Save without asking" dontask)))
  64
  65(defcustom monky-revert-item-confirm t
  66  "Require acknowledgment before reverting an item."
  67  :group 'monky
  68  :type 'boolean)
  69
  70(defcustom monky-log-edit-confirm-cancellation nil
  71  "Require acknowledgment before canceling the log edit buffer."
  72  :group 'monky
  73  :type 'boolean)
  74
  75(defcustom monky-process-popup-time -1
  76  "Popup the process buffer if a command takes longer than this many seconds."
  77  :group 'monky
  78  :type '(choice (const :tag "Never" -1)
  79                 (const :tag "Immediately" 0)
  80                 (integer :tag "After this many seconds")))
  81
  82(defcustom monky-log-cutoff-length 100
  83  "The maximum number of commits to show in the log buffer."
  84  :group 'monky
  85  :type 'integer)
  86
  87(defcustom monky-log-infinite-length 99999
  88  "Number of log used to show as maximum for `monky-log-cutoff-length'."
  89  :group 'monky
  90  :type 'integer)
  91
  92(defcustom monky-log-auto-more t
  93  "Insert more log entries automatically when moving past the last entry.
  94
  95Only considered when moving past the last entry with `monky-goto-next-section'."
  96  :group 'monky
  97  :type 'boolean)
  98
  99(defcustom monky-incoming-repository "default"
 100  "The repository from which changes are pulled from by default."
 101  :group 'monky
 102  :type 'string)
 103
 104(defcustom monky-outgoing-repository ""
 105  "The repository to which changes are pushed to by default."
 106  :group 'monky
 107  :type 'string)
 108
 109(defcustom monky-process-type nil
 110  "How monky spawns Mercurial processes.
 111Monky can either spawn a new Mercurial process for each request or
 112use Mercurial's command server feature to run several commands in a
 113single process instances. While the former is more robust, the latter
 114is usually faster if Monky runs several commands."
 115  :group 'monky
 116  :type '(choice (const :tag "Single processes" :value nil)
 117                 (const :tag "Use command server" :value cmdserver)))
 118
 119(defcustom monky-pull-args ()
 120  "Extra args to pass to pull."
 121  :group 'monky
 122  :type '(repeat string))
 123
 124(defcustom monky-repository-paths nil
 125  "*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.
 126
 127Lisp-type of this option: The value must be a list L whereas each
 128element of L is a 2-element list: The first element is the full
 129path of a directory \(string) and the second element is an
 130arbitrary alias \(string) for this directory which is then
 131displayed instead of the underlying directory."
 132  :group 'monky
 133  :initialize 'custom-initialize-default
 134  :set (function (lambda (symbol value)
 135                   (set symbol value)
 136                   (if (and (boundp 'ecb-minor-mode)
 137                            ecb-minor-mode
 138			    (functionp 'ecb-update-directories-buffer))
 139		       (ecb-update-directories-buffer))))
 140  :type '(repeat (cons :tag "Path with alias"
 141		       (string :tag "Alias")
 142		       (directory :tag "Path"))))
 143
 144(defun monky-root-dir-descr (dir)
 145  "Return the name of dir if it matches a path in monky-repository-paths, otherwise return nil"
 146  (catch 'exit
 147    (dolist (root-dir monky-repository-paths)
 148      (let ((base-dir
 149	     (concat
 150	      (replace-regexp-in-string
 151	       "/$" ""
 152	       (replace-regexp-in-string
 153		"^\~" (getenv "HOME")
 154		(cdr root-dir)))
 155	      "/")))
 156	(when (equal base-dir dir)
 157	  (throw 'exit (cons (car root-dir)
 158			     base-dir)))))))
 159
 160(defun monky-open-repository ()
 161  "Prompt for a repository path or alias, then display the status
 162buffer.  Aliases are set in monky-repository-paths."
 163  (interactive)
 164  (let* ((rootdir (condition-case nil
 165		      (monky-get-root-dir)
 166		    (error nil)))
 167	 (default-repo (or (monky-root-dir-descr rootdir) rootdir))
 168	 (msg (if default-repo
 169		  (concat "repository (default " (car default-repo) "): ")
 170		"repository: "))
 171	 (repo-name (completing-read msg (mapcar 'car monky-repository-paths)))
 172	 (repo (or (assoc repo-name monky-repository-paths) default-repo)))
 173    (when repo (monky-status (cdr repo)))))
 174
 175(defgroup monky-faces nil
 176  "Customize the appearance of Monky"
 177  :prefix "monky-"
 178  :group 'faces
 179  :group 'monky)
 180
 181(defface monky-header
 182  '((t :weight bold))
 183  "Face for generic header lines.
 184
 185Many Monky faces inherit from this one by default."
 186  :group 'monky-faces)
 187
 188(defface monky-section-title
 189  '((((class color) (background light)) :foreground "DarkGoldenrod4" :inherit monky-header)
 190    (((class color) (background  dark)) :foreground "LightGoldenrod2" :inherit monky-header))
 191  "Face for section titles."
 192  :group 'monky-faces)
 193
 194(defface monky-branch
 195  '((t :weight bold :inherit monky-header))
 196  "Face for the current branch."
 197  :group 'monky-faces)
 198
 199(defface monky-diff-title
 200  '((t :inherit (monky-header)))
 201  "Face for diff title lines."
 202  :group 'monky-faces)
 203
 204(defface monky-diff-hunk-header
 205  '((((class color) (background light))
 206     :background "grey80"
 207     :foreground "grey30")
 208    (((class color) (background dark))
 209     :background "grey25"
 210     :foreground "grey70"))
 211  "Face for diff hunk header lines."
 212  :group 'monky-faces)
 213
 214(defface monky-diff-add
 215  '((((class color) (background light))
 216     :background "#cceecc"
 217     :foreground "#22aa22")
 218    (((class color) (background dark))
 219     :background "#336633"
 220     :foreground "#cceecc"))
 221  "Face for lines in a diff that have been added."
 222  :group 'monky-faces)
 223
 224(defface monky-diff-none
 225  '((t))
 226  "Face for lines in a diff that are unchanged."
 227  :group 'monky-faces)
 228
 229(defface monky-diff-del
 230  '((((class color) (background light))
 231     :background "#eecccc"
 232     :foreground "#aa2222")
 233    (((class color) (background dark))
 234     :background "#663333"
 235     :foreground "#eecccc"))
 236  "Face for lines in a diff that have been deleted."
 237  :group 'monky-faces)
 238
 239(defface monky-commit-id
 240  '((((class color) (background light))
 241     :foreground "firebrick")
 242    (((class color) (background dark))
 243     :foreground "tomato"))
 244  "Face for commit IDs: SHA1 codes and commit numbers."
 245  :group 'monky-faces)
 246
 247(defface monky-log-sha1
 248  '((t :inherit monky-commit-id))
 249  "Face for the sha1 element of the log output."
 250  :group 'monky-faces)
 251
 252(defface monky-log-message
 253  '((t))
 254  "Face for the message element of the log output."
 255  :group 'monky-faces)
 256
 257(defface monky-log-author
 258  '((((class color) (background light))
 259     :foreground "navy")
 260    (((class color) (background dark))
 261     :foreground "cornflower blue"))
 262  "Face for author shown in log buffer."
 263  :group 'monky-faces)
 264
 265(defface monky-log-head-label-local
 266  '((((class color) (background light))
 267     :box t
 268     :background "Grey85"
 269     :foreground "LightSkyBlue4")
 270    (((class color) (background dark))
 271     :box t
 272     :background "Grey13"
 273     :foreground "LightSkyBlue1"))
 274  "Face for local branch head labels shown in log buffer."
 275  :group 'monky-faces)
 276
 277(defface monky-log-head-label-tags
 278  '((((class color) (background light))
 279     :box t
 280     :background "LemonChiffon1"
 281     :foreground "goldenrod4")
 282    (((class color) (background dark))
 283     :box t
 284     :background "LemonChiffon1"
 285     :foreground "goldenrod4"))
 286  "Face for tag labels shown in log buffer."
 287  :group 'monky-faces)
 288
 289(defface monky-queue-patch
 290  '((t :weight bold :inherit (monky-header highlight)))
 291  "Face for patch name"
 292  :group 'monky-faces)
 293
 294(defface monky-log-head-label-bookmarks
 295  '((((class color) (background light))
 296     :box t
 297     :background "IndianRed1"
 298     :foreground "IndianRed4")
 299    (((class color) (background dark))
 300     :box t
 301     :background "IndianRed1"
 302     :foreground "IndianRed4"))
 303  "Face for bookmark labels shown in log buffer."
 304  :group 'monky-faces)
 305
 306(defface monky-log-head-label-phase
 307  '((((class color) (background light))
 308     :box t
 309     :background "light green"
 310     :foreground "dark olive green")
 311    (((class color) (background dark))
 312     :box t
 313     :background "light green"
 314     :foreground "dark olive green"))
 315  "Face for phase label shown in log buffer."
 316  :group 'monky-faces)
 317
 318(defface monky-log-date
 319  '((t :weight bold :inherit monky-header))
 320  "Face for date in log."
 321  :group 'monky-faces)
 322
 323(defface monky-queue-active
 324  '((((class color) (background light))
 325     :box t
 326     :background "light green"
 327     :foreground "dark olive green")
 328    (((class color) (background dark))
 329     :box t
 330     :background "light green"
 331     :foreground "dark olive green"))
 332  "Face for active patch queue"
 333  :group 'monky-faces)
 334
 335(defface monky-queue-positive-guard
 336  '((((class color) (background light))
 337     :box t
 338     :background "light green"
 339     :foreground "dark olive green")
 340    (((class color) (background dark))
 341     :box t
 342     :background "light green"
 343     :foreground "dark olive green"))
 344  "Face for queue postive guards"
 345  :group 'monky-faces)
 346
 347(defface monky-queue-negative-guard
 348  '((((class color) (background light))
 349     :box t
 350     :background "IndianRed1"
 351     :foreground "IndianRed4")
 352    (((class color) (background dark))
 353     :box t
 354     :background "IndianRed1"
 355     :foreground "IndianRed4"))
 356  "Face for queue negative guards"
 357  :group 'monky-faces)
 358
 359(defvar monky-mode-hook nil
 360  "Hook run by `monky-mode'.")
 361
 362;;; User facing configuration
 363
 364(put 'monky-mode 'mode-class 'special)
 365
 366;;; Compatibilities
 367
 368(eval-when-compile
 369  (when (< emacs-major-version 23)
 370    (defvar line-move-visual nil)))
 371
 372;;; Utilities
 373
 374(defmacro monky-with-process-environment (&rest body)
 375  (declare (indent 0)
 376           (debug (body)))
 377  `(let ((process-environment (append monky-hg-process-environment
 378                                      process-environment)))
 379     ,@body))
 380
 381(defmacro monky-with-refresh (&rest body)
 382  "Refresh monky buffers after evaluating BODY.
 383
 384It is safe to call the functions which uses this macro inside of
 385this macro.  As it is time consuming to refresh monky buffers,
 386this macro enforces refresh to occur exactly once by pending
 387refreshes inside of this macro.  Nested calls of this
 388macro (possibly via functions) does not refresh buffers multiple
 389times.  Instead, only the outside-most call of this macro
 390refreshes buffers."
 391  (declare (indent 0)
 392           (debug (body)))
 393  `(monky-refresh-wrapper (lambda () ,@body)))
 394
 395(defun monky-completing-read (&rest args)
 396  (apply (if (null ido-mode)
 397             'completing-read
 398           'ido-completing-read)
 399         args))
 400
 401(defun monky-start-process (&rest args)
 402  (monky-with-process-environment
 403    (apply (if (functionp 'start-file-process)
 404               'start-file-process
 405             'start-process) args)))
 406
 407(defun monky-process-file-single (&rest args)
 408  (monky-with-process-environment
 409    (apply 'process-file args)))
 410
 411
 412;; Command server
 413(defvar monky-process nil)
 414(defvar monky-process-buffer-name "*monky-process*")
 415(defvar monky-process-client-buffer nil)
 416
 417(defvar monky-cmd-process nil)
 418(defvar monky-cmd-process-buffer-name "*monky-cmd-process*")
 419(defvar monky-cmd-process-input-buffer nil)
 420(defvar monky-cmd-process-input-point nil)
 421(defvar monky-cmd-error-message nil)
 422(defvar monky-cmd-hello-message nil
 423  "Variable to store parsed hello message.")
 424
 425;; TODO: does this need to be permanent? If it's only used in monky buffers (not source file buffers), it shouldn't be.
 426(defvar-local monky-root-dir nil)
 427(put 'monky-root-dir 'permanent-local t)
 428
 429(defun monky-cmdserver-sentinel (proc _change)
 430  (unless (memq (process-status proc) '(run stop))
 431    (delete-process proc)))
 432
 433(defun monky-cmdserver-read-data (size)
 434  (with-current-buffer (process-buffer monky-cmd-process)
 435    (while (< (point-max) size)
 436      (accept-process-output monky-cmd-process 0.1 nil t))
 437    (let ((str (buffer-substring (point-min) (+ (point-min) size))))
 438      (delete-region (point-min) (+ (point-min) size))
 439      (goto-char (point-min))
 440      (vconcat str))))
 441
 442(defun monky-cmdserver-read ()
 443  "Read one channel and return cons (CHANNEL . RAW-DATA)."
 444  (let* ((data (bindat-unpack '((channel byte) (len u32))
 445                              (monky-cmdserver-read-data 5)))
 446         (channel (bindat-get-field data 'channel))
 447         (len (bindat-get-field data 'len)))
 448    (cons channel (monky-cmdserver-read-data len))))
 449
 450(defun monky-cmdserver-unpack-int (data)
 451  (bindat-get-field (bindat-unpack '((field u32)) data) 'field))
 452
 453(defun monky-cmdserver-unpack-string (data)
 454  (bindat-get-field (bindat-unpack `((field str ,(length data))) data) 'field))
 455
 456(defun monky-cmdserver-write (data)
 457  (process-send-string monky-cmd-process
 458                       (concat (bindat-pack '((len u32))
 459                                            `((len . ,(length data))))
 460                               data)))
 461
 462(defun monky-cmdserver-start ()
 463  (unless monky-root-dir
 464    (let (monky-process monky-process-type)
 465      (setq monky-root-dir (monky-get-root-dir))))
 466
 467  (let ((dir monky-root-dir)
 468        (buf (get-buffer-create monky-cmd-process-buffer-name))
 469        (default-directory monky-root-dir)
 470        (process-connection-type nil))
 471    (with-current-buffer buf
 472      (setq buffer-read-only nil)
 473      (setq buffer-file-coding-system 'no-conversion)
 474      (set-buffer-multibyte nil)
 475      (erase-buffer)
 476      (setq view-exit-action
 477            #'(lambda (buffer)
 478                (with-current-buffer buffer
 479                  (bury-buffer))))
 480      (setq default-directory dir)
 481      (let ((monky-cmd-process (monky-start-process
 482                                "monky-hg" buf "sh" "-c"
 483                                (format "%s --config extensions.mq= serve --cmdserver pipe 2> /dev/null" monky-hg-executable))))
 484        (set-process-coding-system monky-cmd-process 'no-conversion 'no-conversion)
 485        (set-process-sentinel monky-cmd-process #'monky-cmdserver-sentinel)
 486        (setq monky-cmd-hello-message
 487              (monky-cmdserver-parse-hello (monky-cmdserver-read)))
 488        monky-cmd-process))))
 489
 490(defun monky-cmdserver-parse-hello (hello-message)
 491  "Parse hello message to get encoding information."
 492  (let ((channel (car hello-message))
 493        (text (cdr hello-message)))
 494    (if (eq channel ?o)
 495        (progn
 496          (mapcar
 497           (lambda (s)
 498             (string-match "^\\([a-z0-9]+\\) *: *\\(.*\\)$" s)
 499             (let ((field-name (match-string 1 s))
 500                   (field-data (match-string 2 s)))
 501               (cons (intern field-name) field-data)))
 502           (split-string (monky-cmdserver-unpack-string text) "\n")))
 503      (error "unknown channel %c for hello message" channel))))
 504
 505(defun monky-cmdserver-get-encoding (&optional default)
 506  "Get encoding stored in `monky-cmd-hello-message'."
 507  (let ((e (assoc 'encoding monky-cmd-hello-message)))
 508    (if e
 509        (cond
 510         ((string-equal (downcase (cdr e)) "ascii")
 511          'us-ascii)
 512         (t
 513          (intern (downcase (cdr e)))))
 514      default)))
 515
 516(defun monky-cmdserver-runcommand (&rest cmd-and-args)
 517  (setq monky-cmd-error-message nil)
 518  (with-current-buffer (process-buffer monky-cmd-process)
 519    (setq buffer-read-only nil)
 520    (erase-buffer))
 521  (process-send-string monky-cmd-process "runcommand\n")
 522  (monky-cmdserver-write (mapconcat #'identity cmd-and-args "\0"))
 523  (let* ((inhibit-read-only t)
 524         (start (point))
 525         (result
 526          (catch 'finished
 527            (while t
 528              (let* ((result (monky-cmdserver-read))
 529                     (channel (car result))
 530                     (text (cdr result)))
 531                (cond
 532                 ((eq channel ?o)
 533                  (insert (monky-cmdserver-unpack-string text)))
 534                 ((eq channel ?r)
 535                  (throw 'finished
 536                         (monky-cmdserver-unpack-int text)))
 537                 ((eq channel ?e)
 538                  (setq monky-cmd-error-message
 539                        (concat monky-cmd-error-message text)))
 540                 ((memq channel '(?I ?L))
 541                  (with-current-buffer monky-cmd-process-input-buffer
 542                    (let* ((max (if (eq channel ?I)
 543                                    (point-max)
 544                                  (save-excursion
 545                                    (goto-char monky-cmd-process-input-point)
 546                                    (line-beginning-position 2))))
 547                           (maxreq (monky-cmdserver-unpack-int text))
 548                           (len (min (- max monky-cmd-process-input-point)
 549                                     maxreq))
 550                           (end (+ monky-cmd-process-input-point len)))
 551                      (monky-cmdserver-write
 552                       (buffer-substring monky-cmd-process-input-point end))
 553                      (setq monky-cmd-process-input-point end))))
 554                 (t
 555                  (setq monky-cmd-error-message
 556                        (format "Unsupported channel: %c" channel)))))))))
 557    (decode-coding-region start (point)
 558                          (monky-cmdserver-get-encoding 'utf-8))
 559    result))
 560
 561(defun monky-cmdserver-process-file (program infile buffer display &rest args)
 562  "Same as `process-file' but uses the currently active hg command-server."
 563  (if (or infile display)
 564      (apply #'monky-process-file-single program infile buffer display args)
 565    (let ((stdout (if (consp buffer) (car buffer) buffer))
 566          (stderr (and (consp buffer) (cadr buffer))))
 567      (if (eq stdout t) (setq stdout (current-buffer)))
 568      (if (eq stderr t) (setq stderr stdout))
 569      (let ((result
 570             (if stdout
 571                 (with-current-buffer stdout
 572                   (apply #'monky-cmdserver-runcommand args))
 573               (with-temp-buffer
 574                 (apply #'monky-cmdserver-runcommand args)))))
 575        (cond
 576         ((bufferp stderr)
 577          (when monky-cmd-error-message
 578            (with-current-buffer stderr
 579              (insert monky-cmd-error-message))))
 580         ((stringp stderr)
 581          (with-temp-file stderr
 582            (when monky-cmd-error-message
 583              (insert monky-cmd-error-message)))))
 584        result))))
 585
 586(defun monky-process-file (&rest args)
 587  "Same as `process-file' in the current hg environment.
 588This function either calls `monky-cmdserver-process-file' or
 589`monky-process-file-single' depending on whether the hg
 590command-server should be used."
 591  (apply (cond
 592          (monky-cmd-process #'monky-cmdserver-process-file)
 593          ;; ((eq monky-process-type 'cmdserver)
 594          ;;  (error "No process started (forget `monky-with-process`?)"))
 595          (t #'monky-process-file-single))
 596         args))
 597
 598(defmacro monky-with-process (&rest body)
 599  (declare (indent 0)
 600	   (debug (body)))
 601  `(let ((outer (not monky-cmd-process)))
 602     (when (and outer (eq monky-process-type 'cmdserver))
 603       (setq monky-cmd-process (monky-cmdserver-start)))
 604     (unwind-protect
 605	 (progn ,@body)
 606       (when (and monky-cmd-process outer (eq monky-process-type 'cmdserver))
 607	 (delete-process monky-cmd-process)
 608	 (setq monky-cmd-process nil)))))
 609
 610
 611
 612(defvar monky-bug-report-url "http://github.com/ananthakumaran/monky/issues")
 613(defun monky-bug-report (str)
 614  (message "Unknown error: %s\nPlease file a bug at %s"
 615           str monky-bug-report-url))
 616
 617(defun monky-string-starts-with-p (string prefix)
 618  (eq (compare-strings string nil (length prefix) prefix nil nil) t))
 619
 620(defun monky-trim-line (str)
 621  (if (string= str "")
 622      nil
 623    (if (equal (elt str (- (length str) 1)) ?\n)
 624        (substring str 0 (- (length str) 1))
 625      str)))
 626
 627(defun monky-delete-line (&optional end)
 628  "Delete the text in current line.
 629If END is non-nil, deletes the text including the newline character"
 630  (let ((end-point (if end
 631                       (1+ (point-at-eol))
 632                     (point-at-eol))))
 633    (delete-region (point-at-bol) end-point)))
 634
 635(defun monky-split-lines (str)
 636  (if (string= str "")
 637      nil
 638    (let ((lines (nreverse (split-string str "\n"))))
 639      (if (string= (car lines) "")
 640          (setq lines (cdr lines)))
 641      (nreverse lines))))
 642
 643(defun monky-put-line-property (prop val)
 644  (put-text-property (line-beginning-position) (line-beginning-position 2)
 645                     prop val))
 646
 647(defun monky-parse-args (command)
 648  (require 'pcomplete)
 649  (car (with-temp-buffer
 650         (insert command)
 651         (pcomplete-parse-buffer-arguments))))
 652
 653(defun monky-prefix-p (prefix list)
 654  "Return non-nil if PREFIX is a prefix of LIST.
 655PREFIX and LIST should both be lists.
 656
 657If the car of PREFIX is the symbol '*, then return non-nil if the cdr of PREFIX
 658is a sublist of LIST (as if '* matched zero or more arbitrary elements of LIST)"
 659  (or (null prefix)
 660      (if (eq (car prefix) '*)
 661          (or (monky-prefix-p (cdr prefix) list)
 662              (and (not (null list))
 663                   (monky-prefix-p prefix (cdr list))))
 664        (and (not (null list))
 665             (equal (car prefix) (car list))
 666             (monky-prefix-p (cdr prefix) (cdr list))))))
 667
 668(defun monky-wash-sequence (func)
 669  "Run FUNC until end of buffer is reached.
 670
 671FUNC should leave point at the end of the modified region"
 672  (while (and (not (eobp))
 673              (funcall func))))
 674
 675(defun monky-goto-line (line)
 676  "Like `goto-line' but doesn't set the mark."
 677  (save-restriction
 678    (widen)
 679    (goto-char 1)
 680    (forward-line (1- line))))
 681
 682;;; Key bindings
 683
 684(defvar monky-mode-map
 685  (let ((map (make-keymap)))
 686    (suppress-keymap map t)
 687    (define-key map (kbd "n") 'monky-goto-next-section)
 688    (define-key map (kbd "p") 'monky-goto-previous-section)
 689    (define-key map (kbd "RET") 'monky-visit-item)
 690    (define-key map (kbd "TAB") 'monky-toggle-section)
 691    (define-key map (kbd "SPC") 'monky-show-item-or-scroll-up)
 692    (define-key map (kbd "DEL") 'monky-show-item-or-scroll-down)
 693    (define-key map (kbd "g") 'monky-refresh)
 694    (define-key map (kbd "$") 'monky-display-process)
 695    (define-key map (kbd ":") 'monky-hg-command)
 696    (define-key map (kbd "l l") 'monky-log-current-branch)
 697    (define-key map (kbd "l a") 'monky-log-all)
 698    (define-key map (kbd "l r") 'monky-log-revset)
 699    (define-key map (kbd "b") 'monky-branches)
 700    (define-key map (kbd "Q") 'monky-queue)
 701    (define-key map (kbd "q") 'monky-quit-window)
 702
 703    (define-key map (kbd "M-1") 'monky-section-show-level-1-all)
 704    (define-key map (kbd "M-2") 'monky-section-show-level-2-all)
 705    (define-key map (kbd "M-3") 'monky-section-show-level-3-all)
 706    (define-key map (kbd "M-4") 'monky-section-show-level-4-all)
 707    map))
 708
 709(defvar monky-status-mode-map
 710  (let ((map (make-keymap)))
 711    (define-key map (kbd "s") 'monky-stage-item)
 712    (define-key map (kbd "S") 'monky-stage-all)
 713    (define-key map (kbd "u") 'monky-unstage-item)
 714    (define-key map (kbd "U") 'monky-unstage-all)
 715    (define-key map (kbd "a") 'monky-commit-amend)
 716    (define-key map (kbd "c") 'monky-log-edit)
 717    (define-key map (kbd "e") 'monky-ediff-item)
 718    (define-key map (kbd "y") 'monky-bookmark-create)
 719    (define-key map (kbd "C") 'monky-checkout)
 720    (define-key map (kbd "M") 'monky-merge)
 721    (define-key map (kbd "B") 'monky-backout)
 722    (define-key map (kbd "P") 'monky-push)
 723    (define-key map (kbd "f") 'monky-pull)
 724    (define-key map (kbd "k") 'monky-discard-item)
 725    (define-key map (kbd "m") 'monky-resolve-item)
 726    (define-key map (kbd "x") 'monky-unresolve-item)
 727    (define-key map (kbd "X") 'monky-reset-tip)
 728    (define-key map (kbd "A") 'monky-addremove-all)
 729    (define-key map (kbd "L") 'monky-rollback)
 730    map))
 731
 732(defvar monky-log-mode-map
 733  (let ((map (make-keymap)))
 734    (define-key map (kbd "e") 'monky-log-show-more-entries)
 735    (define-key map (kbd "C") 'monky-checkout-item)
 736    (define-key map (kbd "M") 'monky-merge-item)
 737    (define-key map (kbd "B") 'monky-backout-item)
 738    (define-key map (kbd "i") 'monky-qimport-item)
 739    map))
 740
 741(defvar monky-blame-mode-map
 742  (let ((map (make-keymap)))
 743    map))
 744
 745(defvar monky-branches-mode-map
 746  (let ((map (make-keymap)))
 747    (define-key map (kbd "C") 'monky-checkout-item)
 748    (define-key map (kbd "M") 'monky-merge-item)
 749    map))
 750
 751(defvar monky-commit-mode-map
 752  (let ((map (make-keymap)))
 753    map))
 754
 755(defvar monky-queue-mode-map
 756  (let ((map (make-keymap)))
 757    (define-key map (kbd "u") 'monky-qpop-item)
 758    (define-key map (kbd "U") 'monky-qpop-all)
 759    (define-key map (kbd "s") 'monky-qpush-item)
 760    (define-key map (kbd "S") 'monky-qpush-all)
 761    (define-key map (kbd "r") 'monky-qrefresh)
 762    (define-key map (kbd "R") 'monky-qrename-item)
 763    (define-key map (kbd "k") 'monky-qremove-item)
 764    (define-key map (kbd "N") 'monky-qnew)
 765    (define-key map (kbd "f") 'monky-qfinish-item)
 766    (define-key map (kbd "F") 'monky-qfinish-applied)
 767    (define-key map (kbd "d") 'monky-qfold-item)
 768    (define-key map (kbd "G") 'monky-qguard-item)
 769    (define-key map (kbd "o") 'monky-qreorder)
 770    (define-key map (kbd "A") 'monky-addremove-all)
 771    map))
 772
 773(defvar monky-pre-log-edit-window-configuration nil)
 774(defvar monky-log-edit-client-buffer nil)
 775(defvar monky-log-edit-operation nil)
 776(defvar monky-log-edit-info nil)
 777
 778(defvar monky-log-edit-mode-map
 779  (let ((map (make-sparse-keymap)))
 780    (define-key map (kbd "C-c C-c") 'monky-log-edit-commit)
 781    (define-key map (kbd "C-c C-k") 'monky-log-edit-cancel-log-message)
 782    (define-key map (kbd "C-x C-s")
 783      (lambda ()
 784        (interactive)
 785        (message "Not saved. Use C-c C-c to finalize this %s." monky-log-edit-operation)))
 786    map))
 787
 788;;; Sections
 789
 790(defvar-local monky-top-section nil)
 791(defvar monky-old-top-section nil)
 792(defvar monky-section-hidden-default nil)
 793
 794;; A buffer in monky-mode is organized into hierarchical sections.
 795;; These sections are used for navigation and for hiding parts of the
 796;; buffer.
 797;;
 798;; Most sections also represent the objects that Monky works with,
 799;; such as files, diffs, hunks, commits, etc.  The 'type' of a section
 800;; identifies what kind of object it represents (if any), and the
 801;; parent and grand-parent, etc provide the context.
 802
 803(defstruct monky-section
 804  parent children beginning end type title hidden info)
 805
 806(defun monky-set-section-info (info &optional section)
 807  (setf (monky-section-info (or section monky-top-section)) info))
 808
 809
 810(defun monky-new-section (title type)
 811  "Create a new section with title TITLE and type TYPE in current buffer.
 812
 813If not `monky-top-section' exist, the new section will be the new top-section
 814otherwise, the new-section will be a child of the current top-section.
 815
 816If TYPE is nil, the section won't be highlighted."
 817  (let* ((s (make-monky-section :parent monky-top-section
 818                                :title title
 819                                :type type
 820                                :hidden monky-section-hidden-default))
 821         (old (and monky-old-top-section
 822                   (monky-find-section (monky-section-path s)
 823                                       monky-old-top-section))))
 824    (if monky-top-section
 825        (push s (monky-section-children monky-top-section))
 826      (setq monky-top-section s))
 827    (if old
 828        (setf (monky-section-hidden s) (monky-section-hidden old)))
 829    s))
 830
 831(defmacro monky-with-section (title type &rest body)
 832  "Create a new section of title TITLE and type TYPE and evaluate BODY there.
 833
 834Sections create into BODY will be child of the new section.
 835BODY must leave point at the end of the created section.
 836
 837If TYPE is nil, the section won't be highlighted."
 838  (declare (indent 2)
 839           (debug (symbolp symbolp body)))
 840  (let ((s (make-symbol "*section*")))
 841    `(let* ((,s (monky-new-section ,title ,type))
 842            (monky-top-section ,s))
 843       (setf (monky-section-beginning ,s) (point))
 844       ,@body
 845       (setf (monky-section-end ,s) (point))
 846       (setf (monky-section-children ,s)
 847             (nreverse (monky-section-children ,s)))
 848       ,s)))
 849
 850(defmacro monky-create-buffer-sections (&rest body)
 851  "Empty current buffer of text and monky's section, and then evaluate BODY."
 852  (declare (indent 0)
 853           (debug (body)))
 854  `(let ((inhibit-read-only t))
 855     (erase-buffer)
 856     (let ((monky-old-top-section monky-top-section))
 857       (setq monky-top-section nil)
 858       ,@body
 859       (when (null monky-top-section)
 860         (monky-with-section 'top nil
 861           (insert "(empty)\n")))
 862       (monky-propertize-section monky-top-section)
 863       (monky-section-set-hidden monky-top-section
 864                                 (monky-section-hidden monky-top-section)))))
 865
 866(defun monky-propertize-section (section)
 867  "Add text-property needed for SECTION."
 868  (put-text-property (monky-section-beginning section)
 869                     (monky-section-end section)
 870                     'monky-section section)
 871  (dolist (s (monky-section-children section))
 872    (monky-propertize-section s)))
 873
 874(defun monky-find-section (path top)
 875  "Find the section at the path PATH in subsection of section TOP."
 876  (if (null path)
 877      top
 878    (let ((secs (monky-section-children top)))
 879      (while (and secs (not (equal (car path)
 880                                   (monky-section-title (car secs)))))
 881        (setq secs (cdr secs)))
 882      (and (car secs)
 883           (monky-find-section (cdr path) (car secs))))))
 884
 885(defun monky-section-path (section)
 886  "Return the path of SECTION."
 887  (if (not (monky-section-parent section))
 888      '()
 889    (append (monky-section-path (monky-section-parent section))
 890            (list (monky-section-title section)))))
 891
 892(defun monky-insert-section (section-title-and-type buffer-title washer cmd &rest args)
 893  "Run CMD and put its result in a new section.
 894
 895SECTION-TITLE-AND-TYPE is either a string that is the title of the section
 896or (TITLE . TYPE) where TITLE is the title of the section and TYPE is its type.
 897
 898If there is no type, or if type is nil, the section won't be highlighted.
 899
 900BUFFER-TITLE is the inserted title of the section
 901
 902WASHER is a function that will be run after CMD.
 903The buffer will be narrowed to the inserted text.
 904It should add sectioning as needed for monky interaction
 905
 906CMD is an external command that will be run with ARGS as arguments"
 907  (monky-with-process
 908    (let* ((body-beg nil)
 909           (section-title (if (consp section-title-and-type)
 910                              (car section-title-and-type)
 911                            section-title-and-type))
 912           (section-type (if (consp section-title-and-type)
 913                             (cdr section-title-and-type)
 914                           nil))
 915           (section (monky-with-section section-title section-type
 916                      (if buffer-title
 917                          (insert (propertize buffer-title 'face 'monky-section-title) "\n"))
 918                      (setq body-beg (point))
 919                      (apply 'monky-process-file cmd nil t nil args)
 920                      (if (not (eq (char-before) ?\n))
 921                          (insert "\n"))
 922                      (if washer
 923                          (save-restriction
 924                            (narrow-to-region body-beg (point))
 925                            (goto-char (point-min))
 926                            (funcall washer)
 927                            (goto-char (point-max)))))))
 928      (when (= body-beg (point))
 929        (monky-cancel-section section))
 930      section)))
 931
 932(defun monky-cancel-section (section)
 933  (delete-region (monky-section-beginning section)
 934                 (monky-section-end section))
 935  (let ((parent (monky-section-parent section)))
 936    (if parent
 937        (setf (monky-section-children parent)
 938              (delq section (monky-section-children parent)))
 939      (setq monky-top-section nil))))
 940
 941(defun monky-current-section ()
 942  "Return the monky section at point."
 943  (monky-section-at (point)))
 944
 945(defun monky-section-at (pos)
 946  "Return the monky section at position POS."
 947  (or (get-text-property pos 'monky-section)
 948      monky-top-section))
 949
 950(defun monky-find-section-after (pos secs)
 951  "Find the first section that begins after POS in the list SECS."
 952  (while (and secs
 953              (not (> (monky-section-beginning (car secs)) pos)))
 954    (setq secs (cdr secs)))
 955  (car secs))
 956
 957(defun monky-find-section-before (pos secs)
 958  "Find the last section that begins before POS in the list SECS."
 959  (let ((prev nil))
 960    (while (and secs
 961                (not (> (monky-section-beginning (car secs)) pos)))
 962      (setq prev (car secs))
 963      (setq secs (cdr secs)))
 964    prev))
 965
 966(defun monky-next-section (section)
 967  "Return the section that is after SECTION."
 968  (let ((parent (monky-section-parent section)))
 969    (if parent
 970        (let ((next (cadr (memq section
 971                                (monky-section-children parent)))))
 972          (or next
 973              (monky-next-section parent))))))
 974
 975(defvar-local monky-submode nil)
 976(defvar-local monky-refresh-function nil)
 977(defvar-local monky-refresh-args nil)
 978
 979(defun monky-goto-next-section ()
 980  "Go to the next monky section."
 981  (interactive)
 982  (let* ((section (monky-current-section))
 983         (next (or (and (not (monky-section-hidden section))
 984                        (monky-section-children section)
 985                        (monky-find-section-after (point)
 986                                                  (monky-section-children
 987                                                   section)))
 988                   (monky-next-section section))))
 989    (cond
 990     ((and next (eq (monky-section-type next) 'longer))
 991      (when monky-log-auto-more
 992        (monky-log-show-more-entries)
 993        (monky-goto-next-section)))
 994     (next
 995      (goto-char (monky-section-beginning next))
 996      (if (memq monky-submode '(log blame))
 997          (monky-show-commit next)))
 998     (t (message "No next section")))))
 999
1000(defun monky-prev-section (section)
1001  "Return the section that is before SECTION."
1002  (let ((parent (monky-section-parent section)))
1003    (if parent
1004        (let ((prev (cadr (memq section
1005                                (reverse (monky-section-children parent))))))
1006          (cond (prev
1007                 (while (and (not (monky-section-hidden prev))
1008                             (monky-section-children prev))
1009                   (setq prev (car (reverse (monky-section-children prev)))))
1010                 prev)
1011                (t
1012                 parent))))))
1013
1014
1015(defun monky-goto-previous-section ()
1016  "Goto the previous monky section."
1017  (interactive)
1018  (let ((section (monky-current-section)))
1019    (cond ((= (point) (monky-section-beginning section))
1020           (let ((prev (monky-prev-section (monky-current-section))))
1021             (if prev
1022                 (progn
1023                   (if (memq monky-submode '(log blame))
1024                       (monky-show-commit prev))
1025                   (goto-char (monky-section-beginning prev)))
1026               (message "No previous section"))))
1027          (t
1028           (let ((prev (monky-find-section-before (point)
1029                                                  (monky-section-children
1030                                                   section))))
1031             (if (memq monky-submode '(log blame))
1032                 (monky-show-commit (or prev section)))
1033             (goto-char (monky-section-beginning (or prev section))))))))
1034
1035
1036(defun monky-section-context-type (section)
1037  (if (null section)
1038      '()
1039    (let ((c (or (monky-section-type section)
1040                 (if (symbolp (monky-section-title section))
1041                     (monky-section-title section)))))
1042      (if c
1043          (cons c (monky-section-context-type
1044                   (monky-section-parent section)))
1045        '()))))
1046
1047(defun monky-hg-section (section-title-and-type buffer-title washer &rest args)
1048  (apply #'monky-insert-section
1049         section-title-and-type
1050         buffer-title
1051         washer
1052         monky-hg-executable
1053         (append monky-hg-standard-options args)))
1054
1055(defun monky-section-set-hidden (section hidden)
1056  "Hide SECTION if HIDDEN is not nil, show it otherwise."
1057  (setf (monky-section-hidden section) hidden)
1058  (let ((inhibit-read-only t)
1059        (beg (save-excursion
1060               (goto-char (monky-section-beginning section))
1061               (forward-line)
1062               (point)))
1063        (end (monky-section-end section)))
1064    (if (< beg end)
1065        (put-text-property beg end 'invisible hidden)))
1066  (if (not hidden)
1067      (dolist (c (monky-section-children section))
1068        (monky-section-set-hidden c (monky-section-hidden c)))))
1069
1070(defun monky-toggle-section ()
1071  "Toggle hidden status of current section."
1072  (interactive)
1073  (let ((section (monky-current-section)))
1074    (when (monky-section-parent section)
1075      (goto-char (monky-section-beginning section))
1076      (monky-section-set-hidden section (not (monky-section-hidden section))))))
1077
1078(defun monky-section-show-level-1-all ()
1079  "Collapse all the sections in the monky status buffer."
1080  (interactive)
1081  (save-excursion
1082    (goto-char (point-min))
1083    (while (not (eobp))
1084      (let ((section (monky-current-section)))
1085	(monky-section-set-hidden section t))
1086      (forward-line 1))))
1087
1088(defun monky-section-show-level-2-all ()
1089  "Show all the files changes, but not their contents."
1090  (interactive)
1091  (save-excursion
1092    (goto-char (point-min))
1093    (while (not (eobp))
1094      (let ((section (monky-current-section)))
1095	(if (memq (monky-section-type section) (list 'hunk 'diff))
1096	    (monky-section-set-hidden section t)
1097	  (monky-section-set-hidden section nil)))
1098      (forward-line 1))))
1099
1100(defun monky-section-show-level-3-all ()
1101  "Expand all file contents and line numbers, but not the actual changes."
1102  (interactive)
1103  (save-excursion
1104    (goto-char (point-min))
1105    (while (not (eobp))
1106      (let ((section (monky-current-section)))
1107	(if (memq (monky-section-type section) (list 'hunk))
1108	    (monky-section-set-hidden section t)
1109	  (monky-section-set-hidden section nil)))
1110      (forward-line 1))))
1111
1112(defun monky-section-show-level-4-all ()
1113  "Expand all sections."
1114  (interactive)
1115  (save-excursion
1116    (goto-char (point-min))
1117    (while (not (eobp))
1118      (let ((section (monky-current-section)))
1119	(monky-section-set-hidden section nil))
1120      (forward-line 1))))
1121
1122;;; Running commands
1123
1124(defun monky-set-mode-line-process (str)
1125  (let ((pr (if str (concat " " str) "")))
1126    (save-excursion
1127      (monky-for-all-buffers (lambda ()
1128                               (setq mode-line-process pr))))))
1129
1130(defun monky-process-indicator-from-command (comps)
1131  (if (monky-prefix-p (cons monky-hg-executable monky-hg-standard-options)
1132                      comps)
1133      (setq comps (nthcdr (+ (length monky-hg-standard-options) 1) comps)))
1134  (car comps))
1135
1136(defun monky-run* (cmd-and-args
1137		   &optional logline noerase noerror nowait input)
1138  (if (and monky-process
1139           (get-buffer monky-process-buffer-name))
1140      (error "Hg is already running"))
1141  (let ((cmd (car cmd-and-args))
1142        (args (cdr cmd-and-args))
1143        (dir default-directory)
1144        (buf (get-buffer-create monky-process-buffer-name))
1145        (successp nil))
1146    (monky-set-mode-line-process
1147     (monky-process-indicator-from-command cmd-and-args))
1148    (setq monky-process-client-buffer (current-buffer))
1149    (with-current-buffer buf
1150      (view-mode 1)
1151      (set (make-local-variable 'view-no-disable-on-exit) t)
1152      (setq view-exit-action
1153            (lambda (buffer)
1154              (with-current-buffer buffer
1155                (bury-buffer))))
1156      (setq buffer-read-only t)
1157      (let ((inhibit-read-only t))
1158        (setq default-directory dir)
1159        (if noerase
1160            (goto-char (point-max))
1161          (erase-buffer))
1162        (insert "$ " (or logline
1163                         (mapconcat #'identity cmd-and-args " "))
1164                "\n")
1165        (cond (nowait
1166               (setq monky-process
1167                     (let ((process-connection-type nil))
1168                       (apply 'monky-start-process cmd buf cmd args)))
1169               (set-process-sentinel monky-process 'monky-process-sentinel)
1170               (set-process-filter monky-process 'monky-process-filter)
1171               (when input
1172                 (with-current-buffer input
1173                   (process-send-region monky-process
1174                                        (point-min) (point-max))
1175                   (process-send-eof monky-process)
1176                   (sit-for 0.1 t)))
1177               (cond ((= monky-process-popup-time 0)
1178                      (pop-to-buffer (process-buffer monky-process)))
1179                     ((> monky-process-popup-time 0)
1180                      (run-with-timer
1181                       monky-process-popup-time nil
1182                       (function
1183                        (lambda (buf)
1184                          (with-current-buffer buf
1185                            (when monky-process
1186                              (display-buffer (process-buffer monky-process))
1187                              (goto-char (point-max))))))
1188                       (current-buffer))))
1189               (setq successp t))
1190	      (monky-cmd-process
1191	       (let ((monky-cmd-process-input-buffer input)
1192		     (monky-cmd-process-input-point (and input
1193						         (with-current-buffer input
1194						           (point-min)))))
1195		 (setq successp
1196		       (equal (apply #'monky-cmdserver-runcommand (cdr cmd-and-args)) 0))
1197		 (monky-set-mode-line-process nil)
1198		 (monky-need-refresh monky-process-client-buffer)))
1199              (input
1200               (with-current-buffer input
1201                 (setq default-directory dir)
1202                 (setq monky-process
1203                       ;; Don't use a pty, because it would set icrnl
1204                       ;; which would modify the input (issue #20).
1205                       (let ((process-connection-type nil))
1206                         (apply 'monky-start-process cmd buf cmd args)))
1207                 (set-process-filter monky-process 'monky-process-filter)
1208                 (process-send-region monky-process
1209                                      (point-min) (point-max))
1210                 (process-send-eof monky-process)
1211                 (while (equal (process-status monky-process) 'run)
1212                   (sit-for 0.1 t))
1213                 (setq successp
1214                       (equal (process-exit-status monky-process) 0))
1215                 (setq monky-process nil))
1216               (monky-set-mode-line-process nil)
1217               (monky-need-refresh monky-process-client-buffer))
1218              (t
1219               (setq successp
1220                     (equal (apply 'monky-process-file-single cmd nil buf nil args) 0))
1221               (monky-set-mode-line-process nil)
1222               (monky-need-refresh monky-process-client-buffer))))
1223      (or successp
1224          noerror
1225          (error
1226           (or monky-cmd-error-message
1227	       (monky-abort-message (get-buffer monky-process-buffer-name))
1228               "Hg failed")))
1229      successp)))
1230
1231
1232(defun monky-process-sentinel (process event)
1233  (let ((msg (format "Hg %s." (substring event 0 -1)))
1234        (successp (string-match "^finished" event)))
1235    (with-current-buffer (process-buffer process)
1236      (let ((inhibit-read-only t))
1237        (goto-char (point-max))
1238        (insert msg "\n")
1239        (message msg)))
1240    (when (not successp)
1241      (let ((msg (monky-abort-message (process-buffer process))))
1242        (when msg
1243          (message msg))))
1244    (setq monky-process nil)
1245    (monky-set-mode-line-process nil)
1246    (if (buffer-live-p monky-process-client-buffer)
1247        (with-current-buffer monky-process-client-buffer
1248          (monky-with-refresh
1249            (monky-need-refresh monky-process-client-buffer))))))
1250
1251(defun monky-abort-message (buffer)
1252  (with-current-buffer buffer
1253    (save-excursion
1254      (goto-char (point-min))
1255      (when (re-search-forward
1256             (concat "^abort: \\(.*\\)" paragraph-separate) nil t)
1257        (match-string 1)))))
1258
1259;; TODO password?
1260
1261(defun monky-process-filter (proc string)
1262  (save-current-buffer
1263    (set-buffer (process-buffer proc))
1264    (let ((inhibit-read-only t))
1265      (goto-char (process-mark proc))
1266      (insert string)
1267      (set-marker (process-mark proc) (point)))))
1268
1269
1270(defun monky-run-hg (&rest args)
1271  (monky-with-refresh
1272    (monky-run* (append (cons monky-hg-executable
1273                              monky-hg-standard-options)
1274                        args))))
1275
1276(defun monky-run-hg-sync (&rest args)
1277  (message "Running %s %s"
1278           monky-hg-executable
1279           (mapconcat #'identity args " "))
1280  (monky-run* (append (cons monky-hg-executable
1281			    monky-hg-standard-options)
1282		      args)))
1283
1284(defun monky-run-hg-async (&rest args)
1285  (message "Running %s %s"
1286           monky-hg-executable
1287           (mapconcat #'identity args " "))
1288  (monky-run* (append (cons monky-hg-executable
1289                            monky-hg-standard-options)
1290                      args)
1291              nil nil nil t))
1292
1293(defun monky-run-async-with-input (input cmd &rest args)
1294  (monky-run* (cons cmd args) nil nil nil t input))
1295
1296(defun monky-display-process ()
1297  "Display output from most recent hg command."
1298  (interactive)
1299  (unless (get-buffer monky-process-buffer-name)
1300    (user-error "No Hg commands have run"))
1301  (display-buffer monky-process-buffer-name))
1302
1303(defun monky-hg-command (command)
1304  "Perform arbitrary Hg COMMAND."
1305  (interactive "sRun hg like this: ")
1306  (let ((args (monky-parse-args command))
1307        (monky-process-popup-time 0))
1308    (monky-with-refresh
1309      (monky-run* (append (cons monky-hg-executable
1310                                monky-hg-standard-options)
1311                          args)
1312                  nil nil nil t))))
1313
1314;;; Actions
1315
1316(defmacro monky-section-case (opname &rest clauses)
1317  "Make different action depending of current section.
1318
1319HEAD is (SECTION INFO &optional OPNAME),
1320  SECTION will be bind to the current section,
1321  INFO will be bind to the info's of the current section,
1322  OPNAME is a string that will be used to describe current action,
1323
1324CLAUSES is a list of CLAUSE, each clause is (SECTION-TYPE &BODY)
1325where SECTION-TYPE describe section where BODY will be run.
1326
1327This returns non-nil if some section matches.  If the
1328corresponding body return a non-nil value, it is returned,
1329otherwise it return t.
1330
1331If no section matches, this returns nil if no OPNAME was given
1332and throws an error otherwise."
1333
1334  (declare (indent 1)
1335           (debug (form &rest (sexp body))))
1336  (let ((section (make-symbol "*section*"))
1337        (type (make-symbol "*type*"))
1338        (context (make-symbol "*context*")))
1339    `(let* ((,section (monky-current-section))
1340            (,type (monky-section-type ,section))
1341            (,context (monky-section-context-type ,section)))
1342       (cond ,@(mapcar (lambda (clause)
1343                         (let ((prefix (car clause))
1344                               (body (cdr clause)))
1345                           `(,(if (eq prefix t)
1346                                  `t
1347                                `(monky-prefix-p ',(reverse prefix) ,context))
1348                             (or (progn ,@body)
1349                                 t))))
1350                       clauses)
1351             ,@(when opname
1352                 `(((not ,type)
1353                    (user-error "Nothing to %s here" ,opname))
1354                   (t
1355                    (error "Can't %s as %s"
1356                           ,opname
1357                           ,type))))))))
1358
1359(defmacro monky-section-action (opname &rest clauses)
1360  "Refresh monky buffers after executing action defined in CLAUSES.
1361
1362See `monky-section-case' for the definition of HEAD and CLAUSES and
1363`monky-with-refresh' for how the buffers are refreshed."
1364  (declare (indent 1)
1365           (debug (form &rest (sexp body))))
1366  `(monky-with-refresh
1367     (monky-section-case ,opname ,@clauses)))
1368
1369(defun monky-visit-item (&optional other-window)
1370  "Visit current item.
1371With a prefix argument, visit in other window."
1372  (interactive (list current-prefix-arg))
1373  (let ((ff (if other-window 'find-file-other-window 'find-file)))
1374    (monky-section-action "visit"
1375      ((file)
1376       (funcall ff (monky-section-info (monky-current-section))))
1377      ((diff)
1378       (funcall ff (monky-diff-item-file (monky-current-section))))
1379      ((hunk)
1380       (let ((file (monky-diff-item-file (monky-hunk-item-diff (monky-current-section))))
1381             (line (monky-hunk-item-target-line (monky-current-section))))
1382         (funcall ff file)
1383         (goto-char (point-min))
1384         (forward-line (1- line))))
1385      ((commit)
1386       (monky-show-commit (monky-section-info (monky-current-section))))
1387      ((longer)
1388       (monky-log-show-more-entries))
1389      ((queue)
1390       (monky-qqueue (monky-section-info (monky-current-section))))
1391      ((branch)
1392       (monky-checkout (monky-section-info (monky-current-section))))
1393      ((shelf)
1394       (monky-show-shelf
1395	(monky-section-info (monky-current-section)))))))
1396
1397(defun monky-ediff-item ()
1398  "Open the ediff merge editor on the item."
1399  (interactive)
1400  (monky-section-action "ediff"
1401    ((merged diff)
1402     (if (eq (monky-diff-item-kind (monky-current-section)) 'unresolved)
1403	 (monky-ediff-merged (monky-current-section))
1404       (user-error "Already resolved.  Unresolve first.")))
1405    ((unmodified diff)
1406     (user-error "Cannot ediff an unmodified file during a merge."))
1407    ((staged diff)
1408     (user-error "Already staged"))
1409    ((changes diff)
1410     (monky-ediff-changes (monky-current-section)))
1411    ))
1412
1413(defun monky-ediff-merged (item)
1414  (let* ((file (monky-diff-item-file item))
1415	 (file-path (concat (monky-get-root-dir) file)))
1416    (condition-case nil
1417	(monky-run-hg-sync "resolve" "--tool" "internal:dump" file)
1418      (error nil))
1419    (condition-case nil
1420	(ediff-merge-files-with-ancestor
1421	 (concat file-path ".local")
1422	 (concat file-path ".other")
1423	 (concat file-path ".base")
1424	 nil file)
1425      (error nil))
1426    (delete-file (concat file-path ".local"))
1427    (delete-file (concat file-path ".other"))
1428    (delete-file (concat file-path ".base"))
1429    (delete-file (concat file-path ".orig"))))
1430
1431(defun monky-ediff-changes (item)
1432  (ediff-revision
1433   (concat (monky-get-root-dir)
1434	   (monky-diff-item-file item))))
1435
1436(defvar monky-staged-all-files nil)
1437(defvar monky-old-staged-files '())
1438(defvar-local monky-staged-files nil)
1439
1440(defun monky-stage-all ()
1441  "Add all items in Changes to the staging area."
1442  (interactive)
1443  (monky-with-refresh
1444    (setq monky-staged-all-files t)
1445    (monky-refresh-buffer)))
1446
1447(defun monky-stage-item ()
1448  "Add the item at point to the staging area."
1449  (interactive)
1450  (monky-section-action "stage"
1451    ((untracked file)
1452     (monky-run-hg "add" (monky-section-info (monky-current-section))))
1453    ((untracked)
1454     (monky-run-hg "add"))
1455    ((missing file)
1456     (monky-run-hg "remove" "--after" (monky-section-info (monky-current-section))))
1457    ((changes diff)
1458     (monky-stage-file (monky-section-title (monky-current-section)))
1459     (monky-refresh-buffer))
1460    ((changes)
1461     (monky-stage-all))
1462    ((staged diff)
1463     (user-error "Already staged"))
1464    ((unmodified diff)
1465     (user-error "Cannot partially commit a merge"))
1466    ((merged diff)
1467     (user-error "Cannot partially commit a merge"))))
1468
1469(defun monky-unstage-all ()
1470  "Remove all items from the staging area"
1471  (interactive)
1472  (monky-with-refresh
1473    (setq monky-staged-files '())
1474    (monky-refresh-buffer)))
1475
1476(defun monky-unstage-item ()
1477  "Remove the item at point from the staging area."
1478  (interactive)
1479  (monky-with-process
1480    (monky-section-action "unstage"
1481      ((staged diff)
1482       (monky-unstage-file (monky-section-title (monky-current-section)))
1483       (monky-refresh-buffer))
1484      ((staged)
1485       (monky-unstage-all))
1486      ((changes diff)
1487       (user-error "Already unstaged")))))
1488
1489;;; Updating
1490
1491(defun monky-pull ()
1492  "Run hg pull. The monky-pull-args variable contains extra arguments to pass to hg."
1493  (interactive)
1494  (let ((remote (if current-prefix-arg
1495                    (monky-read-remote "Pull from : ")
1496                  monky-incoming-repository)))
1497    (apply #'monky-run-hg-async
1498	   "pull" (append monky-pull-args (list remote)))))
1499
1500(defun monky-remotes ()
1501  (mapcar #'car (monky-hg-config-section "paths")))
1502
1503(defun monky-read-remote (prompt)
1504  (monky-completing-read prompt
1505                         (monky-remotes)))
1506
1507(defun monky-read-revision (prompt)
1508  (let ((revision (read-string prompt)))
1509    (unless (monky-hg-revision-p revision)
1510      (error "%s is not a revision" revision))
1511    revision))
1512
1513(defun monky-push ()
1514  "Pushes current branch to the default path."
1515  (interactive)
1516  (let* ((branch (monky-current-branch))
1517         (remote (if current-prefix-arg
1518                     (monky-read-remote
1519                      (format "Push branch %s to : " branch))
1520                   monky-outgoing-repository)))
1521    (if (string= "" remote)
1522        (monky-run-hg-async "push" "--branch" branch)
1523      (monky-run-hg-async "push" "--branch" branch remote))))
1524
1525(defun monky-checkout (node)
1526  (interactive (list (monky-read-revision "Update to: ")))
1527  (monky-run-hg "update" node))
1528
1529(defun monky-merge (node)
1530  (interactive (list (monky-read-revision "Merge with: ")))
1531  (monky-run-hg "merge" node))
1532
1533(defun monky-reset-tip ()
1534  (interactive)
1535  (when (yes-or-no-p "Discard all uncommitted changes? ")
1536    (monky-run-hg "update" "--clean")))
1537
1538(defun monky-addremove-all ()
1539  (interactive)
1540  (monky-run-hg "addremove"))
1541
1542(defun monky-rollback ()
1543  (interactive)
1544  (monky-run-hg "rollback"))
1545
1546;;; Merging
1547
1548(defun monky-unresolve-item ()
1549  "Mark the item at point as unresolved."
1550  (interactive)
1551  (monky-section-action "unresolve"
1552    ((merged diff)
1553     (if (eq (monky-diff-item-kind (monky-current-section)) 'resolved)
1554         (monky-run-hg "resolve" "--unmark" (monky-diff-item-file (monky-current-section)))
1555       (user-error "Already unresolved")))))
1556
1557(defun monky-resolve-item ()
1558  "Mark the item at point as resolved."
1559  (interactive)
1560  (monky-section-action "resolve"
1561    ((merged diff)
1562     (if (eq (monky-diff-item-kind (monky-current-section)) 'unresolved)
1563         (monky-run-hg "resolve" "--mark" (monky-diff-item-file (monky-current-section)))
1564       (user-error "Already resolved")))))
1565
1566;; History
1567
1568(defun monky-backout (revision)
1569  "Runs hg backout."
1570  (interactive (list (monky-read-revision "Backout : ")))
1571  (monky-pop-to-log-edit 'backout revision))
1572
1573(defun monky-backout-item ()
1574  "Backout the revision represented by current item."
1575  (interactive)
1576  (monky-section-action "backout"
1577    ((log commits commit)
1578     (monky-backout (monky-section-info (monky-current-section))))))
1579
1580(defun monky-show-item-or-scroll-up ()
1581  (interactive)
1582  (monky-section-action "show"
1583    ((commit)
1584     (monky-show-commit (monky-section-info (monky-current-section)) nil #'scroll-up))
1585    (t
1586     (scroll-up))))
1587
1588(defun monky-show-item-or-scroll-down ()
1589  (interactive)
1590  (monky-section-action "show"
1591    ((commit)
1592     (monky-show-commit (monky-section-info (monky-current-section)) nil #'scroll-down))
1593    (t
1594     (scroll-down))))
1595
1596;;; Miscellaneous
1597
1598(defun monky-revert-file (file)
1599  (when (or (not monky-revert-item-confirm)
1600	    (yes-or-no-p (format "Revert %s? " file)))
1601    (monky-run-hg "revert" "--no-backup" file)
1602    (let ((file-buf (find-buffer-visiting
1603		     (concat (monky-get-root-dir) file))))
1604      (if file-buf
1605	  (save-current-buffer
1606	    (set-buffer file-buf)
1607	    (revert-buffer t t t))))))
1608
1609(defun monky-discard-item ()
1610  "Delete the file if not tracked, otherwise revert it."
1611  (interactive)
1612  (monky-section-action "discard"
1613    ((untracked file)
1614     (when (yes-or-no-p (format "Delete %s? " (monky-section-info (monky-current-section))))
1615       (delete-file (monky-section-info (monky-current-section)))
1616       (monky-refresh-buffer)))
1617    ((changes diff)
1618     (monky-revert-file (monky-diff-item-file (monky-current-section))))
1619    ((staged diff)
1620     (monky-revert-file (monky-diff-item-file (monky-current-section))))
1621    ((missing file)
1622     (monky-revert-file (monky-section-info (monky-current-section))))
1623    ((shelf)
1624     (monky-delete-shelf (monky-section-info (monky-current-section))))))
1625
1626(defun monky-quit-window (&optional kill-buffer)
1627  "Bury the buffer and delete its window.  With a prefix argument, kill the
1628buffer instead."
1629  (interactive "P")
1630  (quit-window kill-buffer (selected-window)))
1631
1632;;; Refresh
1633
1634(defun monky-revert-buffers (dir &optional ignore-modtime)
1635  (dolist (buffer (buffer-list))
1636    (when (and buffer
1637               (buffer-file-name buffer)
1638               (monky-string-starts-with-p (buffer-file-name buffer) dir)
1639               (file-readable-p (buffer-file-name buffer))
1640               (or ignore-modtime (not (verify-visited-file-modtime buffer)))
1641               (not (buffer-modified-p buffer)))
1642      (with-current-buffer buffer
1643        (condition-case var
1644            (revert-buffer t t t)
1645          (error (let ((signal-data (cadr var)))
1646                   (cond (t (monky-bug-report signal-data))))))))))
1647
1648(defvar monky-refresh-needing-buffers nil)
1649(defvar monky-refresh-pending nil)
1650
1651(defun monky-refresh-wrapper (func)
1652  "A helper function for `monky-with-refresh'."
1653  (monky-with-process
1654    (if monky-refresh-pending
1655        (funcall func)
1656      (let* ((dir default-directory)
1657             (status-buffer (monky-find-status-buffer dir))
1658             (monky-refresh-needing-buffers nil)
1659             (monky-refresh-pending t))
1660        (unwind-protect
1661            (funcall func)
1662          (when monky-refresh-needing-buffers
1663            (monky-revert-buffers dir)
1664            (dolist (b (adjoin status-buffer
1665                               monky-refresh-needing-buffers))
1666              (monky-refresh-buffer b))))))))
1667
1668(defun monky-need-refresh (&optional buffer)
1669  (let ((buffer (or buffer (current-buffer))))
1670    (setq monky-refresh-needing-buffers
1671          (adjoin buffer monky-refresh-needing-buffers))))
1672
1673(defun monky-refresh ()
1674  "Refresh current buffer to match repository state.
1675Also revert every unmodified buffer visiting files
1676in the corresponding directory."
1677  (interactive)
1678  (monky-with-refresh
1679    (monky-need-refresh)))
1680
1681(defun monky-refresh-buffer (&optional buffer)
1682  (with-current-buffer (or buffer (current-buffer))
1683    (let* ((old-line (line-number-at-pos))
1684           (old-section (monky-current-section))
1685           (old-path (and old-section
1686                          (monky-section-path old-section)))
1687           (section-line (and old-section
1688                              (count-lines
1689                               (monky-section-beginning old-section)
1690                               (point)))))
1691      (if monky-refresh-function
1692          (apply monky-refresh-function
1693                 monky-refresh-args))
1694      (let ((s (and old-path (monky-find-section old-path monky-top-section))))
1695        (cond (s
1696               (goto-char (monky-section-beginning s))
1697               (forward-line section-line))
1698              (t
1699               (monky-goto-line old-line)))
1700        (dolist (w (get-buffer-window-list (current-buffer)))
1701          (set-window-point w (point)))))))
1702
1703(defvar monky-last-point nil)
1704
1705(defun monky-remember-point ()
1706  (setq monky-last-point (point)))
1707
1708(defun monky-invisible-region-end (pos)
1709  (while (and (not (= pos (point-max))) (invisible-p pos))
1710    (setq pos (next-char-property-change pos)))
1711  pos)
1712
1713(defun monky-invisible-region-start (pos)
1714  (while (and (not (= pos (point-min))) (invisible-p pos))
1715    (setq pos (1- (previous-char-property-change pos))))
1716  pos)
1717
1718(defun monky-correct-point-after-command ()
1719  "Move point outside of invisible regions.
1720
1721Emacs often leaves point in invisible regions, it seems.  To fix
1722this, we move point ourselves and never let Emacs do its own
1723adjustments.
1724
1725When point has to be moved out of an invisible region, it can be
1726moved to its end or its beginning.  We usually move it to its
1727end, except when that would move point back to where it was
1728before the last command."
1729  (if (invisible-p (point))
1730      (let ((end (monky-invisible-region-end (point))))
1731        (goto-char (if (= end monky-last-point)
1732                       (monky-invisible-region-start (point))
1733                     end))))
1734  (setq disable-point-adjustment t))
1735
1736(defun monky-post-command-hook ()
1737  (monky-correct-point-after-command))
1738
1739;;; Monky mode
1740
1741(define-derived-mode monky-mode special-mode "Monky"
1742  "View the status of a mercurial repository.
1743
1744\\{monky-mode-map}"
1745  (setq buffer-read-only t)
1746  (setq mode-line-process "")
1747  (setq truncate-lines t)
1748  (add-hook 'pre-command-hook #'monky-remember-point nil t)
1749  (add-hook 'post-command-hook #'monky-post-command-hook t t))
1750
1751(defun monky-mode-init (dir submode refresh-func &rest refresh-args)
1752  (monky-mode)
1753  (setq default-directory dir
1754        monky-submode submode
1755        monky-refresh-function refresh-func
1756        monky-refresh-args refresh-args)
1757  (monky-refresh-buffer))
1758
1759
1760;;; Hg utils
1761
1762(defmacro monky-with-temp-file (file &rest body)
1763  "Create a temporary file name, evaluate BODY and delete the file."
1764  (declare (indent 1)
1765           (debug (symbolp body)))
1766  `(let ((,file (make-temp-file "monky-temp-file")))
1767     (unwind-protect
1768         (progn ,@body)
1769       (delete-file ,file))))
1770
1771(defun monky-hg-insert (args)
1772  (insert (monky-hg-output args)))
1773
1774(defun monky-hg-output (args)
1775  (monky-with-temp-file stderr
1776    (save-current-buffer
1777      (with-temp-buffer
1778        (unless (eq 0 (apply #'monky-process-file
1779                             monky-hg-executable
1780                             nil (list t stderr) nil
1781                             (append monky-hg-standard-options args)))
1782          (error (with-temp-buffer
1783                   (insert-file-contents stderr)
1784                   (buffer-string))))
1785        (buffer-string)))))
1786
1787(defun monky-hg-string (&rest args)
1788  (monky-trim-line (monky-hg-output args)))
1789
1790(defun monky-hg-lines (&rest args)
1791  (monky-split-lines (monky-hg-output args)))
1792
1793(defun monky-hg-exit-code (&rest args)
1794  (apply #'monky-process-file monky-hg-executable nil nil nil
1795         (append monky-hg-standard-options args)))
1796
1797(defun monky-hg-revision-p (revision)
1798  (eq 0 (monky-hg-exit-code "identify" "--rev" revision)))
1799
1800;; TODO needs cleanup
1801(defun monky-get-root-dir ()
1802  (if (and (featurep 'tramp)
1803	   (tramp-tramp-file-p default-directory))
1804      (monky-get-tramp-root-dir)
1805    (monky-get-local-root-dir)))
1806
1807(defun monky-get-local-root-dir ()
1808  (let ((root (monky-hg-string "root")))
1809    (if root
1810	(concat root "/")
1811      (user-error "Not inside a hg repo"))))
1812
1813(defun monky-get-tramp-root-dir ()
1814  (let ((root (monky-hg-string "root"))
1815        (tramp-path (vconcat (tramp-dissect-file-name default-directory))))
1816    (if root
1817        (progn (aset tramp-path 6 root)
1818               (concat (apply 'tramp-make-tramp-file-name (cdr (append tramp-path nil)))
1819                       "/"))
1820      (user-error "Not inside a hg repo"))))
1821
1822(defun monky-find-buffer (submode &optional dir)
1823  (let ((rootdir (expand-file-name (or dir (monky-get-root-dir)))))
1824    (find-if (lambda (buf)
1825               (with-current-buffer buf
1826                 (and default-directory
1827                      (equal (expand-file-name default-directory) rootdir)
1828                      (eq major-mode 'monky-mode)
1829                      (eq monky-submode submode))))
1830             (buffer-list))))
1831
1832(defun monky-find-status-buffer (&optional dir)
1833  (monky-find-buffer 'status dir))
1834
1835(defun monky-for-all-buffers (func &optional dir)
1836  (dolist (buf (buffer-list))
1837    (with-current-buffer buf
1838      (if (and (eq major-mode 'monky-mode)
1839               (or (null dir)
1840                   (equal default-directory dir)))
1841          (funcall func)))))
1842
1843(defun monky-hg-config ()
1844  "Return an alist of ((section . key) . value)"
1845  (mapcar (lambda (line)
1846            (string-match "^\\([^.]*\\)\.\\([^=]*\\)=\\(.*\\)$" line)
1847            (cons (cons (match-string 1 line)
1848                        (match-string 2 line))
1849                  (match-string 3 line)))
1850          (monky-hg-lines "debugconfig")))
1851
1852(defun monky-hg-config-section (section)
1853  "Return an alist of (name . value) for section"
1854  (mapcar (lambda (item)
1855            (cons (cdar item) (cdr item)))
1856          (remove-if-not (lambda (item)
1857                           (equal section (caar item)))
1858                         (monky-hg-config))))
1859
1860(defvar monky-el-directory
1861  (file-name-directory (or load-file-name default-directory))
1862  "The parent directory of monky.el")
1863
1864(defun monky-get-style-path (filename)
1865  (concat (file-name-as-directory (concat monky-el-directory "style"))
1866          filename))
1867
1868(defvar monky-hg-style-log-graph
1869  (monky-get-style-path "log-graph"))
1870
1871(defvar monky-hg-style-files-status
1872  (monky-get-style-path "files-status"))
1873
1874(defvar monky-hg-style-tags
1875  (monky-get-style-path "tags"))
1876
1877(defun monky-hg-log-tags (revision &rest args)
1878  (apply #'monky-hg-lines "log"
1879         "--style" monky-hg-style-tags
1880         "--rev" revision args))
1881
1882(defun monky-qtip-p ()
1883  "Return non-nil if the current revision is qtip"
1884  (let ((rev (replace-regexp-in-string "\\+$" ""
1885                                       (monky-hg-string "identify" "--id"))))
1886    (let ((monky-cmd-process nil))      ; use single process
1887      (member "qtip" (monky-hg-log-tags rev "--config" "extensions.mq=")))))
1888
1889
1890;;; Washers
1891
1892(defun monky-wash-status-lines (callback)
1893  "For every status line in the current buffer, remove it and call CALLBACK.
1894CALLBACK is called with the status and the associated filename."
1895  (while (and (not (eobp))
1896              (looking-at "\\([A-Z!? ]\\) \\([^\t\n]+\\)$"))
1897    (let ((status (case (string-to-char (match-string-no-properties 1))
1898                    (?M 'modified)
1899                    (?A 'new)
1900                    (?R 'removed)
1901                    (?C 'clean)
1902                    (?! 'missing)
1903                    (?? 'untracked)
1904                    (?I 'ignored)
1905                    (?U 'unresolved)
1906                    (t nil)))
1907          (file (match-string-no-properties 2)))
1908      (monky-delete-line t)
1909      (funcall callback status file))))
1910
1911;; File
1912
1913(defun monky-wash-files ()
1914  (let ((empty t))
1915    (monky-wash-status-lines
1916     (lambda (_status file)
1917       (setq empty nil)
1918       (monky-with-section file 'file
1919         (monky-set-section-info file)
1920         (insert file "\n"))))
1921    (unless empty
1922      (insert "\n"))))
1923
1924;; Hunk
1925
1926(defun monky-hunk-item-diff (hunk)
1927  (let ((diff (monky-section-parent hunk)))
1928    (or (eq (monky-section-type diff) 'diff)
1929        (error "Huh?  Parent of hunk not a diff"))
1930    diff))
1931
1932(defun monky-hunk-item-target-line (hunk)
1933  (save-excursion
1934    (beginning-of-line)
1935    (let ((line (line-number-at-pos)))
1936      (goto-char (monky-section-beginning hunk))
1937      (if (not (looking-at "@@+ .* \\+\\([0-9]+\\),[0-9]+ @@+"))
1938          (error "Hunk header not found"))
1939      (let ((target (string-to-number (match-string 1))))
1940        (forward-line)
1941        (while (< (line-number-at-pos) line)
1942          ;; XXX - deal with combined diffs
1943          (if (not (looking-at "-"))
1944              (setq target (+ target 1)))
1945          (forward-line))
1946        target))))
1947
1948(defun monky-wash-hunk ()
1949  (if (looking-at "\\(^@+\\)[^@]*@+")
1950      (let ((n-columns (1- (length (match-string 1))))
1951            (head (match-string 0)))
1952        (monky-with-section head 'hunk
1953          (add-text-properties (match-beginning 0) (1+ (match-end 0))
1954                               '(face monky-diff-hunk-header))
1955          (forward-line)
1956          (while (not (or (eobp)
1957                          (looking-at "^diff\\|^@@")))
1958            (let ((prefix (buffer-substring-no-properties
1959                           (point) (min (+ (point) n-columns) (point-max)))))
1960              (cond ((string-match "\\+" prefix)
1961                     (monky-put-line-property 'face 'monky-diff-add))
1962                    ((string-match "-" prefix)
1963                     (monky-put-line-property 'face 'monky-diff-del))
1964                    (t
1965                     (monky-put-line-property 'face 'monky-diff-none))))
1966            (forward-line))))
1967    nil))
1968
1969;; Diff
1970
1971(defvar monky-hide-diffs nil)
1972
1973(defun monky-diff-item-kind (diff)
1974  (car (monky-section-info diff)))
1975
1976(defun monky-diff-item-file (diff)
1977  (cadr (monky-section-info diff)))
1978
1979(defun monky-diff-line-file ()
1980  (cond ((looking-at "^diff -r \\([^ ]*\\) \\(-r \\([^ ]*\\) \\)?\\(.*\\)$")
1981         (match-string-no-properties 4))
1982	((looking-at (rx "diff --git a/" (group (+? anything)) " b/"))
1983	 (match-string-no-properties 1))
1984        (t
1985         nil)))
1986
1987(defun monky-wash-diff-section (&optional status file)
1988  (let ((case-fold-search nil))
1989   (cond ((looking-at "^diff ")
1990	  (let* ((file (monky-diff-line-file))
1991		 (end (save-excursion
1992		        (forward-line)
1993		        (if (search-forward-regexp "^diff \\|^@@" nil t)
1994			    (goto-char (match-beginning 0))
1995			  (goto-char (point-max)))
1996		        (point-marker)))
1997		 (status (or status
1998			     (cond
1999			      ((save-excursion
2000				 (search-forward-regexp "^--- /dev/null" end t))
2001			       'new)
2002			      ((save-excursion
2003				 (search-forward-regexp "^+++ /dev/null" end t))
2004			       'removed)
2005			      (t 'modified)))))
2006	    (monky-set-section-info (list status file))
2007	    (monky-insert-diff-title status file)
2008            ;; Remove the 'diff ...' text and '+++' text, as it's redundant.
2009            (delete-region (point) end)
2010	    (let ((monky-section-hidden-default nil))
2011	      (monky-wash-sequence #'monky-wash-hunk))))
2012	 ;; sometimes diff returns empty output
2013	 ((and status file)
2014	  (monky-set-section-info (list status file))
2015	  (monky-insert-diff-title status file))
2016	 (t nil))))
2017
2018(defun monky-wash-diff ()
2019  (let ((monky-section-hidden-default monky-hide-diffs))
2020    (monky-with-section nil 'diff
2021      (monky-wash-diff-section))))
2022
2023(defun monky-wash-diffs ()
2024  (monky-wash-sequence #'monky-wash-diff))
2025
2026(defun monky-insert-diff (file &optional status cmd)
2027  (let ((p (point)))
2028    (monky-hg-insert (list (or cmd "diff") file))
2029    (if (not (eq (char-before) ?\n))
2030        (insert "\n"))
2031    (save-restriction
2032      (narrow-to-region p (point))
2033      (goto-char p)
2034      (monky-wash-diff-section status file)
2035      (goto-char (point-max)))))
2036
2037(defun monky-insert-diff-title (status file)
2038  (insert
2039   (format "%-10s %s\n"
2040          (propertize
2041           (symbol-name status)
2042           'face
2043           (if (eq status 'unresolved) 'warning 'monky-diff-title))
2044          (propertize file 'face 'monky-diff-title))))
2045
2046;;; Untracked files
2047
2048(defun monky-insert-untracked-files ()
2049  (monky-hg-section 'untracked "Untracked files:" #'monky-wash-files
2050                    "status" "--unknown"))
2051
2052;;; Missing files
2053
2054(defun monky-insert-missing-files ()
2055  (monky-hg-section 'missing "Missing files:" #'monky-wash-files
2056                    "status" "--deleted"))
2057
2058;;; Changes
2059
2060(defun monky-wash-changes ()
2061  (let ((changes-p nil))
2062    (monky-wash-status-lines
2063     (lambda (status file)
2064       (let ((monky-section-hidden-default monky-hide-diffs))
2065         (if (or monky-staged-all-files
2066                 (member file monky-old-staged-files))
2067             (monky-stage-file file)
2068           (monky-with-section file 'diff
2069             (monky-insert-diff file status))
2070           (setq changes-p t)))))
2071    (when changes-p
2072      (insert "\n"))))
2073
2074
2075(defun monky-insert-changes ()
2076  (let ((monky-hide-diffs t))
2077    (setq monky-old-staged-files (copy-list monky-staged-files))
2078    (setq monky-staged-files '())
2079    (monky-hg-section 'changes "Changes:" #'monky-wash-changes
2080                      "status" "--modified" "--added" "--removed")))
2081
2082;; Staged Changes
2083
2084(defun monky-stage-file (file)
2085  (if (not (member file monky-staged-files))
2086      (setq monky-staged-files (cons file monky-staged-files))))
2087
2088(defun monky-unstage-file (file)
2089  (setq monky-staged-files (delete file monky-staged-files)))
2090
2091(defun monky-insert-staged-changes ()
2092  (when monky-staged-files
2093    (monky-with-section 'staged nil
2094      (insert (propertize "Staged changes:" 'face 'monky-section-title) "\n")
2095      (let ((monky-section-hidden-default t))
2096        (dolist (file monky-staged-files)
2097          (monky-with-section file 'diff
2098            (monky-insert-diff file)))))
2099    (insert "\n"))
2100  (setq monky-staged-all-files nil))
2101
2102;;; Shelves
2103
2104(defun monky-extensions ()
2105  "Return a list of all the enabled mercurial extensions."
2106  (let* ((config
2107          (string-trim (shell-command-to-string "hg config extensions")))
2108         (lines
2109          (split-string config "\n"))
2110         extensions)
2111    (dolist (line lines)
2112      (unless (string-match-p (rx "!" eos) line)
2113        (setq line (string-remove-prefix "extensions." line))
2114        (setq line (string-remove-suffix "=" line)))
2115      (push line extensions))
2116    (nreverse extensions)))
2117
2118(defun monky-insert-shelves ()
2119  (when (member "shelve" (monky-extensions))
2120    (monky-hg-section 'shelves "Shelves:" #'monky-wash-shelves
2121                      "shelve" "--list")))
2122
2123(defun monky-wash-shelves ()
2124  "Set shelf names on each line.
2125This is naive and assumes that shelf names never contain (."
2126  (while (re-search-forward
2127          (rx bol (group (+? not-newline))
2128              (+ space) "(")
2129          nil
2130          t)
2131    (goto-char (line-beginning-position))
2132    (monky-with-section 'shelf nil
2133      (monky-set-section-info (match-string 1))
2134      (put-text-property
2135       (match-beginning 1)
2136       (match-end 1)
2137       'face
2138       'monky-commit-id)
2139      (goto-char (line-end-position)))))
2140
2141;;; Parents
2142
2143(defvar-local monky-parents nil)
2144
2145(defun monky-merge-p ()
2146  (> (length monky-parents) 1))
2147
2148(defun monky-wash-parent ()
2149  (if (looking-at "changeset:\s*\\([0-9]+\\):\\([0-9a-z]+\\)")
2150      (let ((changeset (match-string 2))
2151	    (line (buffer-substring (line-beginning-position) (line-end-position))))
2152        (push changeset monky-parents)
2153
2154	;; Remove the plain text 'changeset: ...' and replace it with
2155	;; propertized text, plus a section that knows the changeset
2156	;; (so RET shows the full commit).
2157	(monky-with-section 'commit nil
2158	  (monky-set-section-info changeset)
2159	  (monky-delete-line t)
2160	  (insert line "\n")
2161
2162	  (put-text-property
2163           (match-beginning 1)
2164           (match-end 1)
2165           'face
2166           'monky-commit-id)
2167          (put-text-property
2168           (match-beginning 2)
2169           (match-end 2)
2170           'face
2171           'monky-commit-id))
2172
2173        (while (not (or (eobp)
2174                        (looking-at "changeset:\s*\\([0-9]+\\):\\([0-9a-z]+\\)")))
2175          (forward-line))
2176        t)
2177    nil))
2178
2179(defun monky-wash-parents ()
2180  (monky-wash-sequence #'monky-wash-parent))
2181
2182(defun monky-insert-parents ()
2183  (monky-hg-section 'parents "Parents:"
2184                    #'monky-wash-parents "parents"))
2185
2186;;; Merged Files
2187
2188(defvar-local monky-merged-files nil)
2189
2190(defun monky-wash-merged-files ()
2191  (let ((empty t))
2192    (monky-wash-status-lines
2193     (lambda (status file)
2194       (setq empty nil)
2195       (let ((monky-section-hidden-default monky-hide-diffs))
2196        (push file monky-merged-files)
2197        ;; XXX hg uses R for resolved and removed status
2198        (let ((status (if (eq status 'unresolved)
2199                           'unresolved
2200                        'resolved)))
2201           (monky-with-section file 'diff
2202             (monky-insert-diff file status))))))
2203    (unless empty
2204      (insert "\n"))))
2205
2206(defun monky-insert-merged-files ()
2207  (let ((monky-hide-diffs t))
2208    (setq monky-merged-files '())
2209    (monky-hg-section 'merged "Merged Files:" #'monky-wash-merged-files
2210                      "resolve" "--list")))
2211
2212;;; Unmodified Files
2213
2214(defun monky-wash-unmodified-files ()
2215  (monky-wash-status-lines
2216   (lambda (_status file)
2217     (let ((monky-section-hidden-default monky-hide-diffs))
2218       (when (not (member file monky-merged-files))
2219         (monky-with-section file 'diff
2220           (monky-insert-diff file)))))))
2221
2222(defun monky-insert-resolved-files ()
2223  (let ((monky-hide-diffs t))
2224    (monky-hg-section 'unmodified "Unmodified files during merge:" #'monky-wash-unmodified-files
2225                      "status" "--modified" "--added" "--removed")))
2226;;; Status mode
2227
2228(defun monky-refresh-status ()
2229  (setq monky-parents nil
2230        monky-merged-files nil)
2231  (monky-create-buffer-sections
2232    (monky-with-section 'status nil
2233      (monky-insert-parents)
2234      (if (monky-merge-p)
2235          (progn
2236            (monky-insert-merged-files)
2237            (monky-insert-resolved-files))
2238        (monky-insert-untracked-files)
2239        (monky-insert-missing-files)
2240        (monky-insert-changes)
2241        (monky-insert-staged-changes)
2242        (monky-insert-shelves)))))
2243
2244(define-minor-mode monky-status-mode
2245  "Minor mode for hg status.
2246
2247\\{monky-status-mode-map}"
2248  :group monky
2249  :init-value ()
2250  :lighter ()
2251  :keymap monky-status-mode-map)
2252
2253;;;###autoload
2254(defun monky-status (&optional directory)
2255  "Show the status of Hg repository."
2256  (interactive)
2257  (monky-with-process
2258    (let* ((rootdir (or directory (monky-get-root-dir)))
2259           (buf (or (monky-find-status-buffer rootdir)
2260                    (generate-new-buffer
2261                     (concat "*monky: "
2262                             (file-name-nondirectory
2263                              (directory-file-name rootdir)) "*")))))
2264      (pop-to-buffer buf)
2265      (monky-mode-init rootdir 'status #'monky-refresh-status)
2266      (monky-status-mode t))))
2267
2268;;; Log mode
2269
2270(define-minor-mode monky-log-mode
2271  "Minor mode for hg log.
2272
2273\\{monky-log-mode-map}"
2274  :group monky
2275  :init-value ()
2276  :lighter ()
2277  :keymap monky-log-mode-map)
2278
2279(defvar monky-log-buffer-name "*monky-log*")
2280
2281(defun monky-propertize-labels (label-list &rest properties)
2282  "Propertize labels (tag/branch/bookmark/...) in LABEL-LIST.
2283
2284PROPERTIES is the arguments for the function `propertize'."
2285  (apply #'concat
2286         (apply #'append
2287                (mapcar (lambda (l)
2288                          (unless (or (string= l "") (string= l "None"))
2289                            (list (apply #'propertize l properties) " ")))
2290                        label-list))))
2291
2292(defun monky-present-log-line (width graph id branches tags bookmarks phase author date message)
2293  (let* ((hg-info (concat
2294                   (propertize (substring id 0 8) 'face 'monky-log-sha1)
2295                   " "
2296                   graph
2297                   (monky-propertize-labels branches 'face 'monky-log-head-label-local)
2298                   (monky-propertize-labels tags 'face 'monky-log-head-label-tags)
2299                   (monky-propertize-labels bookmarks 'face 'monky-log-head-label-bookmarks)
2300                   (unless (or (string= phase "") (string= phase "public"))
2301                     (monky-propertize-labels `(,phase) 'face 'monky-log-head-label-phase))))
2302         (total-space-left (max 0 (- width (length hg-info))))
2303         (author-date-space-taken (+ 16 (min 10 (length author))))
2304         (message-space-left (number-to-string (max 0 (- total-space-left author-date-space-taken 1))))
2305         (msg-format (concat "%-" message-space-left "." message-space-left "s"))
2306         (msg (format msg-format message)))
2307    (let* ((shortened-msg (if (< 3 (length msg))
2308                              (concat (substring msg 0 -3) "...")
2309                            msg))
2310           (msg (if (>= (string-to-number message-space-left) (length message))
2311                   msg
2312                  shortened-msg)))
2313      (concat
2314       hg-info
2315       (propertize msg 'face 'monky-log-message)
2316       (propertize (format " %.10s" author) 'face 'monky-log-author)
2317       (propertize (format " %.10s" date) 'face 'monky-log-date)))))
2318
2319(defun monky-log-current-branch ()
2320  (interactive)
2321  (monky-log "ancestors(.)"))
2322
2323(defun monky-log-buffer-file ()
2324  "View a log of commits that affected the current file."
2325  (interactive)
2326  (monky-log "ancestors(.)" (buffer-file-name)))
2327
2328(defun monky-log-all ()
2329  (interactive)
2330  (monky-log nil))
2331
2332(defun monky-log-revset (revset)
2333  (interactive  "sRevset: ")
2334  (monky-log revset))
2335
2336(defun monky-log (revs &optional path)
2337  (monky-with-process
2338    (let ((topdir (monky-get-root-dir)))
2339      (pop-to-buffer monky-log-buffer-name)
2340      (setq default-directory topdir
2341            monky-root-dir topdir)
2342      (monky-mode-init topdir 'log (monky-refresh-log-buffer revs path))
2343      (monky-log-mode t))))
2344
2345(defvar monky-log-graph-re
2346  (concat
2347   "^\\([-_\\/@o+|\s]+\s*\\) "          ; 1. graph
2348   "\\([a-z0-9]\\{40\\}\\) "            ; 2. id
2349   "<branches>\\(.?*\\)</branches>"     ; 3. branches
2350   "<tags>\\(.?*\\)</tags>"             ; 4. tags
2351   "<bookmarks>\\(.?*\\)</bookmarks>"   ; 5. bookmarks
2352   "<phase>\\(.?*\\)</phase>"           ; 6. phase
2353   "<author>\\(.*?\\)</author>"         ; 7. author
2354   "<monky-date>\\([0-9]+\\).?*</monky-date>" ; 8. date
2355   "\\(.*\\)$"                          ; 9. msg
2356   ))
2357
2358(defun monky-decode-xml-entities (str)
2359  (setq str (replace-regexp-in-string "&lt;" "<" str))
2360  (setq str (replace-regexp-in-string "&gt;" ">" str))
2361  (setq str (replace-regexp-in-string "&amp;" "&" str))
2362  str)
2363
2364(defun monky-xml-items-to-list (xml-like tag)
2365  "Convert XML-LIKE string which has repeated TAG items into a list of strings.
2366
2367Example:
2368    (monky-xml-items-to-list \"<tag>A</tag><tag>B</tag>\" \"tag\")
2369    ; => (\"A\" \"B\")
2370"
2371  (mapcar #'monky-decode-xml-entities
2372          (split-string (replace-regexp-in-string
2373                         (format "^<%s>\\|</%s>$" tag tag) "" xml-like)
2374                        (format "</%s><%s>" tag tag))))
2375
2376(defvar monky-log-count ()
2377  "Internal var used to count the number of logs actually added in a buffer.")
2378
2379(defun monky--author-name (s)
2380  "Extract the name from a Mercurial author string."
2381  (save-match-data
2382    (cond
2383     ((string-match
2384       ;; If S contains a space, take the first word.
2385       (rx (group (1+ (not space)))
2386           space)
2387       s)
2388      (match-string 1 s))
2389     ((string-match
2390       ;; If S is just an email, take the username.
2391       (rx (group (1+ (not (any "@"))))
2392           "@")
2393       s)
2394      (match-string 1 s))
2395     (t s))))
2396
2397(defun monky-wash-log-line ()
2398  (if (looking-at monky-log-graph-re)
2399      (let ((width (window-total-width))
2400            (graph (match-string 1))
2401            (id (match-string 2))
2402            (branches (match-string 3))
2403            (tags (match-string 4))
2404            (bookmarks (match-string 5))
2405            (phase (match-string 6))
2406            (author (monky--author-name (match-string 7)))
2407            (date (format-time-string "%Y-%m-%d" (seconds-to-time (string-to-number (match-string 8)))))
2408            (msg (match-string 9)))
2409        (monky-delete-line)
2410        (monky-with-section id 'commit
2411          (insert (monky-present-log-line
2412                   width
2413                   graph id
2414                   (monky-xml-items-to-list branches "branch")
2415                   (monky-xml-items-to-list tags "tag")
2416                   (monky-xml-items-to-list bookmarks "bookmark")
2417                   (monky-decode-xml-entities phase)
2418                   (monky-decode-xml-entities author)
2419                   (monky-decode-xml-entities date)
2420                   (monky-decode-xml-entities msg)))
2421          (monky-set-section-info id)
2422          (when monky-log-count (incf monky-log-count))
2423          (forward-line)
2424          (when (looking-at "^\\([\\/@o+-|\s]+\s*\\)$")
2425            (let ((graph (match-string 1)))
2426              (insert "         ")
2427              (forward-line))))
2428        t)
2429    nil))
2430
2431(defun monky-wash-logs ()
2432  (let ((monky-old-top-section nil))
2433    (monky-wash-sequence #'monky-wash-log-line)))
2434
2435(defmacro monky-create-log-buffer-sections (&rest body)
2436  "Empty current buffer of text and monky's section, and then evaluate BODY.
2437
2438if the number of logs inserted in the buffer is `monky-log-cutoff-length'
2439insert a line to tell how to insert more of them"
2440  (declare (indent 0)
2441           (debug (body)))
2442  `(let ((monky-log-count 0))
2443     (monky-create-buffer-sections
2444       (monky-with-section 'log nil
2445         ,@body
2446         (if (= monky-log-count monky-log-cutoff-length)
2447           (monky-with-section "longer"  'longer
2448             (insert "type \"e\" to show more logs\n")))))))
2449
2450(defun monky-log-show-more-entries (&optional arg)
2451  "Grow the number of log entries shown.
2452
2453With no prefix optional ARG, show twice as much log entries.
2454With a numerical prefix ARG, add this number to the number of shown log entries.
2455With a non numeric prefix ARG, show all entries"
2456  (interactive "P")
2457  (make-local-variable 'monky-log-cutoff-length)
2458  (cond
2459   ((numberp arg)
2460    (setq monky-log-cutoff-length (+ monky-log-cutoff-length arg)))
2461   (arg
2462    (setq monky-log-cutoff-length monky-log-infinite-length))
2463   (t (setq monky-log-cutoff-length (* monky-log-cutoff-length 2))))
2464  (monky-refresh))
2465
2466(defun monky-refresh-log-buffer (revs path)
2467  (lambda ()
2468    (monky-create-log-buffer-sections
2469      (monky-hg-section
2470       'commits
2471       (if path
2472	   (format "Commits affecting %s:"
2473		   (file-relative-name path monky-root-dir))
2474	 "Commits:")
2475       #'monky-wash-logs
2476       "log"
2477       "--config" "extensions.graphlog="
2478       "-G"
2479       "--limit" (number-to-string monky-log-cutoff-length)
2480       "--style" monky-hg-style-log-graph
2481       (if revs "--rev" "")
2482       (if revs revs "")
2483       (if path path "")))))
2484
2485(defun monky-next-sha1 (pos)
2486  "Return position of next sha1 after given position POS"
2487  (while (and pos
2488              (not (equal (get-text-property pos 'face) 'monky-log-sha1)))
2489    (setq pos (next-single-property-change pos 'face)))
2490  pos)
2491
2492(defun monky-previous-sha1 (pos)
2493  "Return position of previous sha1 before given position POS"
2494  (while (and pos
2495              (not (equal (get-text-property pos 'face) 'monky-log-sha1)))
2496    (setq pos (previous-single-property-change pos 'face)))
2497  pos)
2498
2499;;; Blame mode
2500(define-minor-mode monky-blame-mode
2501  "Minor mode for hg blame.
2502
2503\\{monky-blame-mode-map}"
2504  :group monky
2505  :init-value ()
2506  :lighter ()
2507  :keymap monky-blame-mode-map)
2508
2509(defun monky-present-blame-line (author changeset text)
2510  (concat author
2511	  " "
2512	  (propertize changeset 'face 'monky-log-sha1)
2513	  ": "
2514	  text))
2515
2516(defvar monky-blame-re
2517  (concat
2518   "\\(.*\\) "               ; author
2519   "\\([a-f0-9]\\{12\\}\\):" ; changeset
2520   "\\(.*\\)$"               ; text
2521   ))
2522
2523(defun monky-wash-blame-line ()
2524  (if (looking-at monky-blame-re)
2525      (let ((author (match-string 1))
2526	    (changeset (match-string 2))
2527	    (text (match-string 3)))
2528	(monky-delete-line)
2529	(monky-with-section changeset 'commit
2530	  (insert (monky-present-blame-line author changeset text))
2531	  (monky-set-section-info changeset)
2532	  (forward-line))
2533	t)))
2534
2535(defun monky-wash-blame ()
2536  (monky-wash-sequence #'monky-wash-blame-line))
2537
2538(defun monky-refresh-blame-buffer (file-name)
2539  (monky-create-buffer-sections
2540    (monky-with-section file-name 'blame
2541      (monky-hg-section nil nil
2542			#'monky-wash-blame
2543			"blame"
2544			"--user"
2545			"--changeset"
2546			file-name))))
2547
2548(defun monky-blame-current-file ()
2549  (interactive)
2550  (monky-with-process
2551    (let ((file-name (buffer-file-name))
2552	  (topdir (monky-get-root-dir))
2553          (line-num (line-number-at-pos))
2554          (column (current-column)))
2555      (pop-to-buffer
2556       (format "*monky-blame: %s*"
2557               (file-name-nondirectory buffer-file-name)))
2558      (monky-mode-init topdir 'blame #'monky-refresh-blame-buffer file-name)
2559      (monky-blame-mode t)
2560      ;; Put point on the same line number as the original file.
2561      (forward-line (1- line-num))
2562      (while (and (not (looking-at ":")) (not (eolp)))
2563        (forward-char))
2564      ;; Step over the blame information columns.
2565      (forward-char (length ":  "))
2566      ;; Put point at the same column as the original file.
2567      (forward-char column))))
2568
2569;;; Commit mode
2570
2571(define-minor-mode monky-commit-mode
2572  "Minor mode to view a hg commit.
2573
2574\\{monky-commit-mode-map}"
2575
2576  :group monky
2577  :init-value ()
2578  :lighter ()
2579  :keymap monky-commit-mode-map)
2580
2581(defvar monky-commit-buffer-name "*monky-commit*")
2582
2583(defun monky-empty-buffer-p (buffer)
2584  (with-current-buffer buffer
2585    (< (length (buffer-string)) 1)))
2586
2587(defun monky-show-commit (commit &optional select scroll)
2588  (monky-with-process
2589    (when (monky-section-p commit)
2590      (setq commit (monky-section-info commit)))
2591    (unless (and commit
2592                 (monky-hg-revision-p commit))
2593      (error "%s is not a commit" commit))
2594    (let ((topdir (monky-get-root-dir))
2595          (buffer (get-buffer-create monky-commit-buffer-name)))
2596      (cond
2597       ((and scroll
2598	     (not (monky-empty-buffer-p buffer)))
2599        (let ((win (get-buffer-window buffer)))
2600          (cond ((not win)
2601                 (display-buffer buffer))
2602                (t
2603                 (with-selected-window win
2604                   (funcall scroll))))))
2605       (t
2606        (display-buffer buffer)
2607        (with-current-buffer buffer
2608          (monky-mode-init topdir 'commit
2609                           #'monky-refresh-commit-buffer commit)
2610          (monky-commit-mode t))))
2611      (if select
2612          (pop-to-buffer buffer)))))
2613
2614(defun monky-show-shelf (name)
2615  (let ((buffer (get-buffer-create "*monky-shelf*"))
2616        (inhibit-read-only t))
2617    (pop-to-buffer buffer)
2618
2619    (erase-buffer)
2620    (monky-hg-section
2621     nil nil
2622     #'ignore
2623     "shelve" "-l" "-p" name)
2624    (goto-char (point-min))
2625    (when (re-search-forward "^diff " nil t)
2626      (goto-char (line-beginning-position))
2627      (monky-wash-diffs))
2628    (monky-mode)))
2629
2630(defun monky-delete-shelf (name)
2631  (unless (zerop (monky-hg-exit-code "shelve" "--delete" name))
2632    (user-error "Could not drop shelved %s" name))
2633  (monky-refresh-buffer))
2634
2635(defun monky-refresh-commit-buffer (commit)
2636  (monky-create-buffer-sections
2637    (monky-hg-section nil nil
2638                      #'monky-wash-commit
2639                      "-v"
2640                      "log"
2641                      "--stat"
2642                      "--patch"
2643                      "--rev" commit)))
2644
2645(defun monky-wash-commit ()
2646  (save-excursion
2647    (monky-wash-parent))
2648  (let ((case-fold-search nil))
2649   (while (and (not (eobp)) (not (looking-at "^diff ")) )
2650     (forward-line))
2651   (when (looking-at "^diff ")
2652     (monky-wash-diffs))))
2653
2654;;; Branch mode
2655(define-minor-mode monky-branches-mode
2656  "Minor mode for hg branch.
2657
2658\\{monky-branches-mode-map}"
2659  :group monky
2660  :init-value ()
2661  :lighter ()
2662  :keymap monky-branches-mode-map)
2663
2664(defvar monky-branches-buffer-name "*monky-branches*")
2665
2666(defvar monky-branch-re "^\\(.*[^\s]\\)\s* \\([0-9]+\\):\\([0-9a-z]\\{12\\}\\)\\(.*\\)$")
2667
2668(defvar-local monky-current-branch-name nil)
2669
2670(defun monky-present-branch-line (name rev node status)
2671  (concat rev " : "
2672          (propertize node 'face 'monky-log-sha1) " "
2673          (if (equal name monky-current-branch-name)
2674              (propertize name 'face 'monky-branch)
2675            name)
2676          " "
2677          status))
2678
2679(defun monky-wash-branch-line ()
2680  (if (looking-at monky-branch-re)
2681      (let ((name (match-string 1))
2682            (rev (match-string 2))
2683            (node (match-string 3))
2684            (status (match-string 4)))
2685        (monky-delete-line)
2686        (monky-with-section name 'branch
2687          (insert (monky-present-branch-line name rev node status))
2688          (monky-set-section-info node)
2689          (forward-line))
2690        t)
2691    nil))
2692
2693(defun monky-wash-branches ()
2694  (monky-wash-sequence #'monky-wash-branch-line))
2695
2696(defun monky-refresh-branches-buffer ()
2697  (setq monky-current-branch-name (monky-current-branch))
2698  (monky-create-buffer-sections
2699    (monky-with-section 'buffer nil
2700      (monky-hg-section nil "Branches:"
2701                        #'monky-wash-branches
2702                        "branches"))))
2703
2704(defun monky-current-branch ()
2705  (monky-hg-string "branch"))
2706
2707(defun monky-branches ()
2708  (interactive)
2709  (let ((topdir (monky-get-root-dir)))
2710    (pop-to-buffer monky-branches-buffer-name)
2711    (monky-mode-init topdir 'branches #'monky-refresh-branches-buffer)
2712    (monky-branches-mode t)))
2713
2714(defun monky-checkout-item ()
2715  "Checkout the revision represented by current item."
2716  (interactive)
2717  (monky-section-action "checkout"
2718    ((branch)
2719     (monky-checkout (monky-section-info (monky-current-section))))
2720    ((log commits commit)
2721     (monky-checkout (monky-section-info (monky-current-section))))))
2722
2723(defun monky-merge-item ()
2724  "Merge the revision represented by current item."
2725  (interactive)
2726  (monky-section-action "merge"
2727    ((branch)
2728     (monky-merge (monky-section-info (monky-current-section))))
2729    ((log commits commit)
2730     (monky-merge (monky-section-info (monky-current-section))))))
2731
2732;;; Queue mode
2733(define-minor-mode monky-queue-mode
2734  "Minor mode for hg Queue.
2735
2736\\{monky-queue-mode-map}"
2737  :group monky
2738  :init-value ()
2739  :lighter ()
2740  :keymap monky-queue-mode-map)
2741
2742(defvar monky-queue-buffer-name "*monky-queue*")
2743
2744(defvar-local monky-patches-dir ".hg/patches/")
2745
2746(defun monky-patch-series-file ()
2747  (concat monky-patches-dir "series"))
2748
2749(defun monky-insert-patch (patch inserter &rest args)
2750  (let ((p (point))
2751        (monky-hide-diffs nil))
2752    (save-restriction
2753      (narrow-to-region p p)
2754      (apply inserter args)
2755      (goto-char (point-max))
2756      (if (not (eq (char-before) ?\n))
2757          (insert "\n"))
2758      (goto-char p)
2759      (while (and (not (eobp)) (not (looking-at "^diff")))
2760        (monky-delete-line t))
2761      (when (looking-at "^diff")
2762        (monky-wash-diffs))
2763      (goto-char (point-max)))))
2764
2765(defun monky-insert-guards (patch)
2766  (let ((guards (remove-if
2767                 (lambda (guard) (string= "unguarded" guard))
2768                 (split-string
2769                  (cadr (split-string
2770                         (monky-hg-string "qguard" patch
2771                                          "--config" "extensions.mq=")
2772                         ":"))))))
2773    (dolist (guard guards)
2774      (insert (propertize " " 'face 'monky-queue-patch)
2775              (propertize guard
2776                          'face
2777                          (if (monky-string-starts-with-p guard "+")
2778                              'monky-queue-positive-guard
2779                            'monky-queue-negative-guard))))
2780    (insert (propertize "\n" 'face 'monky-queue-patch))))
2781
2782(defun monky-wash-queue-patch ()
2783  (monky-wash-queue-insert-patch #'insert-file-contents))
2784
2785(defvar monky-queue-staged-all-files nil)
2786(defvar-local monky-queue-staged-files nil)
2787(defvar-local monky-queue-old-staged-files nil)
2788
2789(defun monky-wash-queue-discarding ()
2790  (monky-wash-status-lines
2791   (lambda (status file)
2792     (let ((monky-section-hidden-default monky-hide-diffs))
2793       (if (or monky-queue-staged-all-files
2794               (member file monky-old-staged-files)
2795               (member file monky-queue-old-staged-files))
2796           (monky-queue-stage-file file)
2797         (monky-with-section file 'diff
2798           (monky-insert-diff file status "qdiff"))))))
2799  (setq monky-queue-staged-all-files nil))
2800
2801(defun monky-wash-queue-insert-patch (inserter)
2802  (if (looking-at "^\\([^\n]+\\)$")
2803      (let ((patch (match-string 1)))
2804        (monky-delete-line)
2805        (let ((monky-section-hidden-default t))
2806          (monky-with-section patch 'patch
2807            (monky-set-section-info patch)
2808            (insert
2809             (propertize (format "\t%s" patch) 'face 'monky-queue-patch))
2810            (monky-insert-guards patch)
2811            (funcall #'monky-insert-patch
2812                     patch inserter (concat monky-patches-dir patch))
2813            (forward-line)))
2814        t)
2815    nil))
2816
2817(defun monky-wash-queue-queue ()
2818  (if (looking-at "^\\([^()\n]+\\)\\(\\s-+([^)]*)\\)?$")
2819      (let ((queue (match-string 1)))
2820        (monky-delete-line)
2821        (when (match-beginning 2)
2822          (setq monky-patches-dir
2823                (if (string= queue "patches")
2824                    ".hg/patches/"
2825                  (concat ".hg/patches-" queue "/")))
2826          (put-text-property 0 (length queue) 'face 'monky-queue-active queue))
2827        (monky-with-section queue 'queue
2828          (monky-set-section-info queue)
2829          (insert "\t" queue)
2830          (forward-line))
2831        t)
2832    nil))
2833
2834(defun monky-wash-queue-queues ()
2835    (if (looking-at "^patches (.*)\n?\\'")
2836        (progn
2837          (monky-delete-line t)
2838          nil)
2839      (monky-wash-sequence #'monky-wash-queue-queue)))
2840
2841(defun monky-wash-queue-patches ()
2842  (monky-wash-sequence #'monky-wash-queue-patch))
2843
2844;;; Queues
2845(defun monky-insert-queue-queues ()
2846  (monky-hg-section 'queues "Patch Queues:"
2847                    #'monky-wash-queue-queues
2848                    "qqueue" "--list" "extensions.mq="))
2849
2850;;; Applied Patches
2851(defun monky-insert-queue-applied ()
2852  (monky-hg-section 'applied "Applied Patches:" #'monky-wash-queue-patches
2853                    "qapplied" "--config" "extensions.mq="))
2854
2855;;; UnApplied Patches
2856(defun monky-insert-queue-unapplied ()
2857  (monky-hg-section 'unapplied "UnApplied Patches:" #'monky-wash-queue-patches
2858                    "qunapplied" "--config" "extensions.mq="))
2859
2860;;; Series
2861(defun monky-insert-queue-series ()
2862  (monky-hg-section 'qseries "Series:" #'monky-wash-queue-patches
2863                    "qseries" "--config" "extensions.mq="))
2864
2865;;; Qdiff
2866(defun monky-insert-queue-discarding ()
2867  (when (monky-qtip-p)
2868    (setq monky-queue-old-staged-files (copy-list monky-queue-staged-files))
2869    (setq monky-queue-staged-files '())
2870    (let ((monky-hide-diffs t))
2871      (monky-hg-section 'discarding "Discarding (qdiff):"
2872                        #'monky-wash-queue-discarding
2873                        "log" "--style" monky-hg-style-files-status
2874                        "--rev" "qtip"))))
2875
2876(defun monky-insert-queue-staged-changes ()
2877  (when (and (monky-qtip-p)
2878             (or monky-queue-staged-files monky-staged-files))
2879    (monky-with-section 'queue-staged nil
2880      (insert (propertize "Staged changes (qdiff):"
2881                          'face 'monky-section-title) "\n")
2882      (let ((monky-section-hidden-default t))
2883        (dolist (file (delete-dups (copy-list (append monky-queue-staged-files
2884                                                      monky-staged-files))))
2885          (monky-with-section file 'diff
2886            (monky-insert-diff file nil "qdiff")))))
2887    (insert "\n")))
2888
2889(defun monky-wash-active-guards ()
2890  (if (looking-at "^no active guards")
2891      (monky-delete-line t)
2892    (monky-wash-sequence
2893     (lambda ()
2894       (let ((guard (buffer-substring (point) (point-at-eol))))
2895         (monky-delete-line)
2896         (insert " " (propertize guard 'face 'monky-queue-positive-guard))
2897         (forward-line))))))
2898
2899
2900;;; Active guards
2901(defun monky-insert-active-guards ()
2902  (monky-hg-section 'active-guards "Active Guards:" #'monky-wash-active-guards
2903                    "qselect" "--config" "extensions.mq="))
2904
2905;;; Queue Staged Changes
2906
2907(defun monky-queue-stage-file (file)
2908  (push file monky-queue-staged-files))
2909
2910(defun monky-queue-unstage-file (file)
2911  (setq monky-queue-staged-files (delete file monky-queue-staged-files)))
2912
2913(defun monky-refresh-queue-buffer ()
2914  (monky-create-buffer-sections
2915    (monky-with-section 'queue nil
2916      (monky-insert-untracked-files)
2917      (monky-insert-missing-files)
2918      (monky-insert-changes)
2919      (monky-insert-staged-changes)
2920      (monky-insert-queue-discarding)
2921      (monky-insert-queue-staged-changes)
2922      (monky-insert-queue-queues)
2923      (monky-insert-active-guards)
2924      (monky-insert-queue-applied)
2925      (monky-insert-queue-unapplied)
2926      (monky-insert-queue-series))))
2927
2928(defun monky-queue ()
2929  (interactive)
2930  (monky-with-process
2931    (let ((topdir (monky-get-root-dir)))
2932      (pop-to-buffer monky-queue-buffer-name)
2933      (monky-mode-init topdir 'queue #'monky-refresh-queue-buffer)
2934      (monky-queue-mode t))))
2935
2936(defun monky-qqueue (queue)
2937  (monky-run-hg "qqueue"
2938                "--config" "extensions.mq="
2939                queue))
2940
2941(defun monky-qpop (&optional patch)
2942  (interactive)
2943  (apply #'monky-run-hg
2944         "qpop"
2945         "--config" "extensions.mq="
2946         (if patch (list patch) '())))
2947
2948(defun monky-qpush (&optional patch)
2949  (interactive)
2950  (apply #'monky-run-hg
2951         "qpush"
2952         "--config" "extensions.mq="
2953         (if patch (list patch) '())))
2954
2955(defun monky-qpush-all ()
2956  (interactive)
2957  (monky-run-hg "qpush" "--all"
2958                "--config" "extensions.mq="))
2959
2960(defun monky-qpop-all ()
2961  (interactive)
2962  (monky-run-hg "qpop" "--all"
2963                "--config" "extensions.mq="))
2964
2965(defvar monky-log-edit-buffer-name "*monky-edit-log*"
2966  "Buffer name for composing commit messages.")
2967
2968(defun monky-qrefresh ()
2969  (interactive)
2970  (if (not current-prefix-arg)
2971      (apply #'monky-run-hg "qrefresh"
2972             "--config" "extensions.mq="
2973             (append monky-staged-files monky-queue-staged-files))
2974    ;; get last commit message
2975    (with-current-buffer (get-buffer-create monky-log-edit-buffer-name)
2976      (monky-hg-insert
2977       (list "log" "--config" "extensions.mq="
2978             "--template" "{desc}" "-r" "-1")))
2979    (monky-pop-to-log-edit 'qrefresh)))
2980
2981(defun monky-qremove (patch)
2982  (monky-run-hg "qremove" patch
2983                "--config" "extensions.mq="))
2984
2985(defun monky-qnew (patch)
2986  (interactive (list (read-string "Patch Name : ")))
2987  (if (not current-prefix-arg)
2988      (monky-run-hg "qnew" patch
2989                    "--config" "extensions.mq=")
2990    (monky-pop-to-log-edit 'qnew patch)))
2991
2992(defun monky-qinit ()
2993  (interactive)
2994  (monky-run-hg "qinit"
2995                "--config" "extensions.mq="))
2996
2997(defun monky-qimport (node-1 &optional node-2)
2998  (monky-run-hg "qimport" "--rev"
2999                (if node-2 (concat node-1 ":" node-2) node-1)
3000                "--config" "extensions.mq="))
3001
3002(defun monky-qrename (old-patch &optional new-patch)
3003  (let ((new-patch (or new-patch
3004                       (read-string "New Patch Name : "))))
3005    (monky-run-hg "qrename" old-patch new-patch
3006                  "--config" "extensions.mq=")))
3007
3008(defun monky-qfold (patch)
3009  (monky-run-hg "qfold" patch
3010                "--config" "extensions.mq="))
3011
3012(defun monky-qguard (patch)
3013  (let ((guards (monky-parse-args (read-string "Guards : "))))
3014    (apply #'monky-run-hg "qguard" patch
3015           "--config" "extensions.mq="
3016           "--" guards)))
3017
3018(defun monky-qselect ()
3019  (interactive)
3020  (let ((guards (monky-parse-args (read-string "Guards : "))))
3021    (apply #'monky-run-hg "qselect"
3022           "--config" "extensions.mq="
3023           guards)))
3024
3025(defun monky-qfinish (patch)
3026  (monky-run-hg "qfinish" patch
3027                "--config" "extensions.mq="))
3028
3029(defun monky-qfinish-applied ()
3030  (interactive)
3031  (monky-run-hg "qfinish" "--applied"
3032                "--config" "extensions.mq="))
3033
3034(defun monky-qreorder ()
3035  "Pop all patches and edit .hg/patches/series file to reorder them"
3036  (interactive)
3037  (let ((series (monky-patch-series-file)))
3038   (monky-qpop-all)
3039   (with-current-buffer (get-buffer-create monky-log-edit-buffer-name)
3040     (erase-buffer)
3041     (insert-file-contents series))
3042   (monky-pop-to-log-edit 'qreorder)))
3043
3044(defun monky-queue-stage-all ()
3045  "Add all items in Changes to the staging area."
3046  (interactive)
3047  (monky-with-refresh
3048    (setq monky-queue-staged-all-files t)
3049    (monky-refresh-buffer)))
3050
3051(defun monky-queue-unstage-all ()
3052  "Remove all items from the staging area"
3053  (interactive)
3054  (monky-with-refresh
3055    (setq monky-queue-staged-files '())
3056    (monky-refresh-buffer)))
3057
3058(defun monky-qimport-item ()
3059  (interactive)
3060  (monky-section-action "qimport"
3061    ((log commits commit)
3062     (if (region-active-p)
3063	 (monky-qimport
3064	  (monky-section-info (monky-section-at (monky-next-sha1 (region-beginning))))
3065	  (monky-section-info (monky-section-at
3066			       (monky-previous-sha1 (- (region-end) 1)))))
3067       (monky-qimport (monky-section-info (monky-current-section)))))))
3068
3069(defun monky-qpop-item ()
3070  (interactive)
3071  (monky-section-action "qpop"
3072    ((applied patch)
3073     (monky-qpop (monky-section-info (monky-current-section)))
3074     (monky-qpop))
3075    ((applied)
3076     (monky-qpop-all))
3077    ((staged diff)
3078     (monky-unstage-file (monky-section-title (monky-current-section)))
3079     (monky-queue-unstage-file (monky-section-title (monky-current-section)))
3080     (monky-refresh-buffer))
3081    ((staged)
3082     (monky-unstage-all)
3083     (monky-queue-unstage-all))
3084    ((queue-staged diff)
3085     (monky-unstage-file (monky-section-title (monky-current-section)))
3086     (monky-queue-unstage-file (monky-section-title (monky-current-section)))
3087     (monky-refresh-buffer))
3088    ((queue-staged)
3089     (monky-unstage-all)
3090     (monky-queue-unstage-all))))
3091
3092(defun monky-qpush-item ()
3093  (interactive)
3094  (monky-section-action "qpush"
3095    ((unapplied patch)
3096     (monky-qpush (monky-section-info (monky-current-section))))
3097    ((unapplied)
3098     (monky-qpush-all))
3099    ((untracked file)
3100     (monky-run-hg "add" (monky-section-info (monky-current-section))))
3101    ((untracked)
3102     (monky-run-hg "add"))
3103    ((missing file)
3104     (monky-run-hg "remove" "--after" (monky-section-info (monky-current-section))))
3105    ((changes diff)
3106     (monky-stage-file (monky-section-title (monky-current-section)))
3107     (monky-queue-stage-file (monky-section-title (monky-current-section)))
3108     (monky-refresh-buffer))
3109    ((changes)
3110     (monky-stage-all)
3111     (monky-queue-stage-all))
3112    ((discarding diff)
3113     (monky-stage-file (monky-section-title (monky-current-section)))
3114     (monky-queue-stage-file (monky-section-title (monky-current-section)))
3115     (monky-refresh-buffer))
3116    ((discarding)
3117     (monky-stage-all)
3118     (monky-queue-stage-all))))
3119
3120(defun monky-qremove-item ()
3121  (interactive)
3122  (monky-section-action "qremove"
3123    ((unapplied patch)
3124     (monky-qremove (monky-section-info (monky-current-section))))))
3125
3126(defun monky-qrename-item ()
3127  (interactive)
3128  (monky-section-action "qrename"
3129    ((patch)
3130     (monky-qrename (monky-section-info (monky-current-section))))))
3131
3132(defun monky-qfold-item ()
3133  (interactive)
3134  (monky-section-action "qfold"
3135    ((unapplied patch)
3136     (monky-qfold (monky-section-info (monky-current-section))))))
3137
3138(defun monky-qguard-item ()
3139  (interactive)
3140  (monky-section-action "qguard"
3141    ((patch)
3142     (monky-qguard (monky-section-info (monky-current-section))))))
3143
3144(defun monky-qfinish-item ()
3145  (interactive)
3146  (monky-section-action "qfinish"
3147    ((applied patch)
3148     (monky-qfinish (monky-section-info (monky-current-section))))))
3149
3150;;; Log edit mode
3151
3152(define-derived-mode monky-log-edit-mode text-mode "Monky Log Edit")
3153
3154(defun monky-restore-pre-log-edit-window-configuration ()
3155  (when monky-pre-log-edit-window-configuration
3156    (set-window-configuration monky-pre-log-edit-window-configuration)
3157    (setq monky-pre-log-edit-window-configuration nil)))
3158
3159(defun monky-log-edit-commit ()
3160  "Finish edit and commit."
3161  (interactive)
3162  (when (= (buffer-size) 0)
3163    (user-error "No %s message" monky-log-edit-operation))
3164  (let ((commit-buf (current-buffer)))
3165    (case monky-log-edit-operation
3166      ('commit
3167       (with-current-buffer (monky-find-status-buffer default-directory)
3168         (apply #'monky-run-async-with-input commit-buf
3169                monky-hg-executable
3170                (append monky-hg-standard-options
3171                        (list "commit" "--logfile" "-")
3172                        monky-staged-files))))
3173      ('amend
3174       (with-current-buffer (monky-find-status-buffer default-directory)
3175         (apply #'monky-run-async-with-input commit-buf
3176                monky-hg-executable
3177                (append monky-hg-standard-options
3178                        (list "commit" "--amend" "--logfile" "-")
3179                        monky-staged-files))))
3180      ('backout
3181       (with-current-buffer monky-log-edit-client-buffer
3182         (monky-run-async-with-input commit-buf
3183                                   monky-hg-executable
3184                                   "backout"
3185                                   "--merge"
3186                                   "--logfile" "-"
3187                                   monky-log-edit-info)))
3188      ('qnew
3189       (with-current-buffer monky-log-edit-client-buffer
3190         (monky-run-async-with-input commit-buf
3191                                     monky-hg-executable
3192                                     "qnew" monky-log-edit-info
3193                                     "--config" "extensions.mq="
3194                                     "--logfile" "-")))
3195      ('qrefresh
3196       (with-current-buffer monky-log-edit-client-buffer
3197         (apply #'monky-run-async-with-input commit-buf
3198                monky-hg-executable "qrefresh"
3199                "--config" "extensions.mq="
3200                "--logfile" "-"
3201                (append monky-staged-files monky-queue-staged-files))))
3202      ('qreorder
3203       (let* ((queue-buffer (monky-find-buffer 'queue))
3204	      (series (with-current-buffer queue-buffer
3205			(monky-patch-series-file))))
3206	(with-current-buffer monky-log-edit-buffer-name
3207	  (write-region (point-min) (point-max) series))
3208	(with-current-buffer queue-buffer
3209	  (monky-refresh))))))
3210  (erase-buffer)
3211  (bury-buffer)
3212  (monky-restore-pre-log-edit-window-configuration))
3213
3214(defun monky-log-edit-cancel-log-message ()
3215  "Abort edits and erase commit message being composed."
3216  (interactive)
3217  (when (or (not monky-log-edit-confirm-cancellation)
3218            (yes-or-no-p
3219             "Really cancel editing the log (any changes will be lost)?"))
3220    (erase-buffer)
3221    (bury-buffer)
3222    (monky-restore-pre-log-edit-window-configuration)))
3223
3224(defun monky-pop-to-log-edit (operation &optional info)
3225  (let ((dir default-directory)
3226        (buf (get-buffer-create monky-log-edit-buffer-name)))
3227    (setq monky-pre-log-edit-window-configuration
3228          (current-window-configuration)
3229          monky-log-edit-operation operation
3230          monky-log-edit-client-buffer (current-buffer)
3231          monky-log-edit-info info)
3232    (pop-to-buffer buf)
3233    (setq default-directory dir)
3234    (monky-log-edit-mode)
3235    (message "Type C-c C-c to %s (C-c C-k to cancel)." monky-log-edit-operation)))
3236
3237(defun monky-log-edit ()
3238  "Bring up a buffer to allow editing of commit messages."
3239  (interactive)
3240  (when (not (or monky-staged-files (monky-merge-p)))
3241    (if (y-or-n-p "Nothing staged. Stage and commit all changes? ")
3242        (monky-stage-all)
3243      (user-error "Nothing staged")))
3244  (monky-pop-to-log-edit 'commit))
3245
3246(defun monky-commit-amend ()
3247  "Amends previous commit.
3248Brings up a buffer to allow editing of commit message."
3249  (interactive)
3250  ;; get last commit message
3251  (with-current-buffer (get-buffer-create monky-log-edit-buffer-name)
3252    (monky-hg-insert
3253     (list "log"
3254           "--template" "{desc}" "-r" ".")))
3255  (monky-pop-to-log-edit 'amend))
3256
3257(defun monky-bookmark-create (bookmark-name)
3258  "Create a bookmark at the current location"
3259  (interactive "sBookmark name: ")
3260  (monky-run-hg-async "bookmark" bookmark-name))
3261
3262(defun monky-killall-monky-buffers ()
3263  (interactive)
3264  (cl-flet ((monky-buffer-p (b) (string-match "\*monky\\(:\\|-\\).*" (buffer-name b))))
3265    (let ((monky-buffers (cl-remove-if-not #'monky-buffer-p (buffer-list))))
3266      (cl-loop for mb in monky-buffers
3267               do
3268               (kill-buffer mb)))))
3269
3270(provide 'monky)
3271
3272;; Local Variables:
3273;; byte-compile-warnings: (not cl-functions)
3274;; End:
3275
3276;;; monky.el ends here