811d51a4f2
Rename: cl-tty avoids naming collision with Quicklisp's cl-tui (naryl/cl-tui, a cl-charms-based ncurses library). Our project is pure escape-sequence CL. v0.9.0 adds: - Dialog base class: modal overlay with backdrop, centered panel, size variants (:small/:medium/:large), stack-based management - Dialog subclasses: alert, confirm, select-dialog, prompt-dialog - Toast notifications: transient, top-right corner, auto-dismiss, colored variants (info/success/warning/error) - 78 tests total, 100% passing ASDF: read-time package references (+fiveam:+) replaced with find-symbol so .asd loads without FiveAM pre-loaded
78 lines
3.3 KiB
Common Lisp
78 lines
3.3 KiB
Common Lisp
(in-package #:cl-tty.input)
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Key map struct
|
|
;;; ---------------------------------------------------------------------------
|
|
(defstruct keymap
|
|
(name nil :type (or keyword null))
|
|
(bindings nil :type list)
|
|
(parent nil :type (or keymap null)))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Global keymap registry
|
|
;;; ---------------------------------------------------------------------------
|
|
(defparameter *keymaps* (make-hash-table :test #'equal))
|
|
(defparameter *chord-timeout* 0.5)
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Key spec matching
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun key-match-p (spec event)
|
|
"T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword)
|
|
or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords."
|
|
(etypecase spec
|
|
;; Keyword like :ctrl+p, :alt+f, :enter, :space, :f1
|
|
(keyword
|
|
(let* ((name (string spec))
|
|
(plus (position #\+ name)))
|
|
(if plus
|
|
;; Modified key: :ctrl+p → mod-str="CTRL", key-str="P"
|
|
(let ((mod-str (subseq name 0 plus))
|
|
(key-str (subseq name (1+ plus))))
|
|
(and (eql (intern key-str :keyword)
|
|
(key-event-key event))
|
|
(cond
|
|
((string= mod-str "CTRL") (key-event-ctrl event))
|
|
((string= mod-str "ALT") (key-event-alt event))
|
|
((string= mod-str "SHIFT") (key-event-shift event))
|
|
(t t))))
|
|
;; Plain keyword: :enter, :escape, :f1, etc.
|
|
(eql spec (key-event-key event)))))
|
|
;; List: (:ctrl+p) or (:ctrl+x :ctrl+s)
|
|
(list
|
|
(when spec
|
|
(key-match-p (first spec) event)))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Dispatch
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun dispatch-key-event (event &key component)
|
|
(labels ((try-keymap (km)
|
|
(when km
|
|
(loop for (spec . handler) in (keymap-bindings km)
|
|
thereis (when (key-match-p spec event)
|
|
(funcall handler event)
|
|
t))))
|
|
(find-keymap (name)
|
|
(gethash name *keymaps*)))
|
|
(or (and component
|
|
(let ((km (component-keymap component)))
|
|
(when km (try-keymap km))))
|
|
(try-keymap (find-keymap :local))
|
|
(try-keymap (find-keymap :global)))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; defkeymap macro
|
|
;;; ---------------------------------------------------------------------------
|
|
(defmacro defkeymap (name &body bindings)
|
|
`(setf (gethash ',name *keymaps*)
|
|
(make-keymap :name ',name
|
|
:bindings (list ,@(loop for b in bindings
|
|
collect (if (consp (cdr b))
|
|
`(cons ',(car b) ,(cadr b))
|
|
`(cons ',(car b) ,(cdr b))))))))
|
|
|
|
;;; --- Component protocol integration ---
|
|
(defgeneric component-keymap (component)
|
|
(:method ((c t)) nil))
|