Unify vi-mode visual state with lem buffer marks

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) ("<R>")
     (: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) ("<R>")
     (: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) ("<R>")
-    ()
+    (: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) ("<r>")
     (: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) ("<R>")
     (: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) ("<r>")
     (: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) ("<R>")
-    (: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)

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 "<r>")
-                        `(multiple-value-list (operator-region ',motion :move-point ,move-point)))
+                        `(multiple-value-list (operator-region ',motion)))
                        ((string= arg-descriptor "<R>")
-                        `(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 "<v>")
                         '(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)

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*)

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,39 @@
 ;;
 ;; 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 *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)
+  (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))
+  (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)
+  (remove-hook *prompt-deactivate-hook* 'exit-prompt))
 
 (add-hook *enable-hook* 'vi-enable-hook)
 (add-hook *disable-hook* 'vi-disable-hook)

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]")))))