forked from lem-project/lem
-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request lem-project#1050 from fukamachi/vi-yank-move-pos-c…
…harwise Fix the cursor position after yanked
- Loading branch information
Showing
5 changed files
with
292 additions
and
34 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,224 @@ | ||
| (defpackage :lem-vi-mode/registers | ||
| (:use :cl | ||
| :lem) | ||
| (:import-from :lem-vi-mode/core | ||
| :vi-current-window) | ||
| (:import-from :lem-core | ||
| :with-current-killring) | ||
| (:import-from :lem/common/killring | ||
| :killring | ||
| :make-killring | ||
| :killring-ring | ||
| :push-killring-item | ||
| :peek-killring-item | ||
| :make-item | ||
| :item-string | ||
| :*appending*) | ||
| (:import-from :lem/common/ring | ||
| :ring-ref | ||
| :ring-empty-p | ||
| :invalid-index-error) | ||
| (:import-from :trivial-types | ||
| :proper-list) | ||
| (:export :get-register | ||
| :set-register | ||
| :yank-region | ||
| :delete-region)) | ||
| (in-package :lem-vi-mode/registers) | ||
|
|
||
| (deftype key-sequence () | ||
| '(trivial-types:proper-list lem-core::key)) | ||
|
|
||
| (deftype register () 'character) | ||
|
|
||
| (deftype register-designator () '(or character (string 1))) | ||
|
|
||
| (declaim (type hash-table *named-registers*)) | ||
| (defvar *named-registers* (make-hash-table)) | ||
|
|
||
| (declaim (type killring *yank-history*)) | ||
| (defvar *yank-history* (make-killring 1)) | ||
|
|
||
| (declaim (type killring *deletion-history*)) | ||
| (defvar *deletion-history* (make-killring 9)) | ||
|
|
||
| (defvar *unnamed-register* nil) | ||
| (defvar *small-deletion-register* nil) | ||
|
|
||
| (defun downcase-char (char) | ||
| (declare (type character char)) | ||
| (cond | ||
| ((char<= #\A char #\Z) | ||
| (code-char | ||
| (+ (char-code char) | ||
| #.(- (char-code #\a) (char-code #\A))))) | ||
| ((char<= #\a char #\z)) | ||
| (t char))) | ||
|
|
||
| (defun ensure-char (name) | ||
| (check-type name register-designator) | ||
| (if (stringp name) | ||
| (aref name 0) | ||
| name)) | ||
|
|
||
| (defun named-register-p (name) | ||
| (declare (type character name)) | ||
| (or (char<= #\a name #\z) | ||
| (char<= #\A name #\Z))) | ||
|
|
||
| (defun numbered-register-p (name) | ||
| (declare (type character name)) | ||
| (char<= #\0 name #\9)) | ||
|
|
||
| (defun named-register (name) | ||
| (assert (char<= #\a name #\z)) | ||
| (let ((value-and-options | ||
| (gethash name *named-registers*))) | ||
| (values (car value-and-options) | ||
| (cdr value-and-options)))) | ||
|
|
||
| (defun (setf named-register) (value name &key append) | ||
| (assert (char<= #\a name #\z)) | ||
| (values-list | ||
| (setf (gethash name *named-registers*) | ||
| (if append | ||
| (destructuring-bind (existing-value &optional options) | ||
| (gethash name *named-registers*) | ||
| (cons | ||
| (etypecase existing-value | ||
| (cons | ||
| (check-type value list) | ||
| (append existing-value value)) | ||
| (string | ||
| (check-type value string) | ||
| (format nil "~A~A" existing-value value)) | ||
| (null value)) | ||
| options)) | ||
| (list value))))) | ||
|
|
||
| (defun numbered-register (name) | ||
| (assert (char<= #\0 name #\9)) | ||
| (case name | ||
| (#\0 | ||
| (peek-killring-item *yank-history* 0)) | ||
| (otherwise | ||
| (if (ring-empty-p (killring-ring *deletion-history*)) | ||
| (values nil nil) | ||
| (let ((n (- (char-code name) #.(char-code #\1)))) | ||
| (handler-case (peek-killring-item *deletion-history* n) | ||
| (invalid-index-error () | ||
| (values nil nil)))))))) | ||
|
|
||
| (defun (setf numbered-register) (value name &key append) | ||
| (assert (char<= #\0 name #\9)) | ||
| (check-type value string) | ||
| (case name | ||
| (#\0 | ||
| (let ((*appending* append)) | ||
| (push-killring-item *yank-history* value))) | ||
| (otherwise | ||
| (let ((n (- (char-code name) #.(char-code #\1))) | ||
| (ring (killring-ring *deletion-history*))) | ||
| (if append | ||
| (let ((item (ring-ref ring n))) | ||
| (if item | ||
| (setf (item-string item) | ||
| (format nil "~A~A" | ||
| (item-string item) value)) | ||
| (setf (ring-ref ring n) | ||
| (make-item :string value)))) | ||
| (setf (ring-ref ring n) | ||
| (make-item :string value))))))) | ||
|
|
||
| (defun yank-region (start end &key type) | ||
| (with-current-killring *yank-history* | ||
| (with-killring-context (:options (when (eq type :line) :vi-line) | ||
| :appending (when (eq type :block) | ||
| (continue-flag :vi-yank-block))) | ||
| (copy-region start end))) | ||
| (setf *unnamed-register* #\0) | ||
| (values)) | ||
|
|
||
| (defun delete-region (start end &key type small) | ||
| (with-killring-context (:options (when (eq type :line) :vi-line) | ||
| :appending (when (eq type :block) | ||
| (continue-flag :vi-delete-block))) | ||
| (let ((string (lem:delete-between-points start end))) | ||
| (copy-to-clipboard-with-killring string) | ||
| (unless small | ||
| (push-killring-item *deletion-history* string)) | ||
| (if small | ||
| (setf *small-deletion-register* string | ||
| *unnamed-register* #\-) | ||
| (setf *unnamed-register* #\1)))) | ||
| (values)) | ||
|
|
||
| (defun get-register (name) | ||
| (let ((name (ensure-char name))) | ||
| (declare (type register name)) | ||
| (cond | ||
| ((named-register-p name) | ||
| (named-register name)) | ||
| ((numbered-register-p name) | ||
| (numbered-register name)) | ||
| (t | ||
| (ecase name | ||
| ;; Unnamed register | ||
| (#\" | ||
| (etypecase *unnamed-register* | ||
| (register (get-register *unnamed-register*)) | ||
| ((or string | ||
| key-sequence) | ||
| *unnamed-register*) | ||
| (null nil))) | ||
| ;; Small delete register | ||
| (#\- | ||
| *small-deletion-register*) | ||
| ;; Most recent Ex command (read-only) | ||
| ;(#\:) | ||
| ;; Last inserted text (read-only) | ||
| ;(#\.) | ||
| ;; Current file name (read-only) | ||
| (#\% | ||
| (buffer-filename (current-buffer))) | ||
| ;; Alternate file name register | ||
| (#\# | ||
| (buffer-filename (window-buffer (vi-current-window)))) | ||
| ;; Expression register | ||
| ;(#\=) | ||
| ;; Selection register | ||
| ;((#\* #\+)) | ||
| ;; Blackhole register | ||
| (#\_ | ||
| nil) | ||
| ;; Last search register | ||
| ;(#\/) | ||
| ))))) | ||
|
|
||
| (defun set-register (name value) | ||
| (check-type value (or string key-sequence)) | ||
| (let ((name (ensure-char name))) | ||
| (declare (type character name)) | ||
| (cond | ||
| ((named-register-p name) | ||
| (let ((name (downcase-char name))) | ||
| (setf (named-register name | ||
| :append (char<= #\A name #\Z)) | ||
| value))) | ||
| ((numbered-register-p name) | ||
| (setf (numbered-register name) value)) | ||
| ((char= name #\") | ||
| (setf *unnamed-register* value)) | ||
| (t | ||
| (check-type value string) | ||
| (ecase name | ||
| (#\- | ||
| (check-type value string) | ||
| (setf *small-deletion-register* value)) | ||
| ((#\: #\. #\% #\#) | ||
| (editor-error "Register '\"~A' is read-only." name)) | ||
| ;(#\=) | ||
| ;((#\* #\+)) | ||
| (#\_ nil) | ||
| ;(#\/) | ||
| ))))) |
Oops, something went wrong.