cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- changed decoding of events to match changes in croatoan.

This commit is contained in:
cage 2024-07-05 13:45:05 +02:00
parent a00a363091
commit 3b16fdbbb5
5 changed files with 85 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/command-window.lisp
View File

@ -249,7 +249,7 @@ be either `:keybinding' or `:string'. the former for key command the latter for
(defgeneric remove-messages (object)) (defgeneric remove-messages (object))
(defun event-wants-delete-last-element-p (decoded-event) (defun event-wants-delete-last-element-p (decoded-event)
(or (eq decoded-event :key-backspace) (or (eq decoded-event :backspace)
(string= decoded-event "^?"))) (string= decoded-event "^?")))
(defun manage-command-event (command-window event) (defun manage-command-event (command-window event)
@ -519,35 +519,35 @@ command line."
(move-point-to-start command-window) (move-point-to-start command-window)
(set-keybinding-mode command-window) (set-keybinding-mode command-window)
(fire-user-input-event command-window :canceled t)) (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)) (move-suggestion-page-left command-window))
((eq :alt-right original-key-event) ((eq :alt-right decoded-event)
(move-suggestion-page-right command-window)) (move-suggestion-page-right command-window))
((event-wants-delete-last-element-p decoded-event) ((event-wants-delete-last-element-p decoded-event)
(setf command-line (delete-at-point command-window command-line :direction :left)) (setf command-line (delete-at-point command-window command-line :direction :left))
(when 'hooks:*after-char-to-command-window* (when 'hooks:*after-char-to-command-window*
(hooks:run-hook 'hooks:*after-delete-char-from-command-window* command-window)) (hooks:run-hook 'hooks:*after-delete-char-from-command-window* command-window))
(show-candidate-completion 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)) (setf command-line (delete-at-point command-window command-line :direction :right))
(when 'hooks:*after-char-to-command-window* (when 'hooks:*after-char-to-command-window*
(hooks:run-hook 'hooks:*after-delete-char-from-command-window* command-window)) (hooks:run-hook 'hooks:*after-delete-char-from-command-window* command-window))
(show-candidate-completion command-window)) (show-candidate-completion command-window))
((eq :key-arrow-left original-key-event) ((eq :left decoded-event)
(move-point-left command-window)) (move-point-left command-window))
((eq :key-arrow-right original-key-event) ((eq :right decoded-event)
(move-point-right command-window (length command-line))) (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)) (move-point-to-end command-window command-line))
((eq :key-home original-key-event) ((eq :home decoded-event)
(move-point-to-start command-window)) (move-point-to-start command-window))
((eq :key-arrow-up original-key-event) ((eq :up decoded-event)
(if (win-shown-p suggestions-win) (if (win-shown-p suggestions-win)
(select-suggestion-previous command-window) (select-suggestion-previous command-window)
(multiple-value-bind (new-id new-input) (multiple-value-bind (new-id new-input)
(db:previous-in-history history-position prompt) (db:previous-in-history history-position prompt)
(set-history new-id new-input)))) (set-history new-id new-input))))
((eq :key-arrow-down original-key-event) ((eq :down decoded-event)
(if (win-shown-p suggestions-win) (if (win-shown-p suggestions-win)
(select-suggestion-next command-window) (select-suggestion-next command-window)
(multiple-value-bind (new-id new-input) (multiple-value-bind (new-id new-input)

64
src/keybindings.lisp
View File

@ -52,15 +52,6 @@
;; |'f8' ;; |'f8'
;; |'f9' ;; |'f9'
;; |'f10 ;; |'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-RIGHT
;; | ARROW-LEFT ;; | ARROW-LEFT
;; | ARROW-UP ;; | ARROW-UP
@ -105,31 +96,40 @@
(:text t)) (:text t))
(defrule keybindings-arrow-right "right" (defrule keybindings-arrow-right "right"
(:constant "key-arrow-right")) (:constant "right")
(:function string-upcase))
(defrule keybindings-arrow-left "left" (defrule keybindings-arrow-left "left"
(:constant "key-arrow-left")) (:constant "left")
(:function string-upcase))
(defrule keybindings-arrow-up "up" (defrule keybindings-arrow-up "up"
(:constant "key-arrow-up")) (:constant "up")
(:function string-upcase))
(defrule keybindings-arrow-down "down" (defrule keybindings-arrow-down "down"
(:constant "key-arrow-down")) (:constant "down")
(:function string-upcase))
(defrule keybindings-key-home "home" (defrule keybindings-key-home "home"
(:constant "key-home")) (:constant "home")
(:function string-upcase))
(defrule keybindings-key-end "end" (defrule keybindings-key-end "end"
(:constant "key-end")) (:constant "end")
(:function string-upcase))
(defrule keybindings-key-next-page "npage" (defrule keybindings-key-next-page "npage"
(:constant "key-next-page")) (:constant "page-down")
(:function string-upcase))
(defrule keybindings-key-previous-page "ppage" (defrule keybindings-key-previous-page "ppage"
(:constant "key-previous-page")) (:constant "page-up")
(:function string-upcase))
(defrule keybindings-key-delete-next-char "dc" (defrule keybindings-key-delete-next-char "dc"
(:constant "key-delete-char")) (:constant "delete-char")
(:function string-upcase))
(defrule keybindings-non-printable-key (defrule keybindings-non-printable-key
(or "f10" (or "f10"
@ -142,15 +142,13 @@
"f7" "f7"
"f8" "f8"
"f9" "f9"
"key-arrow-right" "right"
"key-arrow-left" "left"
"key-arrow-up" "up"
"key-arrow-down" "down"
"key-home" "home"
"key-end" "end"
"key-next-page" "delete-char"
"key-previous-page"
"key-delete-char"
keybindings-arrow-right keybindings-arrow-right
keybindings-arrow-left keybindings-arrow-left
keybindings-arrow-up keybindings-arrow-up
@ -523,19 +521,17 @@ understand"
(function-name key))) (function-name key)))
((string= key "^J") ((string= key "^J")
(_ "Enter")) (_ "Enter"))
((or (string= key "KEY-DELETE-CHAR") ((or (string= key "DELETE-CHAR")
(string= key "DC")) (string= key "DC"))
(_ "Delete")) (_ "Delete"))
((or (string= key "KEY-NEXT-PAGE") ((string= key "PAGE-DOWN")
(string= key "NPAGE"))
(_ "Page-up")) (_ "Page-up"))
((or (string= key "KEY-PREVIOUS-PAGE") ((string= key "PAGE-UP")
(string= key "PPAGE"))
(_ "Page-down")) (_ "Page-down"))
((or (string= key "KEY-ARROW-DOWN") ((or (string= key "ARROW-DOWN")
(string= key "UP")) (string= key "UP"))
(_ "Arrow up")) (_ "Arrow up"))
((or (string= key "KEY-ARROW-UP") ((or (string= key "ARROW-UP")
(string= key "DOWN")) (string= key "DOWN"))
(_ "Arrow down")) (_ "Arrow down"))
(t (t

53
src/line-oriented-window.lisp
View File

@ -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))) (window-height (min (truncate (* 0.9 (win-height screen)))
(+ (max (length text-lines) (+ (max (length text-lines)
+min-shown-win-height+) +min-shown-win-height+)
2))) 2)))
(window-x (truncate (- (* 0.5 (win-width screen)) (window-x (truncate (- (* 0.5 (win-width screen))
(* 0.5 window-width)))) (* 0.5 window-width))))
(window-y (truncate (- (* 0.5 (win-height screen)) (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) (win-move high-level-window window-x window-y)
(setf (rows high-level-window) (setf (rows high-level-window)
(loop (loop
for text in text-lines for text in text-lines
for fields in all-fields for fields in all-fields
collect collect
(make-instance 'line (make-instance 'line
:fields fields :fields fields
:normal-text text :normal-text text
:selected-text text :selected-text text
:normal-bg bg :normal-bg bg
:normal-fg fg :normal-fg fg
:selected-bg fg :selected-bg fg
:selected-fg bg))) :selected-fg bg)))
(select-row high-level-window 0) (select-row high-level-window 0)
(draw) (draw)
(loop named inner (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)) while (not (event-quit-blocking-list-dialog-window-p c))
do do
(cond (cond
((string= c :key-arrow-up) ((string= c :up)
(unselect-all high-level-window) (unselect-all high-level-window)
(row-move high-level-window -1)) (row-move high-level-window -1))
((string= c :key-arrow-down) ((string= c :down)
(unselect-all high-level-window) (unselect-all high-level-window)
(row-move high-level-window 1)) (row-move high-level-window 1))
((string= c "^J") ((string= c "^J")
(let ((selected-fields (selected-row-fields high-level-window)) (let ((selected-fields (selected-row-fields high-level-window))
(selected-text (selected-text (selected-row high-level-window)))) (selected-text (selected-text (selected-row high-level-window))))
(when callback (when callback
(funcall callback selected-text selected-fields))))) (funcall callback selected-text selected-fields)))))
(draw)) (draw))
(win-close high-level-window)))) (win-close high-level-window))))

