update mc
[emacs.git] / .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