diff --git a/src/command-window.lisp b/src/command-window.lisp index 96eb36f..09b6b06 100644 --- a/src/command-window.lisp +++ b/src/command-window.lisp @@ -249,7 +249,7 @@ be either `:keybinding' or `:string'. the former for key command the latter for (defgeneric remove-messages (object)) (defun event-wants-delete-last-element-p (decoded-event) - (or (eq decoded-event :key-backspace) + (or (eq decoded-event :backspace) (string= decoded-event "^?"))) (defun manage-command-event (command-window event) @@ -519,35 +519,35 @@ command line." (move-point-to-start command-window) (set-keybinding-mode command-window) (fire-user-input-event command-window :canceled t)) - ((eq :alt-left original-key-event) + ((eq :alt-left decoded-event) (move-suggestion-page-left command-window)) - ((eq :alt-right original-key-event) + ((eq :alt-right decoded-event) (move-suggestion-page-right command-window)) ((event-wants-delete-last-element-p decoded-event) (setf command-line (delete-at-point command-window command-line :direction :left)) (when 'hooks:*after-char-to-command-window* (hooks:run-hook 'hooks:*after-delete-char-from-command-window* command-window)) (show-candidate-completion command-window)) - ((eq :key-delete-char original-key-event) + ((eq :delete decoded-event) (setf command-line (delete-at-point command-window command-line :direction :right)) (when 'hooks:*after-char-to-command-window* (hooks:run-hook 'hooks:*after-delete-char-from-command-window* command-window)) (show-candidate-completion command-window)) - ((eq :key-arrow-left original-key-event) + ((eq :left decoded-event) (move-point-left command-window)) - ((eq :key-arrow-right original-key-event) + ((eq :right decoded-event) (move-point-right command-window (length command-line))) - ((eq :key-end original-key-event) + ((eq :end decoded-event) (move-point-to-end command-window command-line)) - ((eq :key-home original-key-event) + ((eq :home decoded-event) (move-point-to-start command-window)) - ((eq :key-arrow-up original-key-event) + ((eq :up decoded-event) (if (win-shown-p suggestions-win) (select-suggestion-previous command-window) (multiple-value-bind (new-id new-input) (db:previous-in-history history-position prompt) (set-history new-id new-input)))) - ((eq :key-arrow-down original-key-event) + ((eq :down decoded-event) (if (win-shown-p suggestions-win) (select-suggestion-next command-window) (multiple-value-bind (new-id new-input) diff --git a/src/keybindings.lisp b/src/keybindings.lisp index 16572c2..9d9d533 100644 --- a/src/keybindings.lisp +++ b/src/keybindings.lisp @@ -52,15 +52,6 @@ ;; |'f8' ;; |'f9' ;; |'f10 -;; | 'key-arrow-right' -;; | 'key-arrow-left' -;; | 'key-arrow-up' -;; | 'key-arrow-down' -;; | 'key-home' -;; | 'key-end' -;; | 'key-next-page' -;; | 'key-previous-page' -;; | 'key-delete-char' ;; | ARROW-RIGHT ;; | ARROW-LEFT ;; | ARROW-UP @@ -105,31 +96,40 @@ (:text t)) (defrule keybindings-arrow-right "right" - (:constant "key-arrow-right")) + (:constant "right") + (:function string-upcase)) (defrule keybindings-arrow-left "left" - (:constant "key-arrow-left")) + (:constant "left") + (:function string-upcase)) (defrule keybindings-arrow-up "up" - (:constant "key-arrow-up")) + (:constant "up") + (:function string-upcase)) (defrule keybindings-arrow-down "down" - (:constant "key-arrow-down")) + (:constant "down") + (:function string-upcase)) (defrule keybindings-key-home "home" - (:constant "key-home")) + (:constant "home") + (:function string-upcase)) (defrule keybindings-key-end "end" - (:constant "key-end")) + (:constant "end") + (:function string-upcase)) (defrule keybindings-key-next-page "npage" - (:constant "key-next-page")) + (:constant "page-down") + (:function string-upcase)) (defrule keybindings-key-previous-page "ppage" - (:constant "key-previous-page")) + (:constant "page-up") + (:function string-upcase)) (defrule keybindings-key-delete-next-char "dc" - (:constant "key-delete-char")) + (:constant "delete-char") + (:function string-upcase)) (defrule keybindings-non-printable-key (or "f10" @@ -142,15 +142,13 @@ "f7" "f8" "f9" - "key-arrow-right" - "key-arrow-left" - "key-arrow-up" - "key-arrow-down" - "key-home" - "key-end" - "key-next-page" - "key-previous-page" - "key-delete-char" + "right" + "left" + "up" + "down" + "home" + "end" + "delete-char" keybindings-arrow-right keybindings-arrow-left keybindings-arrow-up @@ -523,19 +521,17 @@ understand" (function-name key))) ((string= key "^J") (_ "Enter")) - ((or (string= key "KEY-DELETE-CHAR") + ((or (string= key "DELETE-CHAR") (string= key "DC")) (_ "Delete")) - ((or (string= key "KEY-NEXT-PAGE") - (string= key "NPAGE")) + ((string= key "PAGE-DOWN") (_ "Page-up")) - ((or (string= key "KEY-PREVIOUS-PAGE") - (string= key "PPAGE")) + ((string= key "PAGE-UP") (_ "Page-down")) - ((or (string= key "KEY-ARROW-DOWN") + ((or (string= key "ARROW-DOWN") (string= key "UP")) (_ "Arrow up")) - ((or (string= key "KEY-ARROW-UP") + ((or (string= key "ARROW-UP") (string= key "DOWN")) (_ "Arrow down")) (t diff --git a/src/line-oriented-window.lisp b/src/line-oriented-window.lisp index fdb3e27..0f6146d 100644 --- a/src/line-oriented-window.lisp +++ b/src/line-oriented-window.lisp @@ -516,7 +516,7 @@ will fire the `callback' function (with the selected field from `all-fields' (window-height (min (truncate (* 0.9 (win-height screen))) (+ (max (length text-lines) +min-shown-win-height+) - 2))) + 2))) (window-x (truncate (- (* 0.5 (win-width screen)) (* 0.5 window-width)))) (window-y (truncate (- (* 0.5 (win-height screen)) @@ -537,34 +537,35 @@ will fire the `callback' function (with the selected field from `all-fields' (win-move high-level-window window-x window-y) (setf (rows high-level-window) (loop - for text in text-lines - for fields in all-fields - collect - (make-instance 'line - :fields fields - :normal-text text - :selected-text text - :normal-bg bg - :normal-fg fg - :selected-bg fg - :selected-fg bg))) + for text in text-lines + for fields in all-fields + collect + (make-instance 'line + :fields fields + :normal-text text + :selected-text text + :normal-bg bg + :normal-fg fg + :selected-bg fg + :selected-fg bg))) (select-row high-level-window 0) (draw) (loop named inner - for c = (tui:decode-key-event (c:get-wide-event low-level-window)) + for c = (tui:decode-key-event (c:get-wide-event low-level-window) + :convert-symbol-to-string nil) while (not (event-quit-blocking-list-dialog-window-p c)) do - (cond - ((string= c :key-arrow-up) - (unselect-all high-level-window) - (row-move high-level-window -1)) - ((string= c :key-arrow-down) - (unselect-all high-level-window) - (row-move high-level-window 1)) - ((string= c "^J") - (let ((selected-fields (selected-row-fields high-level-window)) - (selected-text (selected-text (selected-row high-level-window)))) - (when callback - (funcall callback selected-text selected-fields))))) - (draw)) + (cond + ((string= c :up) + (unselect-all high-level-window) + (row-move high-level-window -1)) + ((string= c :down) + (unselect-all high-level-window) + (row-move high-level-window 1)) + ((string= c "^J") + (let ((selected-fields (selected-row-fields high-level-window)) + (selected-text (selected-text (selected-row high-level-window)))) + (when callback + (funcall callback selected-text selected-fields))))) + (draw)) (win-close high-level-window)))) diff --git a/src/tui-utils.lisp b/src/tui-utils.lisp index 5676682..bb12506 100644 --- a/src/tui-utils.lisp +++ b/src/tui-utils.lisp @@ -96,17 +96,23 @@ as argument `complex-string'." (length (complex-char-array complex-string))) (defun decode-key-event (event &key (convert-symbol-to-string t)) - (let* ((key (croatoan:event-key event)) - (decoded-event (cond - ((characterp key) - (key-to-string key)) - ((symbolp key) - (if convert-symbol-to-string - (symbol-name key) - key)) - (t - (error (_ "Unknown key event ~a") key))))) - (values decoded-event key))) + (labels ((decode-event (key) + (cond + ((characterp key) + (key-to-string key)) + ((symbolp key) + (if convert-symbol-to-string + (string-upcase (symbol-name key)) + key)) + ((croatoan:key-p key) + (decode-event (croatoan:key-name key))) + (t + (error (_ "Unknown key event ~a") key))))) + + (let* ((key (croatoan:event-key event)) + (decoded-event (decode-event key))) + #+debug-croatoan-events (misc:dbg "event ~s" decoded-event) + (values decoded-event key)))) (defun colorize-tree-element (color-map annotated-element) "Colormap is an alist like: diff --git a/tinmop.asd b/tinmop.asd index f838a0e..06ee2cb 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -201,3 +201,4 @@ ;; (push :debug-sql *features*) ;; (push :debug-gemini-request *features*) ;; (push :debug-json-rpc *features*) +;; (push :debug-croatoan-events *features*)