.emacs.d/elisp/multiple-cursors/mc-mark-more.el

   1 ;;; mc-mark-more.el
   2
   3 ;; Copyright (C) 2012 Magnar Sveen
   4
   5 ;; Author: Magnar Sveen <magnars@gmail.com>
   6 ;; Keywords: editing cursors
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; This file contains functions to mark more parts of the buffer.
  24 ;; See ./features/mark-more.feature for examples.
  25
  26 ;; Please see multiple-cursors.el for more commentary.
  27
  28 ;;; Code:
  29
  30 (require 'multiple-cursors-core)
  31 (require 'thingatpt)
  32
  33 (defun mc/cursor-end (cursor)
  34   (if (overlay-get cursor 'mark-active)
  35       (max (overlay-get cursor 'point)
  36            (overlay-get cursor 'mark))
  37     (overlay-get cursor 'point)))
  38
  39 (defun mc/cursor-beg (cursor)
  40   (if (overlay-get cursor 'mark-active)
  41       (min (overlay-get cursor 'point)
  42            (overlay-get cursor 'mark))
  43     (overlay-get cursor 'point)))
  44
  45 (defun mc/furthest-region-end ()
  46   (let ((end (max (mark) (point))))
  47     (mc/for-each-fake-cursor
  48      (setq end (max end (mc/cursor-end cursor))))
  49     end))
  50
  51 (defun mc/first-region-start ()
  52   (let ((beg (min (mark) (point))))
  53     (mc/for-each-fake-cursor
  54      (setq beg (min beg (mc/cursor-beg cursor))))
  55     beg))
  56
  57 (defun mc/furthest-cursor-before-point ()
  58   (let ((beg (min (mark) (point)))
  59         furthest)
  60     (mc/for-each-fake-cursor
  61      (when (< (mc/cursor-beg cursor) beg)
  62        (setq beg (mc/cursor-beg cursor))
  63        (setq furthest cursor)))
  64     furthest))
  65
  66 (defun mc/furthest-cursor-after-point ()
  67   (let ((end (max (mark) (point)))
  68         furthest)
  69     (mc/for-each-fake-cursor
  70      (when (> (mc/cursor-end cursor) end)
  71        (setq end (mc/cursor-end cursor))
  72        (setq furthest cursor)))
  73     furthest))
  74
  75 (defun mc/region-strings ()
  76   (let ((strings (list (buffer-substring-no-properties (point) (mark)))))
  77     (mc/for-each-fake-cursor
  78      (add-to-list 'strings (buffer-substring-no-properties
  79                             (mc/cursor-beg cursor)
  80                             (mc/cursor-end cursor))))
  81     strings))
  82
  83 (defvar mc/enclose-search-term nil
  84   "How should mc/mark-more-* search for more matches?
  85
  86 Match everything: nil
  87 Match only whole words: 'words
  88 Match only whole symbols: 'symbols
  89
  90 Use like case-fold-search, don't recommend setting it globally.")
  91
  92 (defun mc/mark-more-like-this (skip-last direction)
  93   (let ((case-fold-search nil)
  94         (re (regexp-opt (mc/region-strings) mc/enclose-search-term))
  95         (point-out-of-order (ecase direction
  96                               (forwards       (< (point) (mark)))
  97                               (backwards (not (< (point) (mark))))))
  98         (furthest-cursor (ecase direction
  99                            (forwards  (mc/furthest-cursor-after-point))
 100                            (backwards (mc/furthest-cursor-before-point))))
 101         (start-char (ecase direction
 102                       (forwards  (mc/furthest-region-end))
 103                       (backwards (mc/first-region-start))))
 104         (search-function (ecase direction
 105                            (forwards  'search-forward-regexp)
 106                            (backwards 'search-backward-regexp)))
 107         (match-point-getter (ecase direction
 108                               (forwards 'match-beginning)
 109                               (backwards 'match-end))))
 110     (mc/save-excursion
 111      (goto-char start-char)
 112      (when skip-last
 113        (mc/remove-fake-cursor furthest-cursor))
 114      (if (funcall search-function re nil t)
 115          (progn
 116            (push-mark (funcall match-point-getter 0))
 117            (when point-out-of-order
 118              (exchange-point-and-mark))
 119            (mc/create-fake-cursor-at-point))
 120        (error "no more matches found.")))))
 121
 122 ;;;###autoload
 123 (defun mc/mark-next-like-this (arg)
 124   "Find and mark the next part of the buffer matching the currently active region
 125 With negative ARG, delete the last one instead.
 126 With zero ARG, skip the last one and mark next."
 127   (interactive "p")
 128   (if (region-active-p)
 129       (if (< arg 0)
 130           (mc/remove-fake-cursor (mc/furthest-cursor-after-point))
 131         (mc/mark-more-like-this (= arg 0) 'forwards))
 132     (mc/mark-lines arg 'forwards))
 133   (mc/maybe-multiple-cursors-mode))
 134
 135 ;;;###autoload
 136 (defun mc/mark-next-word-like-this (arg)
 137   (interactive "p")
 138   (let ((mc/enclose-search-term 'words))
 139     (mc/mark-next-like-this arg)))
 140
 141 ;;;###autoload
 142 (defun mc/mark-next-symbol-like-this (arg)
 143   (interactive "p")
 144   (let ((mc/enclose-search-term 'symbols))
 145     (mc/mark-next-like-this arg)))
 146
 147 ;;;###autoload
 148 (defun mc/mark-previous-like-this (arg)
 149   "Find and mark the previous part of the buffer matching the currently active region
 150 With negative ARG, delete the last one instead.
 151 With zero ARG, skip the last one and mark next."
 152   (interactive "p")
 153   (if (region-active-p)
 154       (if (< arg 0)
 155           (mc/remove-fake-cursor (mc/furthest-cursor-before-point))
 156         (mc/mark-more-like-this (= arg 0) 'backwards))
 157     (mc/mark-lines arg 'backwards))
 158   (mc/maybe-multiple-cursors-mode))
 159
 160 ;;;###autoload
 161 (defun mc/mark-previous-word-like-this (arg)
 162   (interactive "p")
 163   (let ((mc/enclose-search-term 'words))
 164     (mc/mark-previous-like-this arg)))
 165
 166 ;;;###autoload
 167 (defun mc/mark-previous-symbol-like-this (arg)
 168   (interactive "p")
 169   (let ((mc/enclose-search-term 'symbols))
 170     (mc/mark-previous-like-this arg)))
 171
 172 (defun mc/mark-lines (num-lines direction)
 173   (dotimes (i num-lines)
 174     (mc/create-fake-cursor-at-point)
 175     (ecase direction
 176       (forwards (loop do (next-logical-line 1 nil)
 177                       while (mc/all-fake-cursors (point) (1+ (point)))))
 178       (backwards (loop do (previous-logical-line 1 nil)
 179                        while (mc/all-fake-cursors (point) (1+ (point))))))))
 180
 181 ;;;###autoload
 182 (defun mc/mark-next-lines (arg)
 183   (interactive "p")
 184   (mc/mark-lines arg 'forwards)
 185   (mc/maybe-multiple-cursors-mode))
 186
 187 ;;;###autoload
 188 (defun mc/mark-previous-lines (arg)
 189   (interactive "p")
 190   (mc/mark-lines arg 'backwards)
 191   (mc/maybe-multiple-cursors-mode))
 192
 193 ;;;###autoload
 194 (defun mc/unmark-next-like-this ()
 195   "Deselect next part of the buffer matching the currently active region."
 196   (interactive)
 197   (mc/mark-next-like-this -1))
 198
 199 ;;;###autoload
 200 (defun mc/unmark-previous-like-this ()
 201   "Deselect prev part of the buffer matching the currently active region."
 202   (interactive)
 203   (mc/mark-previous-like-this -1))
 204
 205 ;;;###autoload
 206 (defun mc/skip-to-next-like-this ()
 207   "Skip the current one and select the next part of the buffer matching the currently active region."
 208   (interactive)
 209   (mc/mark-next-like-this 0))
 210
 211 ;;;###autoload
 212 (defun mc/skip-to-previous-like-this ()
 213   "Skip the current one and select the prev part of the buffer matching the currently active region."
 214   (interactive)
 215   (mc/mark-previous-like-this 0))
 216
 217 ;;;###autoload
 218 (defun mc/mark-all-like-this ()
 219   "Find and mark all the parts of the buffer matching the currently active region"
 220   (interactive)
 221   (unless (region-active-p)
 222     (error "Mark a region to match first."))
 223   (mc/remove-fake-cursors)
 224   (let ((master (point))
 225         (case-fold-search nil)
 226         (point-first (< (point) (mark)))
 227         (re (regexp-opt (mc/region-strings) mc/enclose-search-term)))
 228     (mc/save-excursion
 229      (goto-char 0)
 230      (while (search-forward-regexp re nil t)
 231        (push-mark (match-beginning 0))
 232        (when point-first (exchange-point-and-mark))
 233        (unless (= master (point))
 234          (mc/create-fake-cursor-at-point))
 235        (when point-first (exchange-point-and-mark)))))
 236   (if (> (mc/num-cursors) 1)
 237       (multiple-cursors-mode 1)
 238     (multiple-cursors-mode 0)))
 239
 240 (defun mc--select-thing-at-point (thing)
 241   (let ((bound (bounds-of-thing-at-point thing)))
 242     (when bound
 243       (set-mark (car bound))
 244       (goto-char (cdr bound))
 245       bound)))
 246
 247 (defun mc--select-thing-at-point-or-bark (thing)
 248   (unless (or (region-active-p) (mc--select-thing-at-point thing))
 249     (error "Mark a region or set cursor on a %s." thing)))
 250
 251 ;;;###autoload
 252 (defun mc/mark-all-words-like-this ()
 253   (interactive)
 254   (mc--select-thing-at-point-or-bark 'word)
 255   (let ((mc/enclose-search-term 'words))
 256     (mc/mark-all-like-this)))
 257
 258 ;;;###autoload
 259 (defun mc/mark-all-symbols-like-this ()
 260   (interactive)
 261   (mc--select-thing-at-point-or-bark 'symbol)
 262   (let ((mc/enclose-search-term 'symbols))
 263     (mc/mark-all-like-this)))
 264
 265 ;;;###autoload
 266 (defun mc/mark-all-in-region (beg end)
 267   "Find and mark all the parts in the region matching the given search"
 268   (interactive "r")
 269   (let ((search (read-from-minibuffer "Mark all in region: "))
 270         (case-fold-search nil))
 271     (if (string= search "")
 272         (message "Mark aborted")
 273       (progn
 274         (mc/remove-fake-cursors)
 275         (goto-char beg)
 276         (while (search-forward search end t)
 277           (push-mark (match-beginning 0))
 278           (mc/create-fake-cursor-at-point))
 279         (let ((first (mc/furthest-cursor-before-point)))
 280           (if (not first)
 281               (error "Search failed for %S" search)
 282             (mc/pop-state-from-overlay first)))
 283         (if (> (mc/num-cursors) 1)
 284             (multiple-cursors-mode 1)
 285           (multiple-cursors-mode 0))))))
 286
 287 (when (not (fboundp 'set-temporary-overlay-map))
 288   ;; Backport this function from newer emacs versions
 289   (defun set-temporary-overlay-map (map &optional keep-pred)
 290     "Set a new keymap that will only exist for a short period of time.
 291 The new keymap to use must be given in the MAP variable. When to
 292 remove the keymap depends on user input and KEEP-PRED:
 293
 294 - if KEEP-PRED is nil (the default), the keymap disappears as
 295   soon as any key is pressed, whether or not the key is in MAP;
 296
 297 - if KEEP-PRED is t, the keymap disappears as soon as a key *not*
 298   in MAP is pressed;
 299
 300 - otherwise, KEEP-PRED must be a 0-arguments predicate that will
 301   decide if the keymap should be removed (if predicate returns
 302   nil) or kept (otherwise). The predicate will be called after
 303   each key sequence."
 304
 305     (let* ((clearfunsym (make-symbol "clear-temporary-overlay-map"))
 306            (overlaysym (make-symbol "t"))
 307            (alist (list (cons overlaysym map)))
 308            (clearfun
 309             `(lambda ()
 310                (unless ,(cond ((null keep-pred) nil)
 311                               ((eq t keep-pred)
 312                                `(eq this-command
 313                                     (lookup-key ',map
 314                                                 (this-command-keys-vector))))
 315                               (t `(funcall ',keep-pred)))
 316                  (remove-hook 'pre-command-hook ',clearfunsym)
 317                  (setq emulation-mode-map-alists
 318                        (delq ',alist emulation-mode-map-alists))))))
 319       (set overlaysym overlaysym)
 320       (fset clearfunsym clearfun)
 321       (add-hook 'pre-command-hook clearfunsym)
 322
 323       (push alist emulation-mode-map-alists))))
 324
 325 ;;;###autoload
 326 (defun mc/mark-more-like-this-extended ()
 327   "Like mark-more-like-this, but then lets you adjust with arrows key.
 328 The adjustments work like this:
 329
 330    <up>    Mark previous like this and set direction to 'up
 331    <down>  Mark next like this and set direction to 'down
 332
 333 If direction is 'up:
 334
 335    <left>  Skip past the cursor furthest up
 336    <right> Remove the cursor furthest up
 337
 338 If direction is 'down:
 339
 340    <left>  Remove the cursor furthest down
 341    <right> Skip past the cursor furthest down
 342
 343 The bindings for these commands can be changed. See `mc/mark-more-like-this-extended-keymap'."
 344   (interactive)
 345   (mc/mmlte--down)
 346   (set-temporary-overlay-map mc/mark-more-like-this-extended-keymap t))
 347
 348 (defvar mc/mark-more-like-this-extended-direction nil
 349   "When using mc/mark-more-like-this-extended are we working on the next or previous cursors?")
 350
 351 (make-variable-buffer-local 'mc/mark-more-like-this-extended)
 352
 353 (defun mc/mmlte--message ()
 354   (if (eq mc/mark-more-like-this-extended-direction 'up)
 355       (message "<up> to mark previous, <left> to skip, <right> to remove, <down> to mark next")
 356     (message "<down> to mark next, <right> to skip, <left> to remove, <up> to mark previous")))
 357
 358 (defun mc/mmlte--up ()
 359   (interactive)
 360   (mc/mark-previous-like-this 1)
 361   (setq mc/mark-more-like-this-extended-direction 'up)
 362   (mc/mmlte--message))
 363
 364 (defun mc/mmlte--down ()
 365   (interactive)
 366   (mc/mark-next-like-this 1)
 367   (setq mc/mark-more-like-this-extended-direction 'down)
 368   (mc/mmlte--message))
 369
 370 (defun mc/mmlte--left ()
 371   (interactive)
 372   (if (eq mc/mark-more-like-this-extended-direction 'down)
 373       (mc/unmark-next-like-this)
 374     (mc/skip-to-previous-like-this))
 375   (mc/mmlte--message))
 376
 377 (defun mc/mmlte--right ()
 378   (interactive)
 379   (if (eq mc/mark-more-like-this-extended-direction 'up)
 380       (mc/unmark-previous-like-this)
 381     (mc/skip-to-next-like-this))
 382   (mc/mmlte--message))
 383
 384 (defvar mc/mark-more-like-this-extended-keymap (make-sparse-keymap))
 385
 386 (define-key mc/mark-more-like-this-extended-keymap (kbd "<up>") 'mc/mmlte--up)
 387 (define-key mc/mark-more-like-this-extended-keymap (kbd "<down>") 'mc/mmlte--down)
 388 (define-key mc/mark-more-like-this-extended-keymap (kbd "<left>") 'mc/mmlte--left)
 389 (define-key mc/mark-more-like-this-extended-keymap (kbd "<right>") 'mc/mmlte--right)
 390
 391 (defvar mc--restrict-mark-all-to-symbols nil)
 392
 393 ;;;###autoload
 394 (defun mc/mark-all-like-this-dwim (arg)
 395   "Tries to guess what you want to mark all of.
 396 Can be pressed multiple times to increase selection.
 397
 398 With prefix, it behaves the same as original `mc/mark-all-like-this'"
 399   (interactive "P")
 400   (if arg
 401       (mc/mark-all-like-this)
 402     (if (and (not (use-region-p))
 403              (derived-mode-p 'sgml-mode)
 404              (mc--on-tag-name-p))
 405         (mc/mark-sgml-tag-pair)
 406       (let ((before (mc/num-cursors)))
 407         (unless (eq last-command 'mc/mark-all-like-this-dwim)
 408           (setq mc--restrict-mark-all-to-symbols nil))
 409         (unless (use-region-p)
 410           (mc--mark-symbol-at-point)
 411           (setq mc--restrict-mark-all-to-symbols t))
 412         (if mc--restrict-mark-all-to-symbols
 413             (mc/mark-all-symbols-like-this-in-defun)
 414           (mc/mark-all-like-this-in-defun))
 415         (when (<= (mc/num-cursors) before)
 416           (if mc--restrict-mark-all-to-symbols
 417               (mc/mark-all-symbols-like-this)
 418             (mc/mark-all-like-this)))
 419         (when (<= (mc/num-cursors) before)
 420           (mc/mark-all-like-this))))))
 421
 422 ;;;###autoload
 423 (defun mc/mark-all-dwim (arg)
 424   "Tries even harder to guess what you want to mark all of.
 425
 426 If the region is active and spans multiple lines, it will behave
 427 as if `mc/mark-all-in-region'. With the prefix ARG, it will call
 428 `mc/edit-lines' instead.
 429
 430 If the region is inactive or on a single line, it will behave like
 431 `mc/mark-all-like-this-dwim'."
 432   (interactive "P")
 433   (if (and (use-region-p)
 434            (not (> (mc/num-cursors) 1))
 435            (not (= (line-number-at-pos (region-beginning))
 436                    (line-number-at-pos (region-end)))))
 437       (if arg
 438           (call-interactively 'mc/edit-lines)
 439        (call-interactively 'mc/mark-all-in-region))
 440     (progn
 441       (setq this-command 'mc/mark-all-like-this-dwim)
 442       (mc/mark-all-like-this-dwim arg))))
 443
 444 (defun mc--in-defun ()
 445   (bounds-of-thing-at-point 'defun))
 446
 447 ;;;###autoload
 448 (defun mc/mark-all-like-this-in-defun ()
 449   "Mark all like this in defun."
 450   (interactive)
 451   (if (mc--in-defun)
 452       (save-restriction
 453         (widen)
 454         (narrow-to-defun)
 455         (mc/mark-all-like-this))
 456     (mc/mark-all-like-this)))
 457
 458 ;;;###autoload
 459 (defun mc/mark-all-words-like-this-in-defun ()
 460   "Mark all words like this in defun."
 461   (interactive)
 462   (mc--select-thing-at-point-or-bark 'word)
 463   (if (mc--in-defun)
 464       (save-restriction
 465         (widen)
 466         (narrow-to-defun)
 467         (mc/mark-all-words-like-this))
 468     (mc/mark-all-words-like-this)))
 469
 470 ;;;###autoload
 471 (defun mc/mark-all-symbols-like-this-in-defun ()
 472   "Mark all symbols like this in defun."
 473   (interactive)
 474   (mc--select-thing-at-point-or-bark 'symbol)
 475   (if (mc--in-defun)
 476       (save-restriction
 477         (widen)
 478         (narrow-to-defun)
 479         (mc/mark-all-symbols-like-this))
 480     (mc/mark-all-symbols-like-this)))
 481
 482 (defun mc--mark-symbol-at-point ()
 483   "Select the symbol under cursor"
 484   (interactive)
 485   (when (not (use-region-p))
 486     (let ((b (bounds-of-thing-at-point 'symbol)))
 487       (goto-char (car b))
 488       (set-mark (cdr b)))))
 489
 490 (defun mc--get-nice-sgml-context ()
 491   (car
 492    (last
 493     (progn
 494       (when (looking-at "<") (forward-char 1))
 495       (when (looking-back ">") (forward-char -1))
 496       (sgml-get-context)))))
 497
 498 (defun mc--on-tag-name-p ()
 499   (let* ((context (save-excursion (mc--get-nice-sgml-context)))
 500          (tag-name-len (length (aref context 4)))
 501          (beg (aref context 2))
 502          (end (+ beg tag-name-len (if (eq 'open (aref context 1)) 1 3))))
 503     (and context
 504          (>= (point) beg)
 505          (<= (point) end))))
 506
 507 ;;;###autoload
 508 (defun mc/add-cursor-on-click (event)
 509   "Add a cursor where you click."
 510   (interactive "e")
 511   (mouse-minibuffer-check event)
 512   ;; Use event-end in case called from mouse-drag-region.
 513   ;; If EVENT is a click, event-end and event-start give same value.
 514   (let ((position (event-end event)))
 515     (if (not (windowp (posn-window position)))
 516         (error "Position not in text area of window"))
 517     (select-window (posn-window position))
 518     (if (numberp (posn-point position))
 519         (save-excursion
 520           (goto-char (posn-point position))
 521           (mc/create-fake-cursor-at-point)))
 522     (mc/maybe-multiple-cursors-mode)))
 523
 524 ;;;###autoload
 525 (defun mc/mark-sgml-tag-pair ()
 526   "Mark the tag we're in and its pair for renaming."
 527   (interactive)
 528   (when (not (mc--inside-tag-p))
 529     (error "Place point inside tag to rename."))
 530   (let ((context (mc--get-nice-sgml-context)))
 531     (if (looking-at "</")
 532         (setq context (car (last (sgml-get-context)))))
 533     (goto-char (aref context 2))
 534     (let* ((tag-name (aref context 4))
 535            (num-chars (length tag-name))
 536            (master-start (1+ (point)))
 537            (mirror-end (save-excursion
 538                          (sgml-skip-tag-forward 1)
 539                          (1- (point)))))
 540       (goto-char (- mirror-end num-chars))
 541       (set-mark mirror-end)
 542       (mc/create-fake-cursor-at-point)
 543       (goto-char master-start)
 544       (set-mark (+ (point) num-chars))))
 545   (mc/maybe-multiple-cursors-mode))
 546
 547 (defun mc--inside-tag-p ()
 548   (save-excursion
 549     (not (null (sgml-get-context)))))
 550
 551 (provide 'mc-mark-more)
 552
 553 ;;; mc-mark-more.el ends here