diff options
Diffstat (limited to 'lisp/term')
| -rw-r--r-- | lisp/term/xterm-kitty.el | 499 |
1 files changed, 499 insertions, 0 deletions
diff --git a/lisp/term/xterm-kitty.el b/lisp/term/xterm-kitty.el new file mode 100644 index 0000000..9706fbb --- /dev/null +++ b/lisp/term/xterm-kitty.el @@ -0,0 +1,499 @@ +;;; xterm-kitty.el --- kitty terminal support + +;; Copyright (C) 2021 Ravi Kiran + +;; Author: Ravi Kiran <aine.marina@gmail.com> +;; Keywords: + +;; 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: + +;; Work-in-progress to support kitty terminal with all modifiers +;; - still need to +;; + ensure proper 24-bit color support +;; + add all keys specified in private unicode space +;; + figure out a way to split keybindings between kitty and non-kitty +;; frames + +;;; Code: + +(require 'term/xterm) + +(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) + (?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") + +(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) + (unless (zerop 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) "~") + (xterm-kitty-decode-key-stroke key mod ?~))) + all-modifiers))) + (mapcar #'car xterm-kitty--suffix-tilde-map)) + (mapc + (lambda (suffix) + (let ((keystr (format "%d" suffix))) + (mapc + (lambda (mod) + (define-key keymap + (concat xterm-kitty-escape-prefix + (if (zerop mod) "" "1") + (aref all-mod-suffixes mod) + (string suffix)) + (xterm-kitty-decode-key-stroke 0 mod suffix))) + all-modifiers))) + (mapcar #'car xterm-kitty--suffix-alpha-map)))) + +;; (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) + (when (< 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)))))) + (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))) + +(fset 'xterm-kitty--original-read-char-exclusive (symbol-function 'read-char-exclusive)) +(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 (xterm-kitty--original-read-char-exclusive)) + (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-map + '(;(?\@ . 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-map)) + +(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. + +DEFAULT is the value to be returned if xterm-kitty is not active. +KEY is the key to be used. MODIFIERS is a list of modifiers, or +modifiers specified explicitly. + +'define-key' uses 'event-convert-list' internally, which strips +off shift modifiers for alphabetic characters. The only way to +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)) + default)) + +;; To do: debug the reason that the table method does not work +;; - the table does not seem to be reflected in input-decode-map +;; - the table method is needed for those packages which advice +;; low-level functions such as read-char, e.g., multiple-cursors +(defvar xterm-kitty-use-table-method nil + "Use table method to handle character map") + +(defun xterm-kitty-apply-keyboard (&optional keymap alternate-keymap) + "Apply keyboard defintion; optionally to KEYMAP and ALTERNATE-KEYMAP." + (let* ((kmap (or keymap + (and (xterm-kitty-in-use) input-decode-map))) + (alternate-kmap (or alternate-keymap + (and kmap + (not keymap) + key-translation-map)))) + (when kmap + (unless keymap ; default keymap was used + (message "Applying xterm-kitty changes") + (send-string-to-terminal "\e[>1;u") + (push "\e[>1;u" (terminal-parameter nil 'tty-mode-set-strings)) + (push "\e[<u" (terminal-parameter nil 'tty-mode-reset-strings))) + (if xterm-kitty-use-table-method + (xterm-kitty--insert-decode-table kmap) + (define-key kmap xterm-kitty-escape-prefix #'xterm-kitty--handle-escape-code))) + (when (and alternate-kmap) + (xterm-kitty--setup-legacy-control-maps alternate-kmap)))) + +(defun xterm-kitty-window-id (&optional terminal) ; public API + (terminal-parameter terminal 'kitty-window-id)) + +(defun xterm-kitty--remote-control-response () + (let ((str "") + prev-chr + chr + parsed + payload) + ;; The reply should be: \eP@kitty-cmd{"ok": true, "data": payload}\e\\ + (while (and (setq chr (xterm--read-event-for-query)) + (not (and (equal prev-chr ?\e) (equal chr ?\\)))) + (when prev-chr (setq str (concat str (string prev-chr)))) + (setq prev-chr chr)) + (setq parsed-data (json-parse-string str)) + (when (and (hash-table-p parsed-data) (eql (gethash "ok" parsed-data) t)) + (setq payload (gethash "data" parsed-data))) + payload)) + +(defun xterm-kitty--save-kitty-window-id () + (let* ((kitty-response (xterm-kitty--remote-control-response)) + (response-json (json-parse-string kitty-response)) + window-id) + (mapc (lambda (os-win) + (mapc (lambda (tab) + (mapc (lambda (win) + (let ((is-self (eq (gethash "is_self" win) t)) + (win-id (gethash "id" win))) + (when is-self + (if window-id + (message "Multiple windows match: using %s, not %s" window-id win-id) + (setq window-id win-id))))) + (gethash "windows" tab))) + (gethash "tabs" os-win))) + response-json) + (set-terminal-parameter nil 'kitty-window-id window-id))) + +(defun xterm-kitty-save-window-id () + "Save kitty window ID of current terminal" + (xterm--query "\eP@kitty-cmd{\"cmd\":\"ls\",\"version\":[0,19,3]}\e\\" + '(("\eP@kitty-cmd" . xterm-kitty--save-kitty-window-id)))) + +(defvar xterm-kitty--focus-window-command-string + "\eP@kitty-cmd{\"cmd\":\"focus-window\",\"version\":[0,19,3],\"no_response\":true,\"payload\":{\"match\":\"id:%d\"}}\e\\" + "Command string to send to kitty to focus kitty window; must have a single placeholder %d") +(defun xterm-kitty-focus (frame-or-window) + "Set focus to terminal containing FRAME-OR-WINDOW + + FRAME-OR-WINDOW can be a terminal, a frame, or a window" + (let* ((frame (if (windowp frame-or-window) (window-frame frame-or-window) frame-or-window)) + (kitty-window-id (xterm-kitty-window-id (frame-terminal frame)))) + ;; (message "Window id %d for %s" kitty-window-id frame) + (if kitty-window-id + (send-string-to-terminal (format xterm-kitty--focus-window-command-string kitty-window-id)) + (message "%s is not a kitty window" frame-or-window)))) +(defun xterm-kitty-select-frame-set-input-focus-advice (old-function frame &optional no-record) + (or (when (xterm-kitty-in-use frame) + ;; (message "Switching to frame: %s" frame) + (xterm-kitty-focus frame) + (select-frame frame no-record)) + (funcall old-function frame no-record))) +(defun xterm-kitty-visible-window-advice (old-function &optional window minibuf all-frames) + (when (xterm-kitty-in-use) + ;; Terminal emacs thinks that only one frame is ever visible + (funcall old-function window minibuf (if (eql all-frames 'visible) t all-frames)))) +(defun xterm-kitty-add-select-frame-set-input-focus-advice () + "Advise SELECT-FRAME-SET-INPUT-FOCUS to handle xterm-kitty terminal windows" + (interactive) + (advice-add 'select-frame-set-input-focus :around #'xterm-kitty-select-frame-set-input-focus-advice) + (advice-add 'next-window :around #'xterm-kitty-visible-window-advice) + (advice-add 'previous-window :around #'xterm-kitty-visible-window-advice)) + +(defvar xterm-kitty--new-os-window-command-string + "\eP@kitty-cmd{\"cmd\":\"new-window\",\"version\":[0,19,3],\"no_response\":true,\"payload\":{\"window_type\":\"os\"}}\e\\" + "Command string to send to kitty to make new kitty window") +(defun xterm-kitty-new-os-window () + "Open new xterm-kitty os window" + (interactive) + (when (xterm-kitty-in-use) + (send-string-to-terminal xterm-kitty--new-os-window-command-string))) + +(defun terminal-init-xterm-kitty () + "Terminal initialization function for kitty" + ;; Order is important here: window id must be saved prior to any + ;; other xterm-kitty function calls in this function. + (xterm-kitty-save-window-id) + (xterm-kitty-apply-keyboard) + + ;; Standard xterm-like initialization + (xterm-register-default-colors xterm-standard-colors) + (tty-set-up-initial-frame-faces) + + ;; Steal private functions from term/xterm that kitty supports + (xterm--query "\e]11;?\e\\" + '(("\e]11;" . xterm--report-background-handler))) + (xterm--init-activate-get-selection) + (xterm--init-activate-set-selection) + (when xterm-set-window-title + (xterm--init-frame-title)) + (xterm--init-bracketed-paste-mode) + (xterm--init-focus-tracking) + + (run-hooks 'terminal-init-xterm-kitty-hook)) + +(provide 'term/xterm-kitty) +;;; xterm-kitty.el ends here |