expand-region-core.el (12005B)
1 ;;; expand-region-core.el --- Increase selected region by semantic units. 2 3 ;; Copyright (C) 2011-2020 Free Software Foundation, Inc 4 5 ;; Author: Magnar Sveen <magnars@gmail.com> 6 ;; Keywords: marking region 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 ;; The core functionality of expand-region. 24 25 ;; See README.md 26 27 ;;; Code: 28 29 (eval-when-compile (require 'cl)) 30 (require 'expand-region-custom) 31 (declare-function er/expand-region "expand-region") 32 33 (defvar er/history '() 34 "A history of start and end points so we can contract after expanding.") 35 36 ;; history is always local to a single buffer 37 (make-variable-buffer-local 'er/history) 38 39 (defvar er--space-str " \t\n") 40 (defvar er--blank-list (append er--space-str nil)) 41 42 (set-default 'er--show-expansion-message nil) 43 44 (defvar er/try-expand-list nil 45 "A list of functions that are tried when expanding.") 46 47 (defvar er/save-mode-excursion nil 48 "A function to save excursion state when expanding.") 49 50 (defun er--prepare-expanding () 51 (when (and (er--first-invocation) 52 (not (use-region-p))) 53 (push-mark nil t) ;; one for keeping starting position 54 (push-mark nil t)) ;; one for replace by set-mark in expansions 55 56 (when (not transient-mark-mode) 57 (setq-local transient-mark-mode (cons 'only transient-mark-mode)))) 58 59 (defun er--copy-region-to-register () 60 (when (and (stringp expand-region-autocopy-register) 61 (> (length expand-region-autocopy-register) 0)) 62 (set-register (aref expand-region-autocopy-register 0) 63 (filter-buffer-substring (region-beginning) (region-end))))) 64 65 ;; save-mark-and-excursion in Emacs 25 works like save-excursion did before 66 (eval-when-compile 67 (when (< emacs-major-version 25) 68 (defmacro save-mark-and-excursion (&rest body) 69 `(save-excursion ,@body)))) 70 71 (defmacro er--save-excursion (&rest body) 72 `(let ((action (lambda () 73 (save-mark-and-excursion ,@body)))) 74 (if er/save-mode-excursion 75 (funcall er/save-mode-excursion action) 76 (funcall action)))) 77 78 (defun er--expand-region-1 () 79 "Increase selected region by semantic units. 80 Basically it runs all the mark-functions in `er/try-expand-list' 81 and chooses the one that increases the size of the region while 82 moving point or mark as little as possible." 83 (let* ((p1 (point)) 84 (p2 (if (use-region-p) (mark) (point))) 85 (start (min p1 p2)) 86 (end (max p1 p2)) 87 (try-list er/try-expand-list) 88 (best-start (point-min)) 89 (best-end (point-max)) 90 (set-mark-default-inactive nil)) 91 92 ;; add hook to clear history on buffer changes 93 (unless er/history 94 (add-hook 'after-change-functions 'er/clear-history t t)) 95 96 ;; remember the start and end points so we can contract later 97 ;; unless we're already at maximum size 98 (unless (and (= start best-start) 99 (= end best-end)) 100 (push (cons p1 p2) er/history)) 101 102 (when (and expand-region-skip-whitespace 103 (er--point-is-surrounded-by-white-space) 104 (= start end)) 105 (skip-chars-forward er--space-str) 106 (setq start (point))) 107 108 (while try-list 109 (er--save-excursion 110 (ignore-errors 111 (funcall (car try-list)) 112 (when (and (region-active-p) 113 (er--this-expansion-is-better start end best-start best-end)) 114 (setq best-start (point)) 115 (setq best-end (mark)) 116 (when (and er--show-expansion-message (not (minibufferp))) 117 (message "%S" (car try-list)))))) 118 (setq try-list (cdr try-list))) 119 120 (setq deactivate-mark nil) 121 ;; if smart cursor enabled, decide to put it at start or end of region: 122 (if (and expand-region-smart-cursor 123 (not (= start best-start))) 124 (progn (goto-char best-end) 125 (set-mark best-start)) 126 (goto-char best-start) 127 (set-mark best-end)) 128 129 (er--copy-region-to-register) 130 131 (when (and (= best-start (point-min)) 132 (= best-end (point-max))) ;; We didn't find anything new, so exit early 133 'early-exit))) 134 135 (defun er--this-expansion-is-better (start end best-start best-end) 136 "t if the current region is an improvement on previous expansions. 137 138 This is provided as a separate function for those that would like 139 to override the heuristic." 140 (and 141 (<= (point) start) 142 (>= (mark) end) 143 (> (- (mark) (point)) (- end start)) 144 (or (> (point) best-start) 145 (and (= (point) best-start) 146 (< (mark) best-end))))) 147 148 (defun er/contract-region (arg) 149 "Contract the selected region to its previous size. 150 With prefix argument contracts that many times. 151 If prefix argument is negative calls `er/expand-region'. 152 If prefix argument is 0 it resets point and mark to their state 153 before calling `er/expand-region' for the first time." 154 (interactive "p") 155 (if (< arg 0) 156 (er/expand-region (- arg)) 157 (when er/history 158 ;; Be sure to reset them all if called with 0 159 (when (= arg 0) 160 (setq arg (length er/history))) 161 162 (when (not transient-mark-mode) 163 (setq-local transient-mark-mode (cons 'only transient-mark-mode))) 164 165 ;; Advance through the list the desired distance 166 (while (and (cdr er/history) 167 (> arg 1)) 168 (setq arg (- arg 1)) 169 (setq er/history (cdr er/history))) 170 ;; Reset point and mark 171 (let* ((last (pop er/history)) 172 (start (car last)) 173 (end (cdr last))) 174 (goto-char start) 175 (set-mark end) 176 177 (er--copy-region-to-register) 178 179 (when (eq start end) 180 (deactivate-mark) 181 (er/clear-history)))))) 182 183 (defun er/prepare-for-more-expansions-internal (repeat-key-str) 184 "Return bindings and a message to inform user about them" 185 (let ((msg (format "Type %s to expand again" repeat-key-str)) 186 (bindings (list (cons repeat-key-str '(er/expand-region 1))))) 187 ;; If contract and expand are on the same binding, ignore contract 188 (unless (string-equal repeat-key-str expand-region-contract-fast-key) 189 (setq msg (concat msg (format ", %s to contract" expand-region-contract-fast-key))) 190 (push (cons expand-region-contract-fast-key '(er/contract-region 1)) bindings)) 191 ;; If reset and either expand or contract are on the same binding, ignore reset 192 (unless (or (string-equal repeat-key-str expand-region-reset-fast-key) 193 (string-equal expand-region-contract-fast-key expand-region-reset-fast-key)) 194 (setq msg (concat msg (format ", %s to reset" expand-region-reset-fast-key))) 195 (push (cons expand-region-reset-fast-key '(er/expand-region 0)) bindings)) 196 (cons msg bindings))) 197 198 (defun er/prepare-for-more-expansions () 199 "Let one expand more by just pressing the last key." 200 (let* ((repeat-key (event-basic-type last-input-event)) 201 (repeat-key-str (single-key-description repeat-key)) 202 (msg-and-bindings (er/prepare-for-more-expansions-internal repeat-key-str)) 203 (msg (car msg-and-bindings)) 204 (bindings (cdr msg-and-bindings))) 205 (when repeat-key 206 (er/set-temporary-overlay-map 207 (let ((map (make-sparse-keymap))) 208 (dolist (binding bindings map) 209 (define-key map (read-kbd-macro (car binding)) 210 `(lambda () 211 (interactive) 212 (setq this-command `,(cadr ',binding)) 213 (or (minibufferp) (message "%s" ,msg)) 214 (eval `,(cdr ',binding)))))) 215 t) 216 (or (minibufferp) (message "%s" msg))))) 217 218 (if (fboundp 'set-temporary-overlay-map) 219 (fset 'er/set-temporary-overlay-map 'set-temporary-overlay-map) 220 ;; Backport this function from newer emacs versions 221 (defun er/set-temporary-overlay-map (map &optional keep-pred) 222 "Set a new keymap that will only exist for a short period of time. 223 The new keymap to use must be given in the MAP variable. When to 224 remove the keymap depends on user input and KEEP-PRED: 225 226 - if KEEP-PRED is nil (the default), the keymap disappears as 227 soon as any key is pressed, whether or not the key is in MAP; 228 229 - if KEEP-PRED is t, the keymap disappears as soon as a key *not* 230 in MAP is pressed; 231 232 - otherwise, KEEP-PRED must be a 0-arguments predicate that will 233 decide if the keymap should be removed (if predicate returns 234 nil) or kept (otherwise). The predicate will be called after 235 each key sequence." 236 237 (let* ((clearfunsym (make-symbol "clear-temporary-overlay-map")) 238 (overlaysym (make-symbol "t")) 239 (alist (list (cons overlaysym map))) 240 (clearfun 241 `(lambda () 242 (unless ,(cond ((null keep-pred) nil) 243 ((eq t keep-pred) 244 `(eq this-command 245 (lookup-key ',map 246 (this-command-keys-vector)))) 247 (t `(funcall ',keep-pred))) 248 (remove-hook 'pre-command-hook ',clearfunsym) 249 (setq emulation-mode-map-alists 250 (delq ',alist emulation-mode-map-alists)))))) 251 (set overlaysym overlaysym) 252 (fset clearfunsym clearfun) 253 (add-hook 'pre-command-hook clearfunsym) 254 255 (push alist emulation-mode-map-alists)))) 256 257 (defadvice keyboard-quit (before collapse-region activate) 258 (when (memq last-command '(er/expand-region er/contract-region)) 259 (er/contract-region 0))) 260 261 (defadvice minibuffer-keyboard-quit (around collapse-region activate) 262 (if (memq last-command '(er/expand-region er/contract-region)) 263 (er/contract-region 0) 264 ad-do-it)) 265 266 (defadvice cua-cancel (before collapse-region activate) 267 (when (memq last-command '(er/expand-region er/contract-region)) 268 (er/contract-region 0))) 269 270 (defun er/clear-history (&rest args) 271 "Clear the history." 272 (setq er/history '()) 273 (remove-hook 'after-change-functions 'er/clear-history t)) 274 275 (defsubst er--first-invocation () 276 "t if this is the first invocation of er/expand-region or er/contract-region" 277 (not (memq last-command '(er/expand-region er/contract-region)))) 278 279 (defun er--point-is-surrounded-by-white-space () 280 (and (or (memq (char-before) er--blank-list) 281 (eq (point) (point-min))) 282 (memq (char-after) er--blank-list))) 283 284 (defun er/enable-mode-expansions (mode add-fn) 285 (add-hook (intern (format "%s-hook" mode)) add-fn) 286 (save-window-excursion 287 (dolist (buffer (buffer-list)) 288 (with-current-buffer buffer 289 (when (derived-mode-p mode) 290 (funcall add-fn)))))) 291 292 (defun er/enable-minor-mode-expansions (mode add-fn) 293 (add-hook (intern (format "%s-hook" mode)) add-fn) 294 (save-window-excursion 295 (dolist (buffer (buffer-list)) 296 (with-current-buffer buffer 297 (when (symbol-value mode) 298 (funcall add-fn)))))) 299 300 ;; Some more performant version of `looking-back' 301 302 (defun er/looking-back-on-line (regexp) 303 "Version of `looking-back' that only checks current line." 304 (looking-back regexp (line-beginning-position))) 305 306 (defun er/looking-back-exact (s) 307 "Version of `looking-back' that only looks for exact matches, no regexp." 308 (string= s (buffer-substring (- (point) (length s)) 309 (point)))) 310 311 (defun er/looking-back-max (regexp count) 312 "Version of `looking-back' that only check COUNT chars back." 313 (looking-back regexp (max 1 (- (point) count)))) 314 315 (provide 'expand-region-core) 316 317 ;;; expand-region-core.el ends here