28
src/tui-utils.lisp
View File

@ -96,17 +96,23 @@ as argument `complex-string'."
(length (complex-char-array complex-string))) (length (complex-char-array complex-string)))
(defun decode-key-event (event &key (convert-symbol-to-string t)) (defun decode-key-event (event &key (convert-symbol-to-string t))
(let* ((key (croatoan:event-key event)) (labels ((decode-event (key)
(decoded-event (cond (cond
((characterp key) ((characterp key)
(key-to-string key)) (key-to-string key))
((symbolp key) ((symbolp key)
(if convert-symbol-to-string (if convert-symbol-to-string
(symbol-name key) (string-upcase (symbol-name key))
key)) key))
(t ((croatoan:key-p key)
(error (_ "Unknown key event ~a") key))))) (decode-event (croatoan:key-name key)))
(values decoded-event 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) (defun colorize-tree-element (color-map annotated-element)
"Colormap is an alist like: "Colormap is an alist like:

1
tinmop.asd
View File

@ -201,3 +201,4 @@
;; (push :debug-sql *features*) ;; (push :debug-sql *features*)
;; (push :debug-gemini-request *features*) ;; (push :debug-gemini-request *features*)
;; (push :debug-json-rpc *features*) ;; (push :debug-json-rpc *features*)
;; (push :debug-croatoan-events *features*)