diff options
Diffstat (limited to 'lisp/term')
| -rw-r--r-- | lisp/term/xterm-kitty.el | 426 |
1 files changed, 5 insertions, 421 deletions
diff --git a/lisp/term/xterm-kitty.el b/lisp/term/xterm-kitty.el index e08d358..c1f79f5 100644 --- a/lisp/term/xterm-kitty.el +++ b/lisp/term/xterm-kitty.el @@ -30,428 +30,12 @@ ;;; Code: (require 'term/xterm) +(require 'kitty-keyboard-protocol) (defun xterm-kitty-in-use (&optional frame) "Check whether FRAME is running under kitty terminal." (terminal-parameter frame 'kitty-window-id)) -(defvar xterm-kitty-modifiers-alist - '((1 . shift) (2 . alt) (4 . control) (8 . super) (16 . hyper) (32 . meta)) - "Modifier mapping; SHIFT must always be present as first element with value 1. - -Changing the values allows for swapping modifiers. For example - (1 . shift) (2 . alt) (4 . control) (8 . meta) (16 . hyper) (32 . super) -would swap meta and super.") - -(defvar xterm-kitty-escape-prefix "\e[" - "CSI escape sequence generated by kitty.") - -(defvar xterm-kitty-shift-alist - `(,@(mapcar (lambda (p) (cons (aref p 0) (aref p 1))) - (split-string "`~ 1! 2@ 3# 4$ 5% 6^ 7& 8* 9( 0) -_ =+ [{ ]} \\| ;: '\" ,< .> /?")) - ,@(mapcar (lambda (c) (cons c (- c (- ?a ?A)))) - (number-sequence ?a ?z))) - "Characters produced by shifted keys; used to convert shifted keybindings.") - -;; ------------------------------------------------------------------------------------ -;; Implementation - -(defconst xterm-kitty--prefix-alist - '((shift . "S-") (alt . "A-") (control . "C-") (super . "s-") (hyper . "H-") (meta . "M-")) - "Modifier prefixes.") -(defconst xterm-kitty--bitset-alist - (mapcar (lambda (a) (cons (car a) (ash 1 (cdr a)))) - '((shift . 25) (alt . 22) (control . 26) (super . 23) (hyper . 24) (meta . 27))) - "Modifier bits set.") -(defconst xterm-kitty--modifier-combinations - (number-sequence 0 (1- (ash 1 (length xterm-kitty-modifiers-alist)))) - "Numerical representation of all combinations") - -(defun xterm-kitty--make-modifiers-from-num (num &rest others) - "Make a list of modifiers from NUM along with additional modifiers OTHERS." - (let* ((bits (mapcar (lambda (idx) (logand num (ash 1 idx))) (number-sequence 0 (1- (length xterm-kitty-modifiers-alist))))) - (found-mods (flatten-list (list (mapcar (lambda (b) (alist-get b xterm-kitty-modifiers-alist)) bits) others)))) - found-mods)) - -(defun xterm-kitty--from-numeric-modifer (num list-map folder) - (apply folder (mapcar (lambda (mod) (alist-get mod list-map)) - (xterm-kitty--make-modifiers-from-num num)))) - -(defconst xterm-kitty--numeric-modifiers - (apply #'vector (mapcar (lambda (num) (xterm-kitty--from-numeric-modifer num xterm-kitty--bitset-alist #'logior)) - xterm-kitty--modifier-combinations)) - "Numeric modifiers to apply to each printable character for kitty modifier.") - -(defconst xterm-kitty--prefix-modifiers - (apply #'vector (mapcar (lambda (num) (if (> num 0) - (xterm-kitty--from-numeric-modifer num xterm-kitty--prefix-alist #'concat) - "")) - xterm-kitty--modifier-combinations)) - "Symbolic prefix to apply to each printable character for kitty modifier.") - -;; (message (apply #'concat (mapcar (lambda (p) (format "%x " (ash p -22))) (sort xterm-kitty--numeric-modifiers '<)))) -;; (message (apply #'concat (mapcar (lambda (p) (format "%s " p)) xterm-kitty--prefix-modifiers))) - -(defun xterm-kitty--add-event-modifier-to-symbol (mod-string e) - (let ((symbol (if (symbolp e) e (car e)))) - (setq symbol (intern (concat mod-string (symbol-name symbol)))) - (if (symbolp e) - symbol - (cons symbol (cdr e))))) - -(defun xterm-kitty--precompute-with-modifiers (sym) - (apply #'vector - (and sym - (mapcar (lambda (mod) (vector (xterm-kitty--add-event-modifier-to-symbol mod sym))) - xterm-kitty--prefix-modifiers)))) - -(defvar xterm-kitty--suffix-tilde-map - '((2 . insert) - (3 . delete) - (5 . prior) - (6 . next) - (7 . home) - (8 . end) - (11 . f1) - (12 . f2) - (13 . f3) - (14 . f4) - (15 . f5) - (17 . f6) - (18 . f7) - (19 . f8) - (20 . f9) - (21 . f10) - (23 . f11) - (24 . f12)) - "Entries with ~ suffix.") -(defvar xterm-kitty--suffix-tilde-precomputed - (apply #'vector (mapcar (lambda (n) (xterm-kitty--precompute-with-modifiers (alist-get n xterm-kitty--suffix-tilde-map))) - (number-sequence 0 (car (car (last xterm-kitty--suffix-tilde-map)))))) - "Precomputed vectors for ~ suffix.") - -(defvar xterm-kitty--suffix-alpha-map - '((?A . up) - (?B . down) - (?C . right) - (?D . left) - ;; (?E . kp-begin) - (?F . end) - (?H . home) - (?P . f1) - (?Q . f2) - (?R . f3) - (?S . f4)) - "Entries with alphabetic suffix.") -(defvar xterm-kitty--suffix-alpha-precomputed - (apply #'vector (mapcar (lambda (n) (xterm-kitty--precompute-with-modifiers (alist-get n xterm-kitty--suffix-alpha-map))) - (number-sequence ?A (caar (last xterm-kitty--suffix-alpha-map))))) - "Precomputed vectors for alphabetic suffix.") - -(defvar xterm-kitty--suffix-u-non-private - `(?\x8 ?\x9 ?\xd ?\x1b ?\x7f ?\s ; BS, TAB, RET, ESC, DEL, SPC - ,@(mapcar #'car xterm-kitty-shift-alist)) - "All characters in non-private unicode space") - -(defvar xterm-kitty--suffix-u-private - `(,@(mapcar (lambda (n) (cons (+ n (- 57376 13)) (intern (format "f%d" n)))) - (number-sequence 13 35)) - ,@(mapcar (lambda (n) (cons (+ 57399 n) (intern (format "kp-%d" n)))) - (number-sequence 0 9)) - (57409 . kp-decimal) - (57410 . kp-divide) - (57411 . kp-multiply) - (57412 . kp-subtract) - (57413 . kp-add) - (57414 . kp-enter) - (57415 . kp-equal) - (57416 . kp-separator) - (57417 . kp-left) - (57418 . kp-right) - (57419 . kp-up) - (57420 . kp-down) - (57421 . kp-prior) - (57422 . kp-next) - (57423 . kp-home) - (57424 . kp-end) - (57425 . kp-insert) - (57426 . kp-delete) - (57427 . kp-begin)) - "Entries with unicode private area mapping") -(defvar xterm-kitty--suffix-u-private-bounds - (let ((codes (mapcar #'car xterm-kitty--suffix-u-private))) - (vector (apply #'min codes) (apply #'max codes))) - "Bounds of private area unicode keycodes") - -(defvar xterm-kitty--suffix-u-private-precomputed - (apply #'vector - (mapcar - (lambda (n) - (when-let (key (alist-get n xterm-kitty--suffix-u-private)) - (xterm-kitty--precompute-with-modifiers key))) - (number-sequence - (aref xterm-kitty--suffix-u-private-bounds 0) - (aref xterm-kitty--suffix-u-private-bounds 1)) - )) - "Precomputed vectors for unicode private area mapping.") - -(defvar xterm-kitty--suffix-u-private-unsupported - '((57428 . media-play ) - (57429 . media-pause ) - (57430 . media-play-pause ) - (57431 . media-reverse ) - (57432 . media-stop ) - (57433 . media-fast-forward ) - (57434 . media-rewind ) - (57435 . media-track-next ) - (57436 . media-track-previous ) - (57437 . media-record ) - (57438 . lower-volume ) - (57439 . raise-volume ) - (57440 . mute-volume ) - (57441 . left-shift ) - (57442 . left-control ) - (57443 . left-alt ) - (57444 . left-super ) - (57445 . left-hyper ) - (57446 . left-meta ) - (57447 . right-shift ) - (57448 . right-control ) - (57449 . right-alt ) - (57450 . right-super ) - (57451 . right-hyper ) - (57452 . right-meta )) - "Entries with unicode private area mapping without emacs equivalents") - -(defconst xterm-kitty--shift-modifier (car (rassoc 'shift xterm-kitty-modifiers-alist)) - "Value of the shift modifier.") - -(defun xterm-kitty--make-suffix (mod) - (if (zerop mod) "" (format ";%d" (1+ mod)))) - -(defun xterm-kitty--insert-decode-table (keymap) - "Insert decoding table into KEYMAP" - (let* ((all-modifiers xterm-kitty--modifier-combinations) - (all-mod-suffixes (apply #'vector (mapcar #'xterm-kitty--make-suffix all-modifiers)))) - (mapc - (lambda (key) - (let ((keystr (format "%d" key))) - (mapc - (lambda (mod) - (define-key keymap - (concat xterm-kitty-escape-prefix keystr (aref all-mod-suffixes mod) "u") - (xterm-kitty-decode-key-stroke key mod ?u))) - all-modifiers))) - xterm-kitty--suffix-u-non-private) - (mapc - (lambda (key) - (let ((keystr (format "%d" key))) - (mapc - (lambda (mod) - (define-key keymap - (concat xterm-kitty-escape-prefix keystr (aref all-mod-suffixes mod) "u") - nil)) - all-modifiers))) - (mapcar #'car xterm-kitty--suffix-u-private-unsupported)) - (mapc - (lambda (key) - (let ((keystr (format "%d" key))) - (mapc - (lambda (mod) - (define-key keymap - (concat xterm-kitty-escape-prefix keystr (aref all-mod-suffixes mod) "~") - (xterm-kitty-decode-key-stroke key mod ?~))) - all-modifiers))) - (mapcar #'car xterm-kitty--suffix-tilde-map)) - (mapc - (lambda (suffix) - (let ((keystr (char-to-string suffix))) - ;; If we let kitty send legacy escape codes, we will need the following: - ;; (define-key keymap (concat "\eO" keystr) - ;; (xterm-kitty-decode-key-stroke 0 0 suffix)) - (mapc - (lambda (mod) - (define-key keymap - (concat xterm-kitty-escape-prefix - (if (zerop mod) "" "1") - (aref all-mod-suffixes mod) - keystr) - (xterm-kitty-decode-key-stroke 0 mod suffix))) - all-modifiers))) - (mapcar #'car xterm-kitty--suffix-alpha-map))) - - ;; Terminal mouse handling - (define-key keymap "\e[200~" #'xterm-translate-bracketed-paste) - (define-key keymap "\e[I" #'xterm-translate-focus-in) - (define-key keymap "\e[O" #'xterm-translate-focus-out)) - -;; (setq dum2 (let ((map (make-sparse-keymap))) -;; (xterm-kitty--insert-decode-table map))) -;; (lookup-key dum2 (concat xterm-kitty-escape-prefix "97;5u")) -;; (xterm-kitty--add-modifier-list '(control) ?i) - -(defun xterm-kitty-decode-key-stroke (keycode modifiers suffix) - "Take KEYCODE MODIFIERS SUFFIX of the form (105,5,u) and construct key." - ;; Ignore modifiers that we cannot understand (CapsLock and NumLock status) - (let ((mods (logand modifiers (1- (length xterm-kitty--numeric-modifiers))))) - (if (eql suffix ?u) - (if (< keycode 57344) - ;; To do: support remaining keycodes in unicode private use area - ;; (send-string-to-terminal (format "%s" (logior keycode (aref xterm-kitty--numeric-modifiers mods)))) - (let* ((shifted-key (and (eql (logand mods xterm-kitty--shift-modifier) - xterm-kitty--shift-modifier) - (alist-get keycode xterm-kitty-shift-alist))) - ;; The following is equivalent to mods & ~shift - (new-modifiers (and shifted-key (- mods xterm-kitty--shift-modifier)))) - (vector (logior (or shifted-key keycode) - (aref xterm-kitty--numeric-modifiers (if shifted-key new-modifiers mods))))) - (when (<= - (aref xterm-kitty--suffix-u-private-bounds 0) - keycode - (aref xterm-kitty--suffix-u-private-bounds 1)) - (aref (aref xterm-kitty--suffix-u-private-precomputed - (- keycode (aref xterm-kitty--suffix-u-private-bounds 0))) - mods))) - (if (eql suffix ?~) - (if (eql keycode 200) - (xterm-translate-bracketed-paste nil) - (aref (aref xterm-kitty--suffix-tilde-precomputed keycode) mods)) - (when (<= ?A suffix ?S) - (if (and (or (eql suffix ?I) (eql suffix ?O)) - (eql keycode 0) - (eql mods 0)) - ;; xterm focus in/out; perhaps there's a better way to do this - (if (eql suffix ?I) (xterm-translate-focus-in nil) (xterm-translate-focus-out nil)) - (aref (aref xterm-kitty--suffix-alpha-precomputed (- suffix ?A)) mods))))))) - -(defun xterm-kitty-handle-non-printable (keystr) - "Split kitty non-printable keystring KEYSTR (e.g., 105;5u) and construct key" - (let* ((suffix (aref keystr (1- (length keystr)))) - (parts (split-string keystr ";")) - (num-parts (length parts)) - (code (string-to-number keystr)) ; will be zero for alpha suffix without modifiers - (modifiers (if (>= num-parts 2) (1- (string-to-number (cadr parts))) 0))) - ;; (send-string-to-terminal (format "%s %s %s" keystr code modifiers)) - (xterm-kitty-decode-key-stroke code modifiers suffix))) - -;; The following function is semi-obsolete, and is intended to be used solely for testing. -(defun xterm-kitty--handle-escape-code1 (prompt) - "Handle escape code by reading rest of keycode as string; PROMPT is ignored." - (let* ((e (read-char)) - (complete-string (string e)) - (count 0)) - ;; There must be a faster way to create this string than one character at a time - (while (and (or (<= ?0 e ?9) - (eql e ?\;)) - (< count 25)) - (setq count (1+ count)) ; safety - (setq e (read-char)) - (setq complete-string (concat complete-string (string e)))) - ;; (send-string-to-terminal complete-string) - (xterm-kitty-handle-non-printable complete-string))) - -(defun xterm-kitty--handle-escape-code (prompt) - "Handle keycode using integer math; PROMPT is ignored." - (let ((keycode 0) - (modifiers 0) - (suffix nil) - (current-num 0) - (e)) - (while (not suffix) - (setq e (read-event)) - (if (<= ?0 e ?9) - (setq current-num (+ (* current-num 10) (- e ?0))) - (if (eql e ?\;) - (setq keycode current-num - current-num 0) - (setq suffix e) - (if (> keycode 0) - (setq modifiers (1- current-num)) - (setq keycode current-num))))) - ;; (message "Code: %d modifiers %d suffix: %s" keycode modifiers suffix) - (xterm-kitty-decode-key-stroke keycode modifiers suffix))) - -(defvar xterm-kitty-legacy-control-mapping - '(;(?\@ . 0) - (?a . 1) - (?b . 2) - (?c . 3) - (?d . 4) - (?e . 5) - (?f . 6) - (?g . 7) - (?h . 8) - ;; (?i . 9) - (?j . 10) - (?k . 11) - (?l . 12) - ;; (?m . 13) - (?n . 14) - (?o . 15) - (?p . 16) - (?q . 17) - (?r . 18) - (?s . 19) - (?t . 20) - (?u . 21) - (?v . 22) - (?w . 23) - (?x . 24) - (?y . 25) - (?z . 26) - ;; (?\[ . 27) - (?\\ . 28) - ;; (?\] . 29) - ;; (?^ . 30) - ;; (?~ . 30) - ;; (?/ . 31) - ;; (?_ . 31) - ;; (?? . 127) - ;; (?0 . 48) - ;; (?1 . 49) - ;; (?2 . 0) - ;; (?3 . 27) - ;; (?4 . 28) - ;; (?5 . 29) - ;; (?6 . 30) - ;; (?7 . 31) - ;; (?8 . 127) - ;; (?9 . 57) - ) - "Map C- and C-M- combinations to legacy values.") - -(defun xterm-kitty--add-modifier-list (mod-list e) - (let ((modifier-list (flatten-list mod-list))) - (if (numberp e) - (progn - ;; (message "%d" (logior e (apply #'logior (mapcar (lambda (m) (alist-get m xterm-kitty--bitset-alist)) modifier-list)))) - (logior e (apply #'logior (mapcar (lambda (m) (alist-get m xterm-kitty--bitset-alist)) modifier-list)))) - (and e - (if modifier-list - (xterm-kitty--add-event-modifier-to-symbol - (apply 'concat (mapcar (lambda (m) (alist-get m xterm-kitty--prefix-alist)) modifier-list)) - e) - e))))) -(defun xterm-kitty--setup-legacy-control-maps (keymap) - (mapc - (lambda (bind) - ;; Redirect C- and C-M- combinations because they are part of base bindings - (define-key keymap (vector (xterm-kitty--add-modifier-list '(control) (car bind))) (vector (cdr bind))) - (define-key keymap - (vector (xterm-kitty--add-modifier-list '(control meta) (car bind))) - (vector (xterm-kitty--add-modifier-list '(meta) (cdr bind))))) - xterm-kitty-legacy-control-mapping)) -(defvar xterm-kitty-legacy-control-map - (let ((map (make-sparse-keymap))) - (xterm-kitty--setup-legacy-control-maps map) - map) - "Legacy control and control-meta remapping for shifted versions") -(defvar xterm-kitty-basic-map - (let ((map (make-sparse-keymap))) - (xterm-kitty--insert-decode-table map) - map) - "Basic decode map for kitty") - (defun xterm-kitty-make-binding-sequence (default key &rest modifiers) "Make a key vector for KEY with VECTORS suitable for binding with 'define-key' if xterm-kitty is active. @@ -465,7 +49,7 @@ avoid it is to provide the key vector itself to 'define-key', which this function explicitly creates. In that sense, this function is almost equivalent to 'event-convert-list'." (if (xterm-kitty-in-use) - (vector (xterm-kitty--add-modifier-list modifiers key)) + (vector (kitty-kbp--add-modifier-list modifiers key)) default)) ;; To do: debug the reason that the table method does not work @@ -491,11 +75,11 @@ function is almost equivalent to 'event-convert-list'." (push "\e[<u" (terminal-parameter nil 'tty-mode-reset-strings))) (if xterm-kitty-use-table-method ;; (xterm-kitty--insert-decode-table kmap) - (xterm--push-map xterm-kitty-basic-map kmap) + (xterm--push-map kitty-kbp-basic-map kmap) ;; (setq input-decode-map xterm-kitty-basic-map) - (define-key kmap xterm-kitty-escape-prefix #'xterm-kitty--handle-escape-code))) + (define-key kmap kitty-kbp-escape-prefix #'kitty-kbp--handle-escape-code))) (when (and alternate-kmap) - (xterm--push-map xterm-kitty-legacy-control-map alternate-kmap)))) + (xterm--push-map kitty-kbp-legacy-control-map alternate-kmap)))) (defun xterm-kitty-window-id (&optional terminal) ; public API (terminal-parameter terminal 'kitty-window-id)) |