From bed226284e9762de58400e2a3a1e40444db532ab Mon Sep 17 00:00:00 2001 From: Ravi R Kiran Date: Sun, 10 Oct 2021 17:01:43 -0500 Subject: Refactor keyboard protocol support into separate file 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 +;; 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 . + +;;; 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[