From fd7bde612ab7a027651ffa29cb390aeb67679d8b Mon Sep 17 00:00:00 2001 From: Jimmy Aguilar Mena Date: Sun, 13 Mar 2022 19:26:23 +0100 Subject: [PATCH] Add new special text attribute cursor-face Reuse the functions for highlight region. * lisp/simple.el (redisplay-unhighlight-overlay-function) : (redisplay-highlight-overlay-function) : New functions from previous lambda (redisplay-unhighlight-region-function) : (redisplay-highlight-region-function) : Redefined with the new functions. (redisplay--update-cursor-property-highlight) : New function for pre-redisplay-functions. --- doc/lispref/text.texi | 5 +++ etc/NEWS | 5 +++ lisp/simple.el | 79 +++++++++++++++++++++++++++++-------------- 3 files changed, 63 insertions(+), 26 deletions(-) diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 7897adeb053..a27d6f88c2a 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3551,6 +3551,11 @@ that alter the text size (e.g., @code{:height}, @code{:weight}, and @code{:slant}). Those attributes are always the same as for the unhighlighted text. +@item cursor-face +@kindex cursor-face @r{(text property)} +This property is similar to @code{mouse-face} but is used when the +cursor is on or near the character. + @item fontified @kindex fontified @r{(text property)} This property says whether the text is ready for display. If diff --git a/etc/NEWS b/etc/NEWS index c374a5b999f..22ba84f084b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1260,6 +1260,11 @@ property. ** New 'min-width' 'display' property. This allows setting a minimum display width for a region of text. ++++ +** New 'cursor-face 'text' property. +This uses cursor-face instead of the default face when cursor is on or +near the character. + +++ ** New event type 'touch-end'. This event is sent whenever the user's finger moves off the mouse diff --git a/lisp/simple.el b/lisp/simple.el index accc119e2b3..cc356addb97 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6482,27 +6482,35 @@ An example is a rectangular region handled as a list of separate contiguous regions for each line." (cdr (region-bounds))) -(defvar redisplay-unhighlight-region-function - (lambda (rol) (when (overlayp rol) (delete-overlay rol)))) - -(defvar redisplay-highlight-region-function - (lambda (start end window rol) - (if (not (overlayp rol)) - (let ((nrol (make-overlay start end))) - (funcall redisplay-unhighlight-region-function rol) - (overlay-put nrol 'window window) - (overlay-put nrol 'face 'region) - ;; Normal priority so that a large region doesn't hide all the - ;; overlays within it, but high secondary priority so that if it - ;; ends/starts in the middle of a small overlay, that small overlay - ;; won't hide the region's boundaries. - (overlay-put nrol 'priority '(nil . 100)) - nrol) - (unless (and (eq (overlay-buffer rol) (current-buffer)) - (eq (overlay-start rol) start) - (eq (overlay-end rol) end)) - (move-overlay rol start end (current-buffer))) - rol)) +(defun redisplay-unhighlight-overlay-function (rol) + "If ROL is an overlay, call ``delete-overlay''." + (when (overlayp rol) (delete-overlay rol))) + +(defvar redisplay-unhighlight-region-function #'redisplay-unhighlight-overlay-function + "Function to remove the region-highlight overlay.") + +(defun redisplay-highlight-overlay-function (start end window rol face) + "Update the overlay ROL in WINDOW with FACE in range START-END." + (if (not (overlayp rol)) + (let ((nrol (make-overlay start end))) + (funcall redisplay-unhighlight-region-function rol) + (overlay-put nrol 'window window) + (overlay-put nrol 'face face) + ;; Normal priority so that a large region doesn't hide all the + ;; overlays within it, but high secondary priority so that if it + ;; ends/starts in the middle of a small overlay, that small overlay + ;; won't hide the region's boundaries. + (overlay-put nrol 'priority '(nil . 100)) + nrol) + (unless (eq (overlay-get rol 'face) face) + (overlay-put rol 'face face)) + (unless (and (eq (overlay-buffer rol) (current-buffer)) + (eq (overlay-start rol) start) + (eq (overlay-end rol) end)) + (move-overlay rol start end (current-buffer))) + rol)) + +(defvar redisplay-highlight-region-function #'redisplay-highlight-overlay-function "Function to move the region-highlight overlay. This function is called with four parameters, START, END, WINDOW and OVERLAY. If OVERLAY is nil, a new overlay is created. In @@ -6525,12 +6533,31 @@ The overlay is returned by the function.") (end (max pt mark)) (new (funcall redisplay-highlight-region-function - start end window rol))) + start end window rol 'region))) (unless (equal new rol) - (set-window-parameter window 'internal-region-overlay - new)))))) - -(defvar pre-redisplay-functions (list #'redisplay--update-region-highlight) + (set-window-parameter window 'internal-region-overlay new)))))) + +(defun redisplay--update-cursor-property-highlight (window) + "This highlights the overlay used to highlight text with cursor-face." + (let ((rol (window-parameter window 'internal-cursor-face-overlay)) + (pt) (value) (cursor-face)) + (if (and (or (eq window (selected-window)) + (and (window-minibuffer-p) + (eq window (minibuffer-selected-window)))) + (setq pt (window-point window)) + (setq value (get-text-property pt 'cursor-face)) + ;; extra code needed here for when passing plists + (setq cursor-face (if (facep value) value))) + (let* ((start (previous-single-property-change (1+ pt) 'cursor-face nil (point-min))) + (end (next-single-property-change pt 'cursor-face nil (point-max))) + (new (redisplay-highlight-overlay-function start end window rol cursor-face))) + (unless (equal new rol) + (set-window-parameter window 'internal-cursor-face-overlay new))) + (if rol + (redisplay-unhighlight-overlay-function rol))))) + +(defvar pre-redisplay-functions (list #'redisplay--update-cursor-property-highlight + #'redisplay--update-region-highlight) "Hook run just before redisplay. It is called in each window that is to be redisplayed. It takes one argument, which is the window that will be redisplayed. When run, the `current-buffer' -- 2.39.2