path: root/lisp/term/xterm-kitty.el

;;; 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)))

(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-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))))

(defvar xterm-kitty--skip-select-frame-set-input-focus-advice nil
  "Set to true to disable setting input focus advice")
(defun xterm-kitty-add-select-frame-set-input-focus-advice (&optional print-message)
  "Advise SELECT-FRAME-SET-INPUT-FOCUS to handle xterm-kitty terminal windows"
  (interactive "p")
  (if xterm-kitty--skip-select-frame-set-input-focus-advice
      (when print-message
        (message "Input focus advice for selecting frames disabled"))
    (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)
    (setq xterm-kitty--skip-select-frame-set-input-focus-advice t)))

(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