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