1 files changed, 473 insertions, 0 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