From 9310f8be68550ad98ad70af0254980049bfcf0ca Mon Sep 17 00:00:00 2001 From: Tomaneo Date: Sun, 11 May 2025 20:36:21 +0300 Subject: [PATCH 1/2] Unify emacs mode mark and vi visual mode. Use buffer mark instead of internal veriable to handle visual mode start point tracking. Any core function which sets buffer mark can thus enable visual mode which means that also selecting area with mouse is compatible with vi mode. Make vi states to be buffer specific, not global. This fixes several minor glitches and annoyances when switching between windows and buffers --- extensions/vi-mode/commands.lisp | 34 +-- extensions/vi-mode/commands/utils.lisp | 48 ++-- extensions/vi-mode/core.lisp | 47 ++-- extensions/vi-mode/states.lisp | 47 +++- extensions/vi-mode/tests/kbdmacro.lisp | 2 +- extensions/vi-mode/tests/utils.lisp | 69 +++--- extensions/vi-mode/vi-mode.lisp | 11 +- extensions/vi-mode/visual.lisp | 308 +++++++++++++------------ src/buffer/internal/basic.lisp | 2 +- src/buffer/internal/buffer.lisp | 15 +- src/buffer/package.lisp | 2 + src/display/logical-line.lisp | 12 +- src/internal-packages.lisp | 3 + 13 files changed, 333 insertions(+), 267 deletions(-) diff --git a/extensions/vi-mode/commands.lisp b/extensions/vi-mode/commands.lisp index 64b498510..a0bee8dd1 100644 --- a/extensions/vi-mode/commands.lisp +++ b/extensions/vi-mode/commands.lisp @@ -380,7 +380,7 @@ Move the cursor to the first non-blank character of the line." (define-operator vi-substitute (beg end type) ("") (:motion vi-forward-char) (vi-delete beg end type) - (change-state 'insert)) + (setf (buffer-state) 'insert)) (define-operator vi-delete-next-char (beg end type) ("") (:motion vi-forward-char) @@ -447,7 +447,7 @@ Move the cursor to the first non-blank character of the line." (kill-region-without-appending start end))) (define-operator vi-change (beg end type) ("") - () + (:move-point nil) (when (point= beg end) (return-from vi-change)) (let ((end-with-newline (char= (character-at end -1) #\Newline))) @@ -464,7 +464,7 @@ Move the cursor to the first non-blank character of the line." (t (unless (eql (character-at (current-point)) #\Space) (skip-whitespace-backward end)) (vi-delete beg end type)))) - (change-state 'insert)) + (setf (buffer-state) 'insert)) (define-operator vi-change-whole-line (beg end) ("") (:motion vi-line) @@ -476,7 +476,7 @@ Move the cursor to the first non-blank character of the line." (define-operator vi-change-line (beg end type) ("") (:motion vi-move-to-end-of-line) (vi-change beg end type) - (change-state 'insert)) + (setf (buffer-state) 'insert)) (define-operator vi-join (start end) ("") (:motion vi-line) @@ -489,7 +489,8 @@ Move the cursor to the first non-blank character of the line." (delete-next-char)))) (define-operator vi-join-line (start end type) ("") - (:motion vi-line) + (:move-point nil + :motion vi-line) (when (and (eq type :line) (point/= start end) (zerop (point-charpos end))) @@ -622,10 +623,11 @@ Move the cursor to the first non-blank character of the line." "~v@{~C~:*~}~*~@[~%~]" (length string) char - (not lastp))))))) + (not lastp)))))) + (to-start (visual-p))) (delete-between-points start end) (insert-string start string-to-replace) - (if (visual-p) + (if to-start (move-point (current-point) start) (character-offset (current-point) *cursor-offset*))))) @@ -999,38 +1001,38 @@ on the same line or at eol if there are none." (delete-active-window)))) (define-command vi-end-insert () () - (change-state 'normal) + (setf (buffer-state) 'normal) (vi-backward-char 1)) (define-command vi-insert () () - (change-state 'insert)) + (setf (buffer-state) 'insert)) (define-command vi-insert-line () () (vi-move-to-beginning-of-line) (skip-whitespace-forward (current-point) t) - (change-state 'insert)) + (setf (buffer-state) 'insert)) (define-command vi-append () () (let ((p (current-point))) (unless (or (end-line-p p) (end-buffer-p p)) (forward-char 1)) - (change-state 'insert))) + (setf (buffer-state) 'insert))) (define-command vi-append-line () () (line-end (current-point)) - (change-state 'insert)) + (setf (buffer-state) 'insert)) (define-command vi-open-below () () (let ((p (current-point))) (line-end p) - (change-state 'insert) + (setf (buffer-state) 'insert) (insert-character p #\Newline) (indent-line (current-point)))) (define-command vi-open-above () () (line-start (current-point)) - (change-state 'insert) + (setf (buffer-state) 'insert) (open-line 1) (let ((column (with-point ((p (current-point))) (point-column (or (and (line-offset p 1) @@ -1069,7 +1071,7 @@ on the same line or at eol if there are none." (lem/universal-argument::*argument* (lem/universal-argument::make-arg-state))) (execute-key-sequence keyseq) (unless (state= prev-state (current-state)) - (change-state prev-state)))))) + (setf (buffer-state) prev-state)))))) (define-text-object-command vi-a-word (count) ("p") (:expand-selection t) @@ -1112,7 +1114,7 @@ on the same line or at eol if there are none." (inner-range-of 'paragraph-object (current-state) count)) (define-command vi-normal () () - (change-state 'normal)) + (setf (buffer-state) 'normal)) (define-command vi-keyboard-quit () () (when (eq (current-state) 'modeline) diff --git a/extensions/vi-mode/commands/utils.lisp b/extensions/vi-mode/commands/utils.lisp index 80d9f7843..74bdcd81d 100644 --- a/extensions/vi-mode/commands/utils.lisp +++ b/extensions/vi-mode/commands/utils.lisp @@ -94,9 +94,9 @@ (values () ())) ((eq (first arg-list) '&optional) (values - arg-list - '("p") - (second (ensure-list (second arg-list))))) + arg-list + '("p") + (second (ensure-list (second arg-list))))) (t (values arg-list '("P") nil)))) (defmacro define-motion (name arg-list arg-descriptors (&key type jump (repeat :motion) (default-n-arg 1)) &body body) @@ -117,7 +117,7 @@ (n (or n (typecase command (vi-motion - (vi-motion-default-n-arg command)) + (vi-motion-default-n-arg command)) (otherwise 1)))) (lem-core::*universal-argument* n)) (execute (lem-core::get-active-modes-class-instance (current-buffer)) @@ -178,7 +178,7 @@ ((visual-block-p) :block) (t :exclusive)))))) -(defun operator-region (motion &key move-point with-type) +(defun operator-region (motion &key with-type) (multiple-value-bind (start end type) (multiple-value-bind (start end type) (if (visual-p) @@ -200,16 +200,7 @@ (multiple-value-prog1 (if with-type (values start end type) - (values start end)) - (when move-point - (if (eq type :block) - (with-point ((p (current-point))) - (move-to-line p (min (line-number-at-point start) - (line-number-at-point end))) - (move-to-column p (min (point-column start) - (point-column end))) - (move-point (current-point) p)) - (move-point (current-point) start)))))) + (values start end))))) (defun call-define-operator (fn &key keep-visual restore-point) (with-point ((*vi-origin-point* (current-point))) @@ -221,16 +212,16 @@ (when (visual-p) (vi-visual-end))))))) -(defun parse-arg-descriptors (arg-descriptors &key motion move-point) +(defun parse-arg-descriptors (arg-descriptors &key motion) `(values-list (append ,@(mapcar (lambda (arg-descriptor) (if (stringp arg-descriptor) (cond ((string= arg-descriptor "") - `(multiple-value-list (operator-region ',motion :move-point ,move-point))) + `(multiple-value-list (operator-region ',motion))) ((string= arg-descriptor "") - `(multiple-value-list (operator-region ',motion :move-point ,move-point :with-type t))) + `(multiple-value-list (operator-region ',motion :with-type t))) ((string= arg-descriptor "") '(multiple-value-list (visual-region))) ((string= arg-descriptor "p") @@ -240,15 +231,28 @@ `(multiple-value-list ,arg-descriptor))) arg-descriptors)))) +(defun move-point-to-start (start end mode) + (if (eq mode :block) + (with-point ((p (current-point))) + (move-to-line p (min (line-number-at-point start) + (line-number-at-point end))) + (move-to-column p (min (point-column start) + (point-column end))) + (move-point (current-point) p)) + (move-point (current-point) start))) + + (defmacro define-operator (name arg-list arg-descriptors (&key motion keep-visual (move-point t) (repeat t) restore-point) &body body) `(define-command (,name (:advice-classes vi-operator) (:initargs :repeat ,repeat)) ,arg-list - (,(parse-arg-descriptors arg-descriptors :motion motion :move-point move-point)) - (call-define-operator (lambda () ,@body) - :keep-visual ,keep-visual - :restore-point ,restore-point))) + (,(parse-arg-descriptors arg-descriptors :motion motion)) + (call-define-operator (lambda () ,@body + (when ,move-point + (move-point-to-start ,(first arg-list) ,(second arg-list) ,(third arg-list)))) + :keep-visual ,keep-visual + :restore-point ,restore-point))) (defun call-define-text-object-command (fn &key expand-selection) (flet ((expand-visual-range (range) diff --git a/extensions/vi-mode/core.lisp b/extensions/vi-mode/core.lisp index b8e998943..bb7913232 100644 --- a/extensions/vi-mode/core.lisp +++ b/extensions/vi-mode/core.lisp @@ -15,16 +15,16 @@ :vi-mode :define-state :current-state - :current-main-state :state= - :change-state :with-state :with-temporary-state :mode-specific-keymaps :pre-command-hook :post-command-hook - :state-enabled-hook - :state-disabled-hook + :state-changed-hook + :buffer-state + :buffer-state-enabled-hook + :buffer-state-disabled-hook :vi-this-command-keys :this-motion-command :vi-command @@ -122,16 +122,23 @@ (defgeneric post-command-hook (state) (:method ((state vi-state)))) -(defgeneric state-enabled-hook (state) - (:method ((state vi-state)))) +(defgeneric state-changed-hook (state)) -(defgeneric state-disabled-hook (state)) +(defgeneric buffer-state-enabled-hook (state buffer) + (:method ((state vi-state) buffer))) -(defmethod state-disabled-hook ((state vi-state))) +(defgeneric buffer-state-disabled-hook (state buffer) + (:method ((state vi-state) buffer))) (defun current-state () *current-state*) +(defun (setf current-state) (state-or-name) + (let ((state (ensure-state state-or-name))) + (setf *current-state* state) + (state-changed-hook state) + (update-cursor-styles state))) + (defun current-main-state () "Same as `current-state` except it returns the previous state insinde `with-temporary-state` macro." (or *current-main-state* @@ -166,20 +173,26 @@ (lem-if:update-cursor-shape (lem:implementation) (state-cursor-type state))) -(defun change-state (name) - (and *current-state* - (state-disabled-hook *current-state*)) - (let ((state (ensure-state name))) - (setf *current-state* state) - (state-enabled-hook state) - (update-cursor-styles state))) +(defun buffer-state (&optional (buffer (current-buffer))) + (buffer-value buffer :vi-buffer-state)) + +(defun (setf buffer-state) (state-or-name &optional (buffer (current-buffer))) + (let ((state (ensure-state state-or-name)) + (old-state (buffer-state buffer))) + (when (not (equal state old-state)) + (when old-state + (buffer-state-disabled-hook old-state buffer)) + (buffer-state-enabled-hook state buffer) + (setf (buffer-value buffer :vi-buffer-state) state)) + (when (eq buffer (current-buffer)) + (setf (current-state) state)))) (defmacro with-state (state &body body) (with-gensyms (old-state) `(let ((,old-state (current-state))) - (change-state ,state) + (setf (current-state) ,state) (unwind-protect (progn ,@body) - (change-state ,old-state))))) + (setf (current-state) ,old-state))))) (defmacro with-temporary-state (state &body body) `(let ((*current-main-state* *current-state*) diff --git a/extensions/vi-mode/states.lisp b/extensions/vi-mode/states.lisp index 148ddd43b..a6ec3b1db 100644 --- a/extensions/vi-mode/states.lisp +++ b/extensions/vi-mode/states.lisp @@ -1,12 +1,17 @@ (defpackage :lem-vi-mode/states (:use :cl :lem) + (:import-from :alexandria + :when-let + :when-let*) (:import-from :lem-vi-mode/core :define-state :*enable-hook* :*disable-hook* - :change-state - :state-enabled-hook + :current-state + :buffer-state + :state-changed-hook + :ensure-state :define-keymap) (:import-from :lem-vi-mode/modeline :state-modeline-yellow @@ -28,7 +33,7 @@ :replace-state)) (in-package :lem-vi-mode/states) -(defmethod state-enabled-hook :after (state) +(defmethod state-changed-hook (state) :after (change-element-by-state state)) ;; @@ -102,19 +107,37 @@ ;; ;; Setup hooks -(defun enable-normal-state () - (change-state 'normal)) -(defun enable-vi-modeline-state () - (change-state 'vi-modeline)) +(defun enter-prompt () + (setf (buffer-state) 'vi-modeline)) +(defun exit-prompt () + (when-let* ((cb (window-buffer (current-window))) + (state (buffer-state cb))) + (setf (current-state) state))) + +(defun vi-switch-to-buffer (&optional (buffer (current-buffer))) + (let ((buffer-state (buffer-state buffer))) + (if buffer-state + (setf (current-state) buffer-state) + (let ((n (ensure-state 'normal))) + (setf (buffer-state buffer) n))))) + +(defun vi-switch-to-window (old new) + (declare (ignore old)) + (when-let ((state (buffer-state (window-buffer new)))) + (setf (current-state) state))) (defun vi-enable-hook () - (change-state 'normal) - (add-hook *prompt-activate-hook* 'enable-vi-modeline-state) - (add-hook *prompt-deactivate-hook* 'enable-normal-state)) + (setf (current-state) (or (buffer-state (current-buffer)) (ensure-state 'normal))) + (add-hook *switch-to-buffer-hook* 'vi-switch-to-buffer) + (add-hook *switch-to-window-hook* 'vi-switch-to-window) + (add-hook *prompt-after-activate-hook* 'enter-prompt) + (add-hook *prompt-deactivate-hook* 'exit-prompt)) (defun vi-disable-hook () - (remove-hook *prompt-activate-hook* 'enable-vi-modeline-state) - (remove-hook *prompt-deactivate-hook* 'enable-normal-state)) + (remove-hook *switch-to-buffer-hook* 'vi-switch-to-buffer) + (remove-hook *switch-to-window-hook* 'vi-switch-to-window) + (remove-hook *prompt-after-activate-hook* 'enter-prompt) + (remove-hook *prompt-deactivate-hook* 'exit-prompt)) (add-hook *enable-hook* 'vi-enable-hook) (add-hook *disable-hook* 'vi-disable-hook) diff --git a/extensions/vi-mode/tests/kbdmacro.lisp b/extensions/vi-mode/tests/kbdmacro.lisp index aa6d797b8..bf93e5856 100644 --- a/extensions/vi-mode/tests/kbdmacro.lisp +++ b/extensions/vi-mode/tests/kbdmacro.lisp @@ -62,4 +62,4 @@ (handler-case (cmd "10@a") (end-of-buffer ())) - (ok (buf= #?"set-command\nset-command\nset-command\nset[]"))))) + (ok (buf= #?"set-command\nset-command\nset-command\nse[t]"))))) diff --git a/extensions/vi-mode/tests/utils.lisp b/extensions/vi-mode/tests/utils.lisp index fce59c70f..2d8368e8f 100644 --- a/extensions/vi-mode/tests/utils.lisp +++ b/extensions/vi-mode/tests/utils.lisp @@ -11,6 +11,7 @@ :*input-hook*) (:import-from :lem-vi-mode/core :vi-mode + :buffer-state :current-state :ensure-state) (:import-from :lem-vi-mode/states @@ -20,8 +21,7 @@ :visual-char :visual-line :visual-block - :apply-visual-range - :clear-visual-overlays) + :apply-visual-range) (:import-from :cl-ppcre) (:import-from :alexandria :remove-from-plistf @@ -92,13 +92,15 @@ cursor (nreverse visual-regions)))) -(defun %make-buffer-string (buffer-text buffer-pos) - (check-type buffer-pos (integer 0)) - (let ((state (current-state))) +(defun make-buffer-string (buffer) + (let ((buffer-text (buffer-text buffer)) + (buffer-pos (position-at-point (buffer-point buffer))) + (buffer-state (buffer-state buffer))) + (check-type buffer-pos (integer 0)) (let ((buf-str (apply #'concatenate 'string (subseq buffer-text 0 (1- buffer-pos)) - (case state + (case buffer-state (insert (list "[]" @@ -109,7 +111,7 @@ (list (format nil "[~C]" (aref buffer-text (1- buffer-pos))) (subseq buffer-text buffer-pos)))))))) - (if (lem-vi-mode/visual:visual-p) + (if (lem-vi-mode/visual:visual-p buffer) (let ((read-pos 0)) (concatenate 'string @@ -133,13 +135,11 @@ (setf read-pos (if (< buffer-pos (position-at-point end)) (+ (position-at-point end) 2) - (position-at-point end)))))) + (position-at-point end)))) + buffer)) (subseq buf-str (1- read-pos)))) buf-str)))) -(defun make-buffer-string (buffer) - (%make-buffer-string (buffer-text buffer) - (position-at-point (buffer-point buffer)))) (defun text-backslashed (text) (ppcre:regex-replace-all "[\\n\\r\\t]" text @@ -193,6 +193,7 @@ (remove-from-plistf buffer-args :name :content) (let ((buffer (apply #'make-buffer name buffer-args))) + (setf (buffer-state buffer) (ensure-state 'normal)) (when content (multiple-value-bind (buffer-text position visual-regions) (parse-buffer-string content) @@ -209,15 +210,8 @@ (if (= position top-left-pos) (1- bot-right-pos) top-left-pos)) - (setf lem-vi-mode/visual::*start-point* p)))) - (dolist (region visual-regions) - (destructuring-bind (from . to) region - (with-point ((start point) - (end point)) - (move-to-position start from) - (move-to-position end to) - (push (lem:make-overlay start end 'lem:region) - lem-vi-mode/visual::*visual-overlays*))))))) + (setf (buffer-mark buffer) p) + (setf (current-state) 'visual-char))))))) buffer)) (defmacro with-test-buffer ((var buffer-content @@ -250,30 +244,28 @@ (once-only (state) `(if ,state (let ((lem-vi-mode/core::*current-state* nil)) - (lem-vi-mode/core::change-state (if (keywordp ,state) - (keyword-to-state ,state) - ,state)) + (setf (current-state) (if (keywordp ,state) + (keyword-to-state ,state) + ,state)) ,@body) (progn ,@body)))) (defun call-with-vi-buffer (buffer state fn) (with-current-buffer (buffer) (let ((state (or state - (if lem-vi-mode/visual::*visual-overlays* + (if (lem-vi-mode/visual::visual-p) 'visual-char - (current-state)))) - (voverlay lem-vi-mode/visual::*visual-overlays*) - (start (and lem-vi-mode/visual::*start-point* - (copy-point lem-vi-mode/visual::*start-point*)))) + (buffer-state buffer)))) + (start (and (lem-vi-mode/visual::visual-p buffer) + (buffer-mark buffer)))) (lem-core:change-buffer-mode buffer 'vi-mode) (with-vi-state (state) - (setf lem-vi-mode/visual::*visual-overlays* voverlay - lem-vi-mode/visual::*start-point* start) + (when start + (setf (buffer-state buffer) 'visual-char)) (testing (format nil "[buf] \"~A\"" (text-backslashed (make-buffer-string (current-buffer)))) - (funcall fn)))) - (clear-visual-overlays))) + (funcall fn)))))) (defun ensure-buffer (buffer-or-string &rest buffer-args @@ -287,9 +279,9 @@ (buffer buffer-or-string))) (defmacro with-vi-buffer ((buffer-or-string - &rest buffer-args - &key state - &allow-other-keys) &body body) + &rest buffer-args + &key state + &allow-other-keys) &body body) (remove-from-plistf buffer-args :state) (with-gensyms (buffer) (once-only (buffer-or-string) @@ -327,7 +319,7 @@ (defun state= (expected-state) (eq expected-state - (state-to-keyword (current-state)))) + (state-to-keyword (buffer-state (current-buffer))))) (defun visual= (visual-regions) (let (current-regions) @@ -376,7 +368,6 @@ negative (text-backslashed expected-text) (text-backslashed actual-text)))) - (defmethod form-description ((function (eql 'buf=)) args values &key negative) (declare (ignore args)) (format nil "Expect the buffer~:[~; not~] to be \"~A\"~@[ (actual: \"~A\")~]" @@ -385,14 +376,14 @@ ;; NOTE: For the older versions of Rove that doesn't cache the assertion description (ignore-errors (text-backslashed - (make-buffer-string (current-buffer)))))) + (make-buffer-string (current-buffer)))))) (defmethod form-description ((function (eql 'state=)) args values &key negative) (declare (ignore args)) (format nil "Expect the vi state~:[~; not~] to be ~A~@[ (actual: ~A)~]" negative (first values) - (ignore-errors (state-to-keyword (current-state))))) + (ignore-errors (state-to-keyword (buffer-state (current-buffer)))))) (defun lines (&rest lines) (format nil "~{~A~%~}" lines)) diff --git a/extensions/vi-mode/vi-mode.lisp b/extensions/vi-mode/vi-mode.lisp index 8b2994e4e..9c350323d 100644 --- a/extensions/vi-mode/vi-mode.lisp +++ b/extensions/vi-mode/vi-mode.lisp @@ -51,7 +51,6 @@ :normal :insert :visual - :change-state :option-value :leader-key)) (in-package :lem-vi-mode) @@ -105,13 +104,13 @@ (defmethod post-command-hook :after ((state visual)) (adjust-window-scroll)) -(defmethod state-enabled-hook ((state insert)) +(defmethod buffer-state-enabled-hook ((state insert) buffer) (when *enable-repeat-recording* (setf *last-repeat-keys* nil)) (unless *macro-running-p* - (buffer-undo-boundary) - (buffer-disable-undo-boundary (lem:current-buffer)))) + (buffer-undo-boundary buffer) + (buffer-disable-undo-boundary buffer))) -(defmethod state-disabled-hook ((state insert)) +(defmethod buffer-state-disabled-hook ((state insert) buffer) (unless *macro-running-p* - (buffer-enable-undo-boundary (lem:current-buffer)))) + (buffer-enable-undo-boundary buffer))) diff --git a/extensions/vi-mode/visual.lisp b/extensions/vi-mode/visual.lisp index 4ddbc2842..eafc2e962 100644 --- a/extensions/vi-mode/visual.lisp +++ b/extensions/vi-mode/visual.lisp @@ -3,6 +3,7 @@ :lem :lem-vi-mode/core) (:import-from :lem-vi-mode/core + :buffer-state :ensure-state) (:import-from :lem-vi-mode/states :*motion-keymap* @@ -13,6 +14,7 @@ (:import-from :lem :alive-point-p) (:import-from :alexandria + :when-let :last-elt) (:export :*visual-keymap* :vi-visual-end @@ -32,19 +34,64 @@ :vi-visual-opposite-side)) (in-package :lem-vi-mode/visual) -(defvar *start-point* nil) -(defvar *visual-overlays* '()) - (defvar *visual-keymap* (make-keymap :name '*visual-keymap*)) +(defmethod make-region-overlays-using-global-mode ((global-mode vi-mode) cursor) + (let ((buffer (point-buffer cursor))) + (visual-overlays buffer))) + +(defun visual-overlays (buffer) + (cond + ;; Char mode + ((visual-char-p buffer) + (with-point ((start (buffer-mark buffer)) + (end (buffer-point buffer))) + (when (point< end start) + (rotatef start end)) + (character-offset end 1) + (list (make-overlay start end 'region :temporary t)))) + ;; Line mode + ((visual-line-p buffer) + (let ((overlays '())) + (apply-region-lines (buffer-mark buffer) (buffer-point buffer) + (lambda (p) + (push (make-line-overlay p 'region :temporary t) + overlays))) + overlays)) + ;; Block mode + ((visual-block-p buffer) + (let ((overlays '())) + (with-point ((start (buffer-mark buffer)) + (end (buffer-point buffer))) + (let ((start-column (point-column start)) + (end-column (point-column end))) + (cond + ;; left-top or left-bottom + ((< end-column start-column) + (character-offset start 1) + (setf start-column (point-column start))) + ;; right-top or right-bottom + (t + (unless (= end-column (length (line-string end))) + (character-offset end 1)) + (setf end-column (point-column end)))) + (apply-region-lines start end + (lambda (p) + (with-point ((s p) (e p)) + (move-to-column s start-column) + (move-to-column e end-column) + (push (make-overlay s e 'region :temporary t) overlays)))))) + overlays)) + (t '()))) + (define-state visual (vi-state) () (:default-initargs :modeline-color 'state-modeline-orange :keymaps (list *visual-keymap* *motion-keymap* *normal-keymap*))) -(define-state visual-char (visual) - () - (:default-initargs :name "VISUAL")) +(define-state visual-char (visual) () + (:default-initargs + :name "VISUAL")) (define-state visual-line (visual) () (:default-initargs @@ -54,117 +101,63 @@ (:default-initargs :name "V-BLOCK")) -(defmethod state-enabled-hook :after ((state visual)) - (setf *start-point* (copy-point (current-point)))) - -(defmethod state-disabled-hook ((state visual)) - (delete-point *start-point*) - (setf *start-point* nil) - (clear-visual-overlays)) - -(defun disable () - (clear-visual-overlays)) - -(defun clear-visual-overlays () - (mapc 'delete-overlay *visual-overlays*) - (setf *visual-overlays* '())) - -(defmethod post-command-hook ((state visual)) - (clear-visual-overlays) - (if (not (eq (current-buffer) (point-buffer *start-point*))) - (vi-visual-end) - (state-setup state))) - -(defgeneric state-setup (visual-state)) - -(defmethod state-setup ((state visual-char)) - (with-point ((start *start-point*) - (end (current-point))) - (when (point< end start) - (rotatef start end)) - (character-offset end 1) - (push (make-overlay start end 'region) - *visual-overlays*))) - -(defmethod state-setup ((state visual-line)) - (apply-region-lines *start-point* (current-point) - (lambda (p) - (push (make-line-overlay p 'region) - *visual-overlays*)))) - -(defmethod state-setup ((state visual-block)) - (with-point ((start *start-point*) - (end (current-point))) - (let ((start-column (point-column start)) - (end-column (point-column end))) - (cond - ;; left-top or left-bottom - ((< end-column start-column) - (character-offset start 1) - (setf start-column (point-column start))) - ;; right-top or right-bottom - (t - (unless (= end-column (length (line-string end))) - (character-offset end 1)) - (setf end-column (point-column end)))) - (apply-region-lines start end - (lambda (p) - (with-point ((s p) (e p)) - (move-to-column s start-column) - (move-to-column e end-column) - (push (make-overlay s e 'region) *visual-overlays*))))))) - -(define-command vi-visual-end () () - (clear-visual-overlays) - (change-state 'normal)) - -(defun enable-visual (new-state) +(defmethod buffer-state-enabled-hook :after ((state visual) buffer) + (unless (buffer-mark-p buffer) + (setf (buffer-mark buffer) (buffer-point buffer)))) + +(defmethod buffer-state-disabled-hook ((state visual) buffer)) + +(define-command vi-visual-end (&optional (buffer (current-buffer))) () + (buffer-mark-cancel buffer) + (setf (buffer-state buffer) 'normal)) + +(defun enable-visual (new-state buffer) (let ((new-state (ensure-state new-state)) - (current-state (current-state))) + (current-state (buffer-state buffer))) (cond ((typep current-state (class-name (class-of new-state))) - (vi-visual-end)) + (vi-visual-end buffer)) ((typep current-state 'visual) - (check-type *start-point* point) - (assert (alive-point-p *start-point*)) - (let ((start (copy-point *start-point*))) - (prog1 (change-state new-state) - (setf *start-point* start)))) + (with-point ((mark (buffer-mark buffer))) + (prog1 (setf (buffer-state buffer) new-state) + (setf (buffer-mark buffer) mark)))) (t - (change-state new-state))))) + (setf (buffer-state buffer) new-state) + (unless (buffer-mark-p buffer) + (setf (buffer-mark buffer) (current-point))))))) -(define-command vi-visual-char () () - (enable-visual 'visual-char)) +(define-command vi-visual-char (&optional (buffer (current-buffer))) () + (enable-visual 'visual-char buffer)) -(define-command vi-visual-line () () - (enable-visual 'visual-line)) +(define-command vi-visual-line (&optional (buffer (current-buffer))) () + (enable-visual 'visual-line buffer)) -(define-command vi-visual-block () () - (enable-visual 'visual-block)) +(define-command vi-visual-block (&optional (buffer (current-buffer))) () + (enable-visual 'visual-block buffer)) -(defun visual-p () - (typep (current-main-state) 'visual)) +(defun visual-p (&optional (buffer (current-buffer))) + (typep (buffer-state buffer) 'visual)) -(defun visual-char-p () - (typep (current-main-state) 'visual-char)) +(defun visual-char-p (&optional (buffer (current-buffer))) + (typep (buffer-state buffer) 'visual-char)) -(defun visual-line-p () - (typep (current-main-state) 'visual-line)) +(defun visual-line-p (&optional (buffer (current-buffer))) + (typep (buffer-state buffer) 'visual-line)) -(defun visual-block-p () - (typep (current-main-state) 'visual-block)) +(defun visual-block-p (&optional (buffer (current-buffer))) + (typep (buffer-state buffer) 'visual-block)) -(defun visual-range () - (with-point ((start *start-point*) - (end (current-point))) +(defun visual-range (&optional (buffer (current-buffer))) + (with-point ((start (buffer-mark buffer)) + (end (buffer-point buffer))) (cond - ((visual-char-p) + ((visual-char-p buffer) (cond ((point<= start end) (character-offset end 1)) ((point< end start) (character-offset start 1))) (list start end)) - ((visual-block-p) + ((visual-block-p buffer) (list start end)) (t (when (point< end start) @@ -174,7 +167,7 @@ (line-end end)) (list start end))))) -(defun (setf visual-range) (new-range) +(defun (setf visual-range) (new-range &optional (buffer (current-buffer))) (check-type new-range list) (destructuring-bind (start end) new-range (cond @@ -183,23 +176,24 @@ ((point< end start) (character-offset start -1))) (cond - ((or (visual-char-p) - (visual-block-p)) - (setf *start-point* start) - (move-point (current-point) end)) - ((visual-line-p) - (unless (same-line-p *start-point* start) - (setf *start-point* start)) - (unless (same-line-p end (current-point)) - (move-point (current-point) end)))))) - -(defun apply-visual-range (function) - (if (visual-line-p) - (apply function (visual-range)) - (dolist (ov (sort (copy-list *visual-overlays*) #'point< :key #'overlay-start)) - (funcall function - (overlay-start ov) - (overlay-end ov))))) + ((or (visual-char-p buffer) + (visual-block-p buffer)) + (setf (buffer-mark buffer) start) + (move-point (buffer-point buffer) end)) + ((visual-line-p buffer) + (unless (same-line-p (buffer-mark buffer) start) + (setf (buffer-mark buffer) start)) + (unless (same-line-p end (buffer-point buffer)) + (move-point (buffer-point buffer) end)))))) + +(defun apply-visual-range (function &optional (buffer (current-buffer))) + (if (visual-line-p buffer) + (apply function (visual-range buffer)) + (progn + (dolist (ov (sort (visual-overlays buffer) #'point< :key #'overlay-start)) + (funcall function + (overlay-start ov) + (overlay-end ov)))))) (defun string-without-escape () (concatenate 'string @@ -207,12 +201,12 @@ while (char/= #\Escape key-char) collect key-char))) -(define-command vi-visual-append () () - (when (visual-block-p) +(define-command vi-visual-append (&optional (buffer (current-buffer))) () + (when (visual-block-p buffer) (let ((str (string-without-escape)) (max-end (apply #'max (mapcar (lambda (ov) (point-charpos (overlay-end ov))) - *visual-overlays*)))) + (visual-overlays buffer))))) (apply-visual-range (lambda (start end) (unless (point< start end) (rotatef start end)) @@ -221,51 +215,71 @@ :initial-element #\Space))) (insert-string end (concatenate 'string spaces - str)))))) + str)))) + buffer)) (vi-visual-end))) -(define-command vi-visual-insert () () - (when (visual-block-p) +(define-command vi-visual-insert (&optional (buffer (current-buffer))) () + (when (visual-block-p buffer) (let ((str (string-without-escape))) (apply-visual-range (lambda (start end) (unless (point< start end) (rotatef start end)) - (insert-string start str)))) + (insert-string start str)) + buffer)) (vi-visual-end))) -(define-command vi-visual-swap-points () () - (with-point ((start *start-point*)) - (move-point *start-point* (current-point)) - (move-point (current-point) start))) - -(define-command vi-visual-opposite-side () () - (if (visual-block-p) - (let ((start-col (point-charpos *start-point*)) - (end-col (point-charpos (current-point)))) - (move-to-column *start-point* end-col) - (move-to-column (current-point) start-col)) +(define-command vi-visual-swap-points (&optional (buffer (current-buffer))) () + (with-point ((start (buffer-mark buffer))) + (setf (buffer-mark buffer) (buffer-point buffer)) + (move-point (buffer-point buffer) start))) + +(define-command vi-visual-opposite-side (&optional (buffer (current-buffer))) () + (if (visual-block-p buffer) + (let ((start-col (point-charpos (buffer-mark buffer))) + (end-col (point-charpos (buffer-point buffer)))) + (move-to-column (buffer-mark buffer) end-col) + (move-to-column (buffer-point buffer) start-col)) (vi-visual-swap-points))) (defmethod check-marked-using-global-mode ((global-mode vi-mode) buffer) - nil) + (unless (buffer-mark buffer) + (editor-error "Not mark in this buffer"))) (defmethod set-region-point-using-global-mode ((global-mode vi-mode) (start point) (end point)) (declare (ignore global-mode)) - (when (visual-p) - (let ((v-range (visual-range))) - (move-point start (car v-range)) - (move-point end (cadr v-range))))) + (let ((buffer (current-buffer))) + (when (visual-p buffer) + (let ((v-range (visual-range buffer))) + (move-point start (car v-range)) + (move-point end (cadr v-range)))))) (defmethod region-beginning-using-global-mode ((global-mode vi-mode) - &optional (buffer (current-buffer))) - (declare (ignore buffer)) - (if (visual-p) - (car (visual-range)) + &optional (buffer (current-buffer))) + (if (visual-p buffer) + (car (visual-range buffer)) (editor-error "Not in visual mode"))) (defmethod region-end-using-global-mode ((global-mode vi-mode) - &optional (buffer (current-buffer))) - (declare (ignore buffer)) - (if (visual-p) - (cadr (visual-range)) + &optional (buffer (current-buffer))) + (if (visual-p buffer) + (cadr (visual-range buffer)) (editor-error "Not in visual mode"))) + +(defun enable-visual-from-hook (buffer) + (unless (visual-p buffer) + (enable-visual 'visual-char buffer))) + +(defun disable-visual-from-hook(buffer) + (setf (buffer-state buffer) 'normal)) + +(defun visual-enable-hook () + (add-hook *buffer-mark-activate-hook* 'enable-visual-from-hook) + (add-hook *buffer-mark-deactivate-hook* 'disable-visual-from-hook)) + +(defun visual-disable-hook () + (remove-hook *buffer-mark-activate-hook* 'enable-visual-from-hook) + (remove-hook *buffer-mark-deactivate-hook* 'disable-visual-from-hook)) + +(add-hook *enable-hook* 'visual-enable-hook) +(add-hook *disable-hook* 'visual-disable-hook) diff --git a/src/buffer/internal/basic.lisp b/src/buffer/internal/basic.lisp index 6718b257a..ae43bcec9 100644 --- a/src/buffer/internal/basic.lisp +++ b/src/buffer/internal/basic.lisp @@ -442,7 +442,7 @@ If 'line-number' is out of the buffer, 'point' does not move and returns NIL." (defun set-current-mark (point) "Set 'point' to the current mark." (let ((buffer (point-buffer point))) - (mark-set-point (buffer-mark-object buffer) point)) + (setf (buffer-mark buffer) point)) point) (defun blank-line-p (point) diff --git a/src/buffer/internal/buffer.lisp b/src/buffer/internal/buffer.lisp index 1f4a4446e..bc38d14c9 100644 --- a/src/buffer/internal/buffer.lisp +++ b/src/buffer/internal/buffer.lisp @@ -90,6 +90,11 @@ :initform nil :accessor buffer-last-write-date))) +(defvar *buffer-mark-activate-hook* '() + "Hook run when mark is activated.") +(defvar *buffer-mark-deactivate-hook* '() + "Hook run when mark is inactivated.") + (defclass text-buffer (buffer) ()) @@ -232,8 +237,16 @@ Options that can be specified by arguments are ignored if `temporary` is NIL and "Unflag the change flag of 'buffer'." (setf (buffer-%modified-p buffer) 0)) +(defun (setf buffer-mark) (point &optional (buffer (current-buffer))) + (let ((already-active (buffer-mark-p buffer))) + (mark-set-point (buffer-mark-object buffer) point) + (unless already-active + (run-hooks *buffer-mark-activate-hook* buffer)))) + (defun buffer-mark-cancel (buffer) - (mark-cancel (buffer-mark-object buffer))) + (when (buffer-mark-p buffer) + (mark-cancel (buffer-mark-object buffer)) + (run-hooks *buffer-mark-deactivate-hook* buffer))) (defun buffer-attributes (buffer) (concatenate 'string diff --git a/src/buffer/package.lisp b/src/buffer/package.lisp index 1398028ca..040ac6a01 100644 --- a/src/buffer/package.lisp +++ b/src/buffer/package.lisp @@ -78,6 +78,8 @@ :with-buffer-point :with-current-buffer :clear-buffer-edit-history + :*buffer-mark-activate-hook* + :*buffer-mark-deactivate-hook* ;; TODO: delete ugly exports :%buffer-clear-keep-binfo :%buffer-keep-binfo) diff --git a/src/display/logical-line.lisp b/src/display/logical-line.lisp index 93ee0beba..83ab71936 100644 --- a/src/display/logical-line.lisp +++ b/src/display/logical-line.lisp @@ -245,13 +245,15 @@ (make-attribute :background color) :temporary t)))) -(defun make-temporary-region-overlay-from-cursor (cursor) +(defgeneric make-region-overlays-using-global-mode (global-mode cursor)) + +(defmethod make-region-overlays-using-global-mode ((global-mode emacs-mode) cursor) (let ((mark (cursor-mark cursor))) (when (mark-active-p mark) - (make-overlay cursor + (list (make-overlay cursor (mark-point mark) 'region - :temporary t)))) + :temporary t))))) (defun make-cursor-overlay* (point) (make-cursor-overlay @@ -266,8 +268,8 @@ (overlays (buffer-overlays buffer))) (when (eq (current-window) window) (dolist (cursor (buffer-cursors buffer)) - (if-push (make-temporary-region-overlay-from-cursor cursor) - overlays)) + (alexandria:when-let ((region-overlays (make-region-overlays-using-global-mode (current-global-mode) cursor))) + (dolist (ol region-overlays) (push ol overlays)))) (if-push (make-temporary-highlight-line-overlay buffer) overlays)) (if (and (eq window (current-window)) diff --git a/src/internal-packages.lisp b/src/internal-packages.lisp index 724edba1d..c65c25da4 100644 --- a/src/internal-packages.lisp +++ b/src/internal-packages.lisp @@ -609,6 +609,9 @@ :redraw-buffer :compute-left-display-area-content :compute-wrap-left-area-content) + ;; display/logical-line.lisp + (:export + :make-region-overlays-using-global-mode) ;; interface.lisp (:export :with-implementation From b30c87f6b9841b587caaf85bc653981e73eed6fc Mon Sep 17 00:00:00 2001 From: Tomaneo Date: Fri, 23 May 2025 22:29:07 +0300 Subject: [PATCH 2/2] Make region selection functions behave more vi like in vi-mode --- extensions/vi-mode/states.lisp | 2 ++ src/commands/s-expression.lisp | 2 +- src/internal-packages.lisp | 1 + src/mouse.lisp | 4 ++-- src/region.lisp | 2 ++ 5 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extensions/vi-mode/states.lisp b/extensions/vi-mode/states.lisp index a6ec3b1db..4d8b36981 100644 --- a/extensions/vi-mode/states.lisp +++ b/extensions/vi-mode/states.lisp @@ -127,6 +127,7 @@ (setf (current-state) state))) (defun vi-enable-hook () + (setf *region-end-offset* -1) (setf (current-state) (or (buffer-state (current-buffer)) (ensure-state 'normal))) (add-hook *switch-to-buffer-hook* 'vi-switch-to-buffer) (add-hook *switch-to-window-hook* 'vi-switch-to-window) @@ -134,6 +135,7 @@ (add-hook *prompt-deactivate-hook* 'exit-prompt)) (defun vi-disable-hook () + (setf *region-end-offset* 0) (remove-hook *switch-to-buffer-hook* 'vi-switch-to-buffer) (remove-hook *switch-to-window-hook* 'vi-switch-to-window) (remove-hook *prompt-after-activate-hook* 'enter-prompt) diff --git a/src/commands/s-expression.lisp b/src/commands/s-expression.lisp index c91b07396..73c9ac692 100644 --- a/src/commands/s-expression.lisp +++ b/src/commands/s-expression.lisp @@ -66,7 +66,7 @@ (form-offset (mark-point (cursor-mark (current-point))) 1)) (t (save-excursion - (form-offset (current-point) 1) + (character-offset (form-offset (current-point) 1) *region-end-offset*) (set-cursor-mark (current-point) (current-point)))))) (define-command (kill-sexp (:advice-classes editable-advice)) (&optional (n 1)) (:universal) diff --git a/src/internal-packages.lisp b/src/internal-packages.lisp index c65c25da4..feffef9a6 100644 --- a/src/internal-packages.lisp +++ b/src/internal-packages.lisp @@ -644,6 +644,7 @@ :background-color) ;; region.lisp (:export + :*region-end-offset* :check-marked-using-global-mode :region-beginning-using-global-mode :region-end-using-global-mode diff --git a/src/mouse.lisp b/src/mouse.lisp index 2af09a253..4486ba412 100644 --- a/src/mouse.lisp +++ b/src/mouse.lisp @@ -331,7 +331,7 @@ (get-select-expression-points (current-point)) (when start (set-current-mark start) - (move-point (current-point) end)))) + (move-point (current-point) (character-offset end *region-end-offset*))))) (defun select-form-at-current-point () (with-point ((start (current-point)) @@ -341,7 +341,7 @@ (move-point end start) (form-offset end 1) (set-current-mark start) - (move-point (current-point) end)))) + (move-point (current-point) (character-offset end *region-end-offset*))))) (define-command () () diff --git a/src/region.lisp b/src/region.lisp index 69206663e..f19c50e99 100644 --- a/src/region.lisp +++ b/src/region.lisp @@ -1,5 +1,7 @@ (in-package :lem-core) +(defvar *region-end-offset* 0) + (defgeneric check-marked-using-global-mode (global-mode buffer)) (defgeneric region-beginning-using-global-mode (global-mode &optional buffer)) (defgeneric region-end-using-global-mode (global-mode &optional buffer))