summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorRavi R Kiran <aine.marina@gmail.com>2021-10-10 22:01:43 (GMT)
committerRavi R Kiran <aine.marina@gmail.com>2021-10-10 22:01:43 (GMT)
commitbed226284e9762de58400e2a3a1e40444db532ab (patch)
tree573e1ff83ba06a6fc67e5da57447007d18ab5d85
parent1fbee9c1868d3b26becf5daac77e00e73453f461 (diff)
downloaddotemacs-bed226284e9762de58400e2a3a1e40444db532ab.zip
dotemacs-bed226284e9762de58400e2a3a1e40444db532ab.tar.gz
dotemacs-bed226284e9762de58400e2a3a1e40444db532ab.tar.bz2
Refactor keyboard protocol support into separate file
-rw-r--r--lisp/kitty-keyboard-protocol.el473
-rw-r--r--lisp/term/xterm-kitty.el426
2 files changed, 478 insertions, 421 deletions
diff --git a/lisp/kitty-keyboard-protocol.el b/lisp/kitty-keyboard-protocol.el
new file mode 100644
index 0000000..77de473
--- /dev/null
+++ b/lisp/kitty-keyboard-protocol.el
@@ -0,0 +1,473 @@
+;;; kitty-keyboard-protocol.el --- Kitty keyboard protocol -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 Ravi Kiran
+
+;; Author: Ravi Kiran <aine.marina@gmail.com>
+;; Keywords: terminals
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Kitty keyboard protocol support for unambiguous key detection
+
+;;; Code:
+
+(defvar kitty-kbp-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 kitty-kbp-escape-prefix "\e["
+ "CSI escape sequence generated by kitty.")
+
+(defvar kitty-kbp-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 kitty-kbp--prefix-alist
+ '((shift . "S-") (alt . "A-") (control . "C-") (super . "s-") (hyper . "H-") (meta . "M-"))
+ "Modifier prefixes.")
+(defconst kitty-kbp--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 kitty-kbp--modifier-combinations
+ (number-sequence 0 (1- (ash 1 (length kitty-kbp-modifiers-alist))))
+ "Numerical representation of all combinations")
+
+(defun kitty-kbp--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 kitty-kbp-modifiers-alist)))))
+ (found-mods (flatten-list
+ (list (mapcar (lambda (b) (alist-get b kitty-kbp-modifiers-alist))
+ bits) others))))
+ found-mods))
+
+(defun kitty-kbp--from-numeric-modifer (num list-map folder)
+ (apply folder (mapcar (lambda (mod) (alist-get mod list-map))
+ (kitty-kbp--make-modifiers-from-num num))))
+
+(defconst kitty-kbp--numeric-modifiers
+ (apply #'vector (mapcar (lambda (num) (kitty-kbp--from-numeric-modifer num kitty-kbp--bitset-alist #'logior))
+ kitty-kbp--modifier-combinations))
+ "Numeric modifiers to apply to each printable character for kitty modifier.")
+
+(defconst kitty-kbp--prefix-modifiers
+ (apply #'vector (mapcar (lambda (num) (if (> num 0)
+ (kitty-kbp--from-numeric-modifer num kitty-kbp--prefix-alist #'concat)
+ ""))
+ kitty-kbp--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 kitty-kbp--numeric-modifiers '<))))
+;; (message (apply #'concat (mapcar (lambda (p) (format "%s " p)) kitty-kbp--prefix-modifiers)))
+
+(defun kitty-kbp--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 kitty-kbp--precompute-with-modifiers (sym)
+ (apply #'vector
+ (and sym
+ (mapcar (lambda (mod) (vector (kitty-kbp--add-event-modifier-to-symbol mod sym)))
+ kitty-kbp--prefix-modifiers))))
+
+;; Must be in sorted order
+(defvar kitty-kbp--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 kitty-kbp--suffix-tilde-precomputed
+ (apply #'vector (mapcar (lambda (n) (kitty-kbp--precompute-with-modifiers (alist-get n kitty-kbp--suffix-tilde-map)))
+ (number-sequence 0 (car (car (last kitty-kbp--suffix-tilde-map))))))
+ "Precomputed vectors for ~ suffix.")
+
+;; Must be in sorted order
+(defvar kitty-kbp--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 kitty-kbp--suffix-alpha-precomputed
+ (apply #'vector (mapcar (lambda (n) (kitty-kbp--precompute-with-modifiers (alist-get n kitty-kbp--suffix-alpha-map)))
+ (number-sequence ?A (caar (last kitty-kbp--suffix-alpha-map)))))
+ "Precomputed vectors for alphabetic suffix.")
+
+;; Must be in sorted order
+(defvar kitty-kbp--suffix-u-non-private
+ `(?\x8 ?\x9 ?\xd ?\x1b ?\x7f ?\s ; BS, TAB, RET, ESC, DEL, SPC
+ ,@(mapcar #'car kitty-kbp-shift-alist))
+ "All characters in non-private unicode space")
+
+;; Must be in sorted order
+(defvar kitty-kbp--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 kitty-kbp--suffix-u-private-bounds
+ (let ((codes (mapcar #'car kitty-kbp--suffix-u-private)))
+ (vector (apply #'min codes) (apply #'max codes)))
+ "Bounds of private area unicode keycodes")
+
+(defvar kitty-kbp--suffix-u-private-precomputed
+ (apply #'vector
+ (mapcar
+ (lambda (n)
+ (when-let (key (alist-get n kitty-kbp--suffix-u-private))
+ (kitty-kbp--precompute-with-modifiers key)))
+ (number-sequence
+ (aref kitty-kbp--suffix-u-private-bounds 0)
+ (aref kitty-kbp--suffix-u-private-bounds 1))
+ ))
+ "Precomputed vectors for unicode private area mapping.")
+
+;; Must be in sorted order
+(defvar kitty-kbp--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 kitty-kbp--shift-modifier (car (rassoc 'shift kitty-kbp-modifiers-alist))
+ "Value of the shift modifier.")
+
+(defun kitty-kbp-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 kitty-kbp--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 kitty-kbp--numeric-modifiers mods))))
+ (let* ((shifted-key (and (eql (logand mods kitty-kbp--shift-modifier)
+ kitty-kbp--shift-modifier)
+ (alist-get keycode kitty-kbp-shift-alist)))
+ ;; The following is equivalent to mods & ~shift
+ (new-modifiers (and shifted-key (- mods kitty-kbp--shift-modifier))))
+ (vector (logior (or shifted-key keycode)
+ (aref kitty-kbp--numeric-modifiers (if shifted-key new-modifiers mods)))))
+ (when (<=
+ (aref kitty-kbp--suffix-u-private-bounds 0)
+ keycode
+ (aref kitty-kbp--suffix-u-private-bounds 1))
+ (aref (aref kitty-kbp--suffix-u-private-precomputed
+ (- keycode (aref kitty-kbp--suffix-u-private-bounds 0)))
+ mods)))
+ (if (eql suffix ?~)
+ (if (eql keycode 200)
+ (xterm-translate-bracketed-paste nil)
+ (aref (aref kitty-kbp--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 kitty-kbp--suffix-alpha-precomputed (- suffix ?A)) mods)))))))
+
+(defun kitty-kbp-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))
+ (kitty-kbp-decode-key-stroke code modifiers suffix)))
+
+
+
+;; --------------------------------------------------------------------------------
+;; Read from event loop (current working method)
+
+(defvar kitty-kbp-event-read-function
+ #'read-event
+ "Function to use for keyboard event collection")
+
+;; The following function is semi-obsolete, and is intended to be used solely for testing.
+(defun kitty-kbp--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)
+ (kitty-kbp-handle-non-printable complete-string)))
+
+(defun kitty-kbp--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)
+ (kitty-kbp-decode-key-stroke keycode modifiers suffix)))
+
+
+
+;; --------------------------------------------------------------------------------
+;; Keymap storage functions (currently do not work for unknown reasons)
+
+(defun kitty-kbp--make-suffix (mod)
+ (if (zerop mod) "" (format ";%d" (1+ mod))))
+
+(defun kitty-kbp--insert-decode-table (keymap)
+ "Insert decoding table into KEYMAP"
+ (let* ((all-modifiers kitty-kbp--modifier-combinations)
+ (all-mod-suffixes (apply #'vector (mapcar #'kitty-kbp--make-suffix all-modifiers))))
+ (mapc
+ (lambda (key)
+ (let ((keystr (format "%d" key)))
+ (mapc
+ (lambda (mod)
+ (define-key keymap
+ (concat kitty-kbp-escape-prefix keystr (aref all-mod-suffixes mod) "u")
+ (kitty-kbp-decode-key-stroke key mod ?u)))
+ all-modifiers)))
+ kitty-kbp--suffix-u-non-private)
+ (mapc
+ (lambda (key)
+ (let ((keystr (format "%d" key)))
+ (mapc
+ (lambda (mod)
+ (define-key keymap
+ (concat kitty-kbp-escape-prefix keystr (aref all-mod-suffixes mod) "u")
+ nil))
+ all-modifiers)))
+ (mapcar #'car kitty-kbp--suffix-u-private-unsupported))
+ (mapc
+ (lambda (key)
+ (let ((keystr (format "%d" key)))
+ (mapc
+ (lambda (mod)
+ (define-key keymap
+ (concat kitty-kbp-escape-prefix keystr (aref all-mod-suffixes mod) "~")
+ (kitty-kbp-decode-key-stroke key mod ?~)))
+ all-modifiers)))
+ (mapcar #'car kitty-kbp--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)
+ ;; (kitty-kbp-decode-key-stroke 0 0 suffix))
+ (mapc
+ (lambda (mod)
+ (define-key keymap
+ (concat kitty-kbp-escape-prefix
+ (if (zerop mod) "" "1")
+ (aref all-mod-suffixes mod)
+ keystr)
+ (kitty-kbp-decode-key-stroke 0 mod suffix)))
+ all-modifiers)))
+ (mapcar #'car kitty-kbp--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)))
+;; (kitty-kbp--insert-decode-table map)))
+;; (lookup-key dum2 (concat kitty-kbp-escape-prefix "97;5u"))
+;; (kitty-kbp--add-modifier-list '(control) ?i)
+
+(defvar kitty-kbp-basic-map
+ (let ((map (make-sparse-keymap)))
+ (kitty-kbp--insert-decode-table map)
+ map)
+ "Basic decode map for kitty")
+
+
+
+;; --------------------------------------------------------------------------------
+;; Map upper case to lower case for legacy control maps
+
+(defvar kitty-kbp-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 kitty-kbp--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 kitty-kbp--bitset-alist)) modifier-list))))
+ (logior e (apply #'logior (mapcar (lambda (m) (alist-get m kitty-kbp--bitset-alist)) modifier-list))))
+ (and e
+ (if modifier-list
+ (kitty-kbp--add-event-modifier-to-symbol
+ (apply 'concat (mapcar (lambda (m) (alist-get m kitty-kbp--prefix-alist)) modifier-list))
+ e)
+ e)))))
+(defun kitty-kbp--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 (kitty-kbp--add-modifier-list '(control) (car bind))) (vector (cdr bind)))
+ (define-key keymap
+ (vector (kitty-kbp--add-modifier-list '(control meta) (car bind)))
+ (vector (kitty-kbp--add-modifier-list '(meta) (cdr bind)))))
+ kitty-kbp-legacy-control-mapping))
+(defvar kitty-kbp-legacy-control-map
+ (let ((map (make-sparse-keymap)))
+ (kitty-kbp--setup-legacy-control-maps map)
+ map)
+ "Legacy control and control-meta remapping for shifted versions")
+
+(provide 'kitty-keyboard-protocol)
+;;; kitty-keyboard-protocol.el ends here
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))