mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-23 07:19:15 +00:00
Speed up tall rectangular selections (bug#72830)
Instead of setting the highlight overlay on every line in the selection, only do so on the window-height worth of lines closest to point because the rest aren't likely to be visible. This makes a massive difference for tall rectangular selections which previously were so slow as to be unusable. (Tall selections are still slow if `select-active-regions` is non-nil, but that is something that users can actually do something about.) * lisp/rect.el (rectangle--highlight-for-redisplay) (rectangle--unhighlight-for-redisplay): Replace call to `apply-on-rectangle`, which operates on every line, with a loop over an approximate screenful. Extend the `rectangle` overlay list structure with a value for point, because `exchange-point-and-mark` must trigger a recomputation of highlight overlays despite the selection not actually changing.
This commit is contained in:
Mattias Engdegård
parent
cbaf7edbb4
commit
38c7516827
188
lisp/rect.el
188
lisp/rect.el
@ -857,102 +857,130 @@ Ignores `line-move-visual'."
|
||||
(eq (nth 1 rol) (buffer-chars-modified-tick))
|
||||
(eq start (nth 2 rol))
|
||||
(eq end (nth 3 rol))
|
||||
(equal (rectangle--crutches) (nth 4 rol)))
|
||||
(equal (rectangle--crutches) (nth 4 rol))
|
||||
;; Check point explicitly so that `exchange-point-and-mark'
|
||||
;; triggers overlay recomputation.
|
||||
(eq (nth 5 rol) (point)))
|
||||
rol)
|
||||
(t
|
||||
(save-excursion
|
||||
(let* ((nrol nil)
|
||||
(let* ((pt (point))
|
||||
(nrol nil)
|
||||
(old (if (eq 'rectangle (car-safe rol))
|
||||
(nthcdr 5 rol)
|
||||
(nthcdr 6 rol)
|
||||
(funcall redisplay-unhighlight-region-function rol)
|
||||
nil)))
|
||||
(cl-assert (eq (window-buffer window) (current-buffer)))
|
||||
;; `rectangle--pos-cols' looks up the `selected-window's parameter!
|
||||
(with-selected-window window
|
||||
(apply-on-rectangle
|
||||
(lambda (leftcol rightcol)
|
||||
(let* ((mleft (move-to-column leftcol))
|
||||
(left (point))
|
||||
;; BEWARE: In the presence of other overlays with
|
||||
;; before/after/display-strings, this happens to move to
|
||||
;; the column "as if the overlays were not applied", which
|
||||
;; is sometimes what we want, tho it can be
|
||||
;; considered a bug in move-to-column (it should arguably
|
||||
;; pay attention to the before/after-string/display
|
||||
;; properties when computing the column).
|
||||
(mright (move-to-column rightcol))
|
||||
(right (point))
|
||||
(ol
|
||||
(if (not old)
|
||||
(let ((ol (make-overlay left right)))
|
||||
(overlay-put ol 'window window)
|
||||
(overlay-put ol 'face 'region)
|
||||
ol)
|
||||
(let ((ol (pop old)))
|
||||
(move-overlay ol left right (current-buffer))
|
||||
ol))))
|
||||
;; `move-to-column' may stop before the column (if bumping into
|
||||
;; EOL) or overshoot it a little, when column is in the middle
|
||||
;; of a char.
|
||||
(cond
|
||||
((< mleft leftcol) ;`leftcol' is past EOL.
|
||||
(overlay-put ol 'before-string (rectangle--space-to leftcol))
|
||||
(setq mright (max mright leftcol)))
|
||||
((and (> mleft leftcol) ;`leftcol' is in the middle of a char.
|
||||
(eq (char-before left) ?\t))
|
||||
(setq left (1- left))
|
||||
(move-overlay ol left right)
|
||||
(goto-char left)
|
||||
(overlay-put ol 'before-string (rectangle--space-to leftcol)))
|
||||
((overlay-get ol 'before-string)
|
||||
(overlay-put ol 'before-string nil)))
|
||||
(cond
|
||||
;; While doing rectangle--string-preview, the two sets of
|
||||
;; overlays steps on the other's toes. I fixed some of the
|
||||
;; problems, but others remain. The main one is the two
|
||||
;; (rectangle--space-to rightcol) below which try to virtually
|
||||
;; insert missing text, but during "preview", the text is not
|
||||
;; missing (it's provided by preview's own overlay).
|
||||
(rectangle--string-preview-state
|
||||
(if (overlay-get ol 'after-string)
|
||||
(overlay-put ol 'after-string nil)))
|
||||
((< mright rightcol) ;`rightcol' is past EOL.
|
||||
(let ((str (rectangle--space-to rightcol)))
|
||||
(put-text-property 0 (length str) 'face 'region str)
|
||||
;; If cursor happens to be here, draw it at the right place.
|
||||
(rectangle--place-cursor leftcol left str)
|
||||
(overlay-put ol 'after-string str)))
|
||||
((and (> mright rightcol) ;`rightcol's in the middle of a char.
|
||||
(eq (char-before right) ?\t))
|
||||
(setq right (1- right))
|
||||
(move-overlay ol left right)
|
||||
(if (= rightcol leftcol)
|
||||
(overlay-put ol 'after-string nil)
|
||||
(goto-char right)
|
||||
(let ((str (rectangle--space-to rightcol)))
|
||||
(put-text-property 0 (length str) 'face 'region str)
|
||||
(when (= left right)
|
||||
(rectangle--place-cursor leftcol left str))
|
||||
(overlay-put ol 'after-string str))))
|
||||
((overlay-get ol 'after-string)
|
||||
(overlay-put ol 'after-string nil)))
|
||||
(when (and (= leftcol rightcol) (display-graphic-p))
|
||||
;; Make zero-width rectangles visible!
|
||||
(overlay-put ol 'after-string
|
||||
(concat (propertize " "
|
||||
'face '(region (:height 0.2)))
|
||||
(overlay-get ol 'after-string))))
|
||||
(push ol nrol)))
|
||||
start end))
|
||||
(let* ((cols (rectangle--pos-cols start end))
|
||||
(startcol (car cols))
|
||||
(endcol (cdr cols))
|
||||
(leftcol (min startcol endcol))
|
||||
(rightcol (max startcol endcol))
|
||||
;; We don't know what lines will actually be displayed,
|
||||
;; so add highlight overlays on lines within the window
|
||||
;; height from point.
|
||||
(height (window-height))
|
||||
(start-pt (max start (progn (forward-line (- height))
|
||||
(point))))
|
||||
(end-pt (min end (progn (goto-char pt)
|
||||
(forward-line height)
|
||||
(point)))))
|
||||
(goto-char start-pt)
|
||||
(beginning-of-line)
|
||||
(while
|
||||
(let* ((mleft (move-to-column leftcol))
|
||||
(left (point))
|
||||
;; BEWARE: In the presence of other overlays with
|
||||
;; before/after/display-strings, this happens to move to
|
||||
;; the column "as if the overlays were not applied",
|
||||
;; which is sometimes what we want, tho it can be
|
||||
;; considered a bug in move-to-column (it should
|
||||
;; arguably pay attention to the
|
||||
;; before/after-string/display properties when computing
|
||||
;; the column).
|
||||
(mright (move-to-column rightcol))
|
||||
(right (point))
|
||||
(ol
|
||||
(if (not old)
|
||||
(let ((ol (make-overlay left right)))
|
||||
(overlay-put ol 'window window)
|
||||
(overlay-put ol 'face 'region)
|
||||
ol)
|
||||
(let ((ol (pop old)))
|
||||
(move-overlay ol left right (current-buffer))
|
||||
ol))))
|
||||
;; `move-to-column' may stop before the column (if bumping
|
||||
;; into EOL) or overshoot it a little, when column is in the
|
||||
;; middle of a char.
|
||||
(cond
|
||||
((< mleft leftcol) ;`leftcol' is past EOL.
|
||||
(overlay-put ol 'before-string
|
||||
(rectangle--space-to leftcol))
|
||||
(setq mright (max mright leftcol)))
|
||||
((and (> mleft leftcol) ;`leftcol' is in the middle of a char
|
||||
(eq (char-before left) ?\t))
|
||||
(setq left (1- left))
|
||||
(move-overlay ol left right)
|
||||
(goto-char left)
|
||||
(overlay-put ol 'before-string
|
||||
(rectangle--space-to leftcol)))
|
||||
((overlay-get ol 'before-string)
|
||||
(overlay-put ol 'before-string nil)))
|
||||
(cond
|
||||
;; While doing rectangle--string-preview, the two sets of
|
||||
;; overlays steps on the other's toes. I fixed some of the
|
||||
;; problems, but others remain. The main one is the two
|
||||
;; (rectangle--space-to rightcol) below which try to
|
||||
;; virtually insert missing text, but during "preview", the
|
||||
;; text is not missing (it's provided by preview's own
|
||||
;; overlay).
|
||||
(rectangle--string-preview-state
|
||||
(if (overlay-get ol 'after-string)
|
||||
(overlay-put ol 'after-string nil)))
|
||||
((< mright rightcol) ;`rightcol' is past EOL.
|
||||
(let ((str (rectangle--space-to rightcol)))
|
||||
(put-text-property 0 (length str) 'face 'region str)
|
||||
;; If cursor happens to be here, draw it at the right
|
||||
;; place.
|
||||
(rectangle--place-cursor leftcol left str)
|
||||
(overlay-put ol 'after-string str)))
|
||||
((and (> mright rightcol) ;`rightcol' in the middle of a char
|
||||
(eq (char-before right) ?\t))
|
||||
(setq right (1- right))
|
||||
(move-overlay ol left right)
|
||||
(if (= rightcol leftcol)
|
||||
(overlay-put ol 'after-string nil)
|
||||
(goto-char right)
|
||||
(let ((str (rectangle--space-to rightcol)))
|
||||
(put-text-property 0 (length str) 'face 'region str)
|
||||
(when (= left right)
|
||||
(rectangle--place-cursor leftcol left str))
|
||||
(overlay-put ol 'after-string str))))
|
||||
((overlay-get ol 'after-string)
|
||||
(overlay-put ol 'after-string nil)))
|
||||
(when (and (= leftcol rightcol) (display-graphic-p))
|
||||
;; Make zero-width rectangles visible!
|
||||
(overlay-put ol 'after-string
|
||||
(concat (propertize
|
||||
" " 'face '(region (:height 0.2)))
|
||||
(overlay-get ol 'after-string))))
|
||||
(push ol nrol)
|
||||
(and (zerop (forward-line 1))
|
||||
(bolp)
|
||||
(<= (point) end-pt))))
|
||||
)
|
||||
)
|
||||
(mapc #'delete-overlay old)
|
||||
`(rectangle ,(buffer-chars-modified-tick)
|
||||
,start ,end ,(rectangle--crutches)
|
||||
,start ,end ,(rectangle--crutches) ,pt
|
||||
,@nrol))))))
|
||||
|
||||
(defun rectangle--unhighlight-for-redisplay (orig rol)
|
||||
(if (not (eq 'rectangle (car-safe rol)))
|
||||
(funcall orig rol)
|
||||
(mapc #'delete-overlay (nthcdr 5 rol))
|
||||
(mapc #'delete-overlay (nthcdr 6 rol))
|
||||
(setcar (cdr rol) nil)))
|
||||
|
||||
(defun rectangle--duplicate-right (n displacement)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user