;;; Detect cursor movement.
(defun cursor-sensor--detect (&optional window)
- (with-current-buffer (window-buffer window)
- (unless cursor-sensor-inhibit
- (let* ((point (window-point window))
- ;; It's often desirable to make the
- ;; cursor-sensor-functions property non-sticky on both
- ;; ends, but that means get-pos-property might never
- ;; see it.
- (new (or (get-char-property point 'cursor-sensor-functions)
- (unless (<= (point-min) point)
- (get-char-property (1- point)
- 'cursor-sensor-functions))))
- (old (window-parameter window 'cursor-sensor--last-state))
- (oldposmark (car old))
- (oldpos (or (if oldposmark (marker-position oldposmark))
- (point-min)))
- (start (min oldpos point))
- (end (max oldpos point)))
- (unless (or (null old) (eq (marker-buffer oldposmark) (current-buffer)))
- ;; `window' does not display the same buffer any more!
- (setcdr old nil))
- (if (or (and (null new) (null (cdr old)))
- (and (eq new (cdr old))
- (eq (next-single-char-property-change
- start 'cursor-sensor-functions nil end)
- end)))
- ;; Clearly nothing to do.
- nil
- ;; Maybe something to do. Let's see exactly what needs to run.
- (let* ((missing-p
- (lambda (f)
- "Non-nil if F is missing somewhere between START and END."
- (let ((pos start)
- (missing nil))
- (while (< pos end)
- (setq pos (next-single-char-property-change
- pos 'cursor-sensor-functions
- nil end))
- (unless (memq f (get-char-property
- pos 'cursor-sensor-functions))
- (setq missing t)))
- missing)))
- (window (selected-window)))
- (dolist (f (cdr old))
- (unless (and (memq f new) (not (funcall missing-p f)))
- (funcall f window oldpos 'left)))
- (dolist (f new)
- (unless (and (memq f (cdr old)) (not (funcall missing-p f)))
- (funcall f window oldpos 'entered)))))
-
- ;; Remember current state for next time.
- ;; Re-read cursor-sensor-functions since the functions may have moved
- ;; window-point!
- (if old
- (progn (move-marker (car old) point)
- (setcdr old new))
- (set-window-parameter window 'cursor-sensor--last-state
- (cons (copy-marker point) new)))))))
+ ;; We're run from `pre-redisplay-functions' and `post-command-hook'
+ ;; where we can't handle errors very well, so just demote them to make
+ ;; sure they don't get in the way.
+ (with-demoted-errors "cursor-sensor--detect: %S"
+ (with-current-buffer (window-buffer window)
+ (unless cursor-sensor-inhibit
+ (let* ((point (window-point window))
+ ;; It's often desirable to make the
+ ;; cursor-sensor-functions property non-sticky on both
+ ;; ends, so we can't use `get-pos-property' because it
+ ;; might never see it.
+ ;; FIXME: Combine properties from covering overlays?
+ (new (or (get-char-property point 'cursor-sensor-functions)
+ (unless (<= (point-min) point)
+ (get-char-property (1- point)
+ 'cursor-sensor-functions))))
+ (old (window-parameter window 'cursor-sensor--last-state))
+ (oldposmark (car old))
+ (oldpos (or (if oldposmark (marker-position oldposmark))
+ (point-min)))
+ (start (min oldpos point))
+ (end (max oldpos point)))
+ (unless (or (null old)
+ (eq (marker-buffer oldposmark) (current-buffer)))
+ ;; `window' does not display the same buffer any more!
+ (setcdr old nil))
+ (if (and (null new) (null (cdr old)))
+ ;; Clearly nothing to do.
+ nil
+ ;; Maybe something to do. Let's see exactly what needs to run.
+ (let* ((missing-p
+ (lambda (f)
+ "Non-nil if F is missing somewhere between START and END."
+ (let ((pos start)
+ (missing nil))
+ (while (< pos end)
+ (setq pos (next-single-char-property-change
+ pos 'cursor-sensor-functions
+ nil end))
+ (unless (memq f (get-char-property
+ pos 'cursor-sensor-functions))
+ (setq missing t)))
+ missing)))
+ (window (selected-window)))
+ (dolist (f (cdr old))
+ (unless (and (memq f new) (not (funcall missing-p f)))
+ (funcall f window oldpos 'left)))
+ (dolist (f new)
+ (let ((op (cond
+ ((or (not (memq f (cdr old))) (funcall missing-p f))
+ 'entered)
+ ((not (= start end)) 'moved))))
+ (when op
+ (funcall f window oldpos op))))))
+
+ ;; Remember current state for next time.
+ ;; Re-read cursor-sensor-functions since the functions may have moved
+ ;; window-point!
+ (if old
+ (progn (move-marker (car old) point)
+ (setcdr old new))
+ (set-window-parameter window 'cursor-sensor--last-state
+ (cons (copy-marker point) new))))))))
;;;###autoload
(define-minor-mode cursor-sensor-mode
This property should hold a list of functions which react to the motion
of the cursor. They're called with three arguments (WINDOW OLDPOS DIR)
where WINDOW is the affected window, OLDPOS is the last known position of
-the cursor and DIR can be `entered' or `left' depending on whether the cursor
-is entering the area covered by the text-property property or leaving it."
+the cursor and DIR can be `entered', `left', or `moved' depending on whether
+the cursor is entering the area covered by the text-property property,
+leaving it, or just moving inside of it."
:global nil
(cond
(cursor-sensor-mode
;; (list match-num1 match-num2 startline))
(overlay-put ol 'evaporate t)
(dolist (x props)
- (when (or (> end beg)
- ;; Don't highlight the char we cover artificially.
- (not (memq (car-safe x) '(face font-lock-face))))
- (overlay-put ol (car x) (cdr x))))
+ (if (or (> end beg)
+ (not (memq (car-safe x) '(face font-lock-face))))
+ (overlay-put ol (car x) (cdr x))
+ ;; Don't highlight the char we cover artificially.
+ (overlay-put ol (if (= beg olbeg) 'before-string 'after-string)
+ (propertize
+ " " (car-safe x) (cdr-safe x)
+ 'display '(space :width 0.5)))))
ol)))))
+(defcustom smerge-refine-shadow-cursor t
+ "If non-nil, display a shadow cursor on the other side of smerge refined regions.
+Its appearance is controlled by the face `smerge-refine-shadow-cursor'."
+ :type 'boolean
+ :version "31.1")
+
+(defface smerge-refine-shadow-cursor
+ '((t :box (:line-width (-2 . -2))))
+ "Face placed on a character to highlight it as the shadow cursor.
+The presence of the shadow cursor depends on the
+variable `smerge-refine-shadow-cursor'.")
+
;;;###autoload
(defun smerge-refine-regions (beg1 end1 beg2 end2 props-c &optional preproc props-r props-a)
"Show fine differences in the two regions BEG1..END1 and BEG2..END2.
(ol2 (make-overlay beg2 end2 nil
;; Make it shrink rather than spread when editing.
'front-advance nil))
- (common-props '((evaporate . t) (smerge--refine-region . t))))
+ (common-props '((evaporate . t) (smerge--refine-region . t)
+ (cursor-sensor-functions
+ smerge--refine-shadow-cursor))))
+ (when smerge-refine-shadow-cursor
+ (cursor-sensor-mode 1))
(dolist (prop (or props-a props-c))
(when (and (not (memq (car prop) '(face font-lock-face)))
(member prop (or props-r props-c))
(define-obsolete-function-alias 'smerge-refine-subst
#'smerge-refine-regions "26.1")
+(defun smerge--refine-at-right-margin-p (pos window)
+ ;; FIXME: `posn-at-point' seems to be costly/slow.
+ (when-let* ((posn (posn-at-point pos window))
+ (xy (nth 2 posn))
+ (x (car-safe xy))
+ (_ (numberp x)))
+ (> (+ x (with-selected-window window (string-pixel-width " ")))
+ (car (window-text-pixel-size window)))))
+
+(defun smerge--refine-shadow-cursor (window _oldpos dir)
+ (let ((ol (window-parameter window 'smerge--refine-shadow-cursor)))
+ (if (not (and smerge-refine-shadow-cursor
+ (memq dir '(entered moved))))
+ (if ol (delete-overlay ol))
+ (with-current-buffer (window-buffer window)
+ (let* ((cursor (window-point window))
+ (other-beg (ignore-errors (smerge--refine-other-pos cursor))))
+ (if (not other-beg)
+ (if ol (delete-overlay ol))
+ (let ((other-end (min (point-max) (1+ other-beg))))
+ ;; If other-beg/end covers a "wide" char like TAB or LF, the
+ ;; resulting shadow cursor doesn't look like a cursor, so try
+ ;; and convert it to a before-string space.
+ (when (or (and (eq ?\n (char-after other-beg))
+ (not (smerge--refine-at-right-margin-p
+ other-beg window)))
+ (and (eq ?\t (char-after other-beg))
+ ;; FIXME: `posn-at-point' seems to be costly/slow.
+ (when-let* ((posn (posn-at-point other-beg window))
+ (xy (nth 2 posn))
+ (x (car-safe xy))
+ (_ (numberp x)))
+ (< (1+ (% x tab-width)) tab-width))))
+ (setq other-end other-beg))
+ ;; FIXME: Doesn't obey `cursor-in-non-selected-windows'.
+ (if ol (move-overlay ol other-beg other-end)
+ (setq ol (make-overlay other-beg other-end nil t nil))
+ (setf (window-parameter window 'smerge--refine-shadow-cursor)
+ ol)
+ (overlay-put ol 'window window)
+ (overlay-put ol 'face 'smerge-refine-shadow-cursor))
+ ;; When the shadow cursor needs to be at EOB (or TAB or EOL),
+ ;; "draw" it as a pseudo space character.
+ (overlay-put ol 'before-string
+ (when (= other-beg other-end)
+ (eval-when-compile
+ (propertize
+ " " 'face 'smerge-refine-shadow-cursor)))))))))))
+
(defun smerge-refine (&optional part)
"Highlight the words of the conflict that are different.
For 3-way conflicts, highlights only two of the three parts.
(unless smerge-use-changed-face
'((smerge . refine) (font-lock-face . smerge-refined-added))))))
-(defun smerge-refine-exchange-point ()
- "Go to the matching position in the other chunk."
- (interactive)
+(defun smerge--refine-other-pos (pos)
(let* ((covering-ol
- (let ((ols (overlays-at (point))))
+ (let ((ols (overlays-at pos)))
(while (and ols (not (overlay-get (car ols)
'smerge--refine-region)))
(pop ols))
(or (car ols)
(user-error "Not inside a refined region"))))
(ref-pos
- (if (or (get-char-property (point) 'smerge--refine-other)
- (get-char-property (1- (point)) 'smerge--refine-other))
- (point)
+ (if (or (get-char-property pos 'smerge--refine-other)
+ (get-char-property (1- pos) 'smerge--refine-other))
+ pos
(let ((next (next-single-char-property-change
- (point) 'smerge--refine-other nil
+ pos 'smerge--refine-other nil
(overlay-end covering-ol)))
(prev (previous-single-char-property-change
- (point) 'smerge--refine-other nil
+ pos 'smerge--refine-other nil
(overlay-start covering-ol))))
(cond
((and (> prev (overlay-start covering-ol))
(or (>= next (overlay-end covering-ol))
- (> (- next (point)) (- (point) prev))))
+ (> (- next pos) (- pos prev))))
prev)
((< next (overlay-end covering-ol)) next)
(t (user-error "No \"other\" position info found"))))))
(boundary
(cond
- ((< ref-pos (point))
+ ((< ref-pos pos)
(let ((adjust (get-char-property (1- ref-pos)
'smerge--refine-adjust)))
- (min (point) (+ ref-pos (or (cdr adjust) 0)))))
- ((> ref-pos (point))
+ (min pos (+ ref-pos (or (cdr adjust) 0)))))
+ ((> ref-pos pos)
(let ((adjust (get-char-property ref-pos 'smerge--refine-adjust)))
- (max (point) (- ref-pos (or (car adjust) 0)))))
+ (max pos (- ref-pos (or (car adjust) 0)))))
(t ref-pos)))
(other-forw (get-char-property ref-pos 'smerge--refine-other))
(other-back (get-char-property (1- ref-pos) 'smerge--refine-other))
(other (or other-forw other-back))
- (dist (- boundary (point))))
+ (dist (- boundary pos)))
(if (not (overlay-start other))
(user-error "The \"other\" position has vanished")
- (goto-char
- (- (if other-forw
- (- (overlay-start other)
- (or (car (overlay-get other 'smerge--refine-adjust)) 0))
- (+ (overlay-end other)
- (or (cdr (overlay-get other 'smerge--refine-adjust)) 0)))
- dist)))))
+ (- (if other-forw
+ (- (overlay-start other)
+ (or (car (overlay-get other 'smerge--refine-adjust)) 0))
+ (+ (overlay-end other)
+ (or (cdr (overlay-get other 'smerge--refine-adjust)) 0)))
+ dist))))
+
+(defun smerge-refine-exchange-point ()
+ "Go to the matching position in the other chunk."
+ (interactive)
+ (goto-char (smerge--refine-other-pos (point))))
(defun smerge-swap ()
;; FIXME: Extend for diff3 to allow swapping the middle end as well.
projects / emacs.git / commitdiff