diff --git a/docs/default-keybindings.md b/docs/default-keybindings.md index c3145a20d..416ef3086 100644 --- a/docs/default-keybindings.md +++ b/docs/default-keybindings.md @@ -1,20 +1,20 @@ ## Move | Command | Key bindings | Documentation | |---------------------------------------------------------------------------------------------------------------|---------------|-------------------------------------------------------| -| [next-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L66) | C-n, Down | Move the cursor to next line. | +| [next-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L66) | Down, C-n | Move the cursor to next line. | | [next-logical-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L73) | | Move the cursor to the next logical line. | -| [previous-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L80) | C-p, Up | Move the cursor to the previous line. | +| [previous-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L80) | Up, C-p | Move the cursor to the previous line. | | [previous-logical-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L84) | | Move the cursor to the previous logical line. | -| [forward-char](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L88) | C-f, Right | Move the cursor to the next character. | -| [backward-char](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L94) | C-b, Left | Move the cursor to the previous character. | -| [move-to-beginning-of-buffer](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L99) | M-<, C-Home | Move the cursor to the beginning of the buffer. | -| [move-to-end-of-buffer](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L104) | M->, C-End | Move the cursor to the end of the buffer. | -| [move-to-beginning-of-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L109) | C-a, Home | Move the cursor to the beginning of the line. | +| [forward-char](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L88) | Right, C-f | Move the cursor to the next character. | +| [backward-char](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L94) | Left, C-b | Move the cursor to the previous character. | +| [move-to-beginning-of-buffer](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L99) | C-Home, M-< | Move the cursor to the beginning of the buffer. | +| [move-to-end-of-buffer](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L104) | C-End, M-> | Move the cursor to the end of the buffer. | +| [move-to-beginning-of-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L109) | Home, C-a | Move the cursor to the beginning of the line. | | [move-to-beginning-of-logical-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L125) | | Move the cursor to the beginning of the logical line. | -| [move-to-end-of-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L129) | C-e, End | Move the cursor to the end of the line. | +| [move-to-end-of-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L129) | End, C-e | Move the cursor to the end of the line. | | [move-to-end-of-logical-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L135) | | Move the cursor to the end of the logical line. | -| [next-page](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L139) | C-v, PageDown | Move the cursor to the next page by one page. | -| [previous-page](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L147) | M-v, PageUp | Move the cursor to the previous page by one page. | +| [next-page](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L139) | PageDown, C-v | Move the cursor to the next page by one page. | +| [previous-page](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L147) | PageUp, M-v | Move the cursor to the previous page by one page. | | [next-page-char](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L155) | C-x ] | Move the cursor to the next page character (^L). | | [previous-page-char](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L165) | C-x [ | Move the cursor to the previous page character (^L). | | [goto-line](https://github.com/lem-project/lem/blob/main/src/commands/move.lisp#L169) | M-g | Move the cursor to the specified line number. | @@ -26,8 +26,8 @@ | [newline](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L100) | Return | Insert a new line. | | [open-line](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L104) | C-o | Insert a new line without moving the cursor position. | | [quoted-insert](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L108) | C-q | Insert the next entered key (including control characters). | -| [delete-next-char](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L123) | C-d, Delete | Delete the next character. | -| [delete-previous-char](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L146) | C-h, Backspace | Delete the previous character. | +| [delete-next-char](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L123) | Delete, C-d | Delete the next character. | +| [delete-previous-char](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L146) | Backspace, C-h | Delete the previous character. | | [copy-region](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L160) | M-w | Copy the text of region. | | [copy-region-to-clipboard](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L166) | | Copy the selected text to the clipboard. | | [kill-region](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L178) | C-w | Kill the text of region. | @@ -49,7 +49,7 @@ current line. | [delete-indentation](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L356) | M-^ | Merge the current line with the previous line. | | [transpose-characters](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L376) | C-t | Swaps the characters before and after the cursor. | | [undo](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L393) | C-\ | Undo. | -| [redo](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L400) | C-_, C-/ | Redo. | +| [redo](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L400) | C-/, C-_ | Redo. | | [delete-trailing-whitespace](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L427) | | Removes all end-of-line and end-of-buffer whitespace from the current buffer. | | [mark-and-forward-char](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L482) | Shift-Right | Sets a mark if none is set, then moves cursor forward by n characters | | [mark-and-backward-char](https://github.com/lem-project/lem/blob/main/src/commands/edit.lisp#L488) | Shift-Left | Sets a mark if none is set, then moves cursor backward by n characters | @@ -59,17 +59,17 @@ current line. ## Mark | Command | Key bindings | Documentation | |--------------------------------------------------------------------------------------------------|--------------|----------------------------------------------------------------| -| [mark-set](https://github.com/lem-project/lem/blob/main/src/commands/mark.lisp#L15) | C-@, C-Space | Sets a mark at the current cursor position. | +| [mark-set](https://github.com/lem-project/lem/blob/main/src/commands/mark.lisp#L15) | C-Space, C-@ | Sets a mark at the current cursor position. | | [exchange-point-mark](https://github.com/lem-project/lem/blob/main/src/commands/mark.lisp#L23) | C-x C-x | Exchange the current cursor position with the marked position. | | [mark-set-whole-buffer](https://github.com/lem-project/lem/blob/main/src/commands/mark.lisp#L31) | C-x h | Select the whole buffer as a region. | ## Word | Command | Key bindings | Documentation | |--------------------------------------------------------------------------------------------------|---------------------------------|-----------------------------------------------------------| -| [forward-word](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L84) | M-f, C-Right | Move to cursor to next word. | -| [previous-word](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L88) | M-b, C-Left | Move to cursor to previous word | -| [delete-word](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L92) | M-d, C-Delete | Delete the next word. | -| [backward-delete-word](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L106) | M-C-h, M-Backspace, C-Backspace | Delete the previous word. | +| [forward-word](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L84) | C-Right, M-f | Move to cursor to next word. | +| [previous-word](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L88) | C-Left, M-b | Move to cursor to previous word | +| [delete-word](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L92) | C-Delete, M-d | Delete the next word. | +| [backward-delete-word](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L106) | C-Backspace, M-Backspace, M-C-h | Delete the previous word. | | [downcase-region](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L137) | C-x C-l | Replaces the selected region with a downcase. | | [uppercase-region](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L141) | C-x C-u | Replaces the selected region with a uppercase. | | [capitalize-word](https://github.com/lem-project/lem/blob/main/src/commands/word.lisp#L162) | M-c | Replace the following word with capital-case. | @@ -89,7 +89,7 @@ current line. | [backward-list](https://github.com/lem-project/lem/blob/main/src/commands/s-expression.lisp#L49) | M-C-p | Move the cursor to the backward list. | | [down-list](https://github.com/lem-project/lem/blob/main/src/commands/s-expression.lisp#L53) | M-C-d | Move the cursor to the inner expression. | | [up-list](https://github.com/lem-project/lem/blob/main/src/commands/s-expression.lisp#L57) | M-C-u | Move the cursor to the outer expression. | -| [mark-sexp](https://github.com/lem-project/lem/blob/main/src/commands/s-expression.lisp#L62) | M-C-@, M-C-Space | Select the forward expression as a region. | +| [mark-sexp](https://github.com/lem-project/lem/blob/main/src/commands/s-expression.lisp#L62) | M-C-Space, M-C-@ | Select the forward expression as a region. | | [kill-sexp](https://github.com/lem-project/lem/blob/main/src/commands/s-expression.lisp#L72) | M-C-k | Kill the forward expression as a region. | | [transpose-sexps](https://github.com/lem-project/lem/blob/main/src/commands/s-expression.lisp#L81) | M-C-t | Swaps the expression before and after the cursor. | @@ -152,7 +152,7 @@ Supported modes include: c-mode with clang-format, go-mode with gofmt, js-mode a | [recenter](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L120) | C-l | Scroll so that the cursor is in the middle. | | [split-active-window-vertically](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L134) | C-x 2 | Split the current window vertically. | | [split-active-window-horizontally](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L140) | C-x 3 | Split the current window horizontally. | -| [next-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L146) | C-x o, M-o | Go to the next window. | +| [next-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L146) | M-o, C-x o | Go to the next window. | | [previous-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L158) | M-O | | | [switch-to-last-focused-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L161) | | Go to the window that was last in focus. | | [window-move-down](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L169) | | Go to the window below. | @@ -160,14 +160,14 @@ Supported modes include: c-mode with clang-format, go-mode with gofmt, js-mode a | [window-move-right](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L179) | | Go to the window on the right. | | [window-move-left](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L184) | | Go to the window on the left. | | [delete-other-windows](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L189) | C-x 1 | Delete all other windows. | -| [delete-active-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L214) | C-x 0, M-q | Delete the active window. | +| [delete-active-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L214) | M-q, C-x 0 | Delete the active window. | | [quit-active-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L222) | | Quit the active window. This is a command for a popped-up window. | | [grow-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L227) | C-x ^ | Grow the window's height. | | [shrink-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L235) | C-x C-z | Shrink the window's height. | | [grow-window-horizontally](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L243) | C-x } | Grow the window's width. | | [shrink-window-horizontally](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L251) | C-x { | Shrink the window's width. | -| [scroll-down](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L262) | C-Down, M-Down | Scroll down. | -| [scroll-up](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L276) | C-Up, M-Up | Scroll up. | +| [scroll-down](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L262) | M-Down, C-Down | Scroll down. | +| [scroll-up](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L276) | M-Up, C-Up | Scroll up. | | [find-file-next-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L288) | C-x 4 f | Open a file in another window. Split the screen vertically if needed. | | [read-file-next-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L289) | C-x 4 r | Read a file in another window. | | [select-buffer-next-window](https://github.com/lem-project/lem/blob/main/src/commands/window.lisp#L290) | C-x 4 b | Select a buffer in another window. | @@ -188,11 +188,11 @@ Supported modes include: c-mode with clang-format, go-mode with gofmt, js-mode a | Command | Key bindings | Documentation | |----------------------------------------------------------------------------------------------|--------------|------------------------------------------------------------------------------| | [describe-key](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L15) | C-x ? | Tell what is the command associated to a keybinding. | -| [describe-bindings](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L44) | | Describe the bindings of the buffer's current major mode. | -| [list-modes](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L66) | | Output all available major and minor modes. | -| [describe-mode](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L87) | | Show information about current major mode and enabled minor modes. | -| [apropos-command](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L113) | | Find all symbols in the running Lisp image whose names match a given string. | -| [lem-version](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L124) | | Display Lem's version. | +| [describe-bindings](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L43) | | Describe the bindings of the buffer's current major mode. | +| [list-modes](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L65) | | Output all available major and minor modes. | +| [describe-mode](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L86) | | Show information about current major mode and enabled minor modes. | +| [apropos-command](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L112) | | Find all symbols in the running Lisp image whose names match a given string. | +| [lem-version](https://github.com/lem-project/lem/blob/main/src/commands/help.lisp#L123) | | Display Lem's version. | ## Font | Command | Key bindings | Documentation | @@ -210,7 +210,7 @@ Supported modes include: c-mode with clang-format, go-mode with gofmt, js-mode a | [exit-lem](https://github.com/lem-project/lem/blob/main/src/commands/other.lisp#L54) | C-x C-c | Ask for modified buffers before exiting lem. | | [quick-exit](https://github.com/lem-project/lem/blob/main/src/commands/other.lisp#L67) | | Exit the lem job and kill it. | | [execute-command](https://github.com/lem-project/lem/blob/main/src/commands/other.lisp#L111) | M-x | Read a command name, then read the ARG and call the command. | -| [show-context-menu](https://github.com/lem-project/lem/blob/main/src/commands/other.lisp#L126) | Shift-F10, M-h | | +| [show-context-menu](https://github.com/lem-project/lem/blob/main/src/commands/other.lisp#L126) | M-h, Shift-F10 | | | [load-library](https://github.com/lem-project/lem/blob/main/src/commands/other.lisp#L132) | | Load the Lisp library named NAME. | ## Frame diff --git a/extensions/bookmark/bookmark.lisp b/extensions/bookmark/bookmark.lisp index cc17f0fd5..375ad71db 100644 --- a/extensions/bookmark/bookmark.lisp +++ b/extensions/bookmark/bookmark.lisp @@ -58,7 +58,7 @@ Use (DESCRIBE (FIND-PACKAGE \"LEM-BOOKMARK\")) to find all available commands.") If the file is a relative path, it is relative to LEM-HOME.") (defvar *keymap* - (make-keymap :name "Bookmark keymap") + (make-keymap :description "Bookmark keymap") "Keymap for bookmark related commands.") (defvar *bookmark-table* (make-hash-table :test #'equal)) diff --git a/extensions/copilot/copilot.lisp b/extensions/copilot/copilot.lisp index 03e6dfd3d..bbb061f4f 100644 --- a/extensions/copilot/copilot.lisp +++ b/extensions/copilot/copilot.lisp @@ -238,7 +238,7 @@ (defvar *inline-completion-request* nil) (defvar *completion-canceled* nil) -(defvar *copilot-completion-keymap* (make-keymap :name "Copilot Completion")) +(defvar *copilot-completion-keymap* (make-keymap :description "Copilot Completion")) (define-key *copilot-completion-keymap* "Tab" 'copilot-accept-suggestion) (define-key *copilot-completion-keymap* 'copilot-next-suggestion 'copilot-next-suggestion) @@ -246,7 +246,7 @@ (defun find-copilot-completion-command (key) (lookup-keybind key - :keymaps (append (lem-core::all-keymaps) + :keymaps (append (lem-core::other-keymaps) (list *copilot-completion-keymap*)))) (defun search-preffix (str1 str2) diff --git a/extensions/lem-dashboard/lem-dashboard.lisp b/extensions/lem-dashboard/lem-dashboard.lisp index 96c01b229..895ee853b 100644 --- a/extensions/lem-dashboard/lem-dashboard.lisp +++ b/extensions/lem-dashboard/lem-dashboard.lisp @@ -17,7 +17,7 @@ (defvar *dashboard-buffer-name* "*dashboard*") (defvar *dashboard-enable* t) -(defvar *dashboard-mode-keymap* (make-keymap :name '*dashboard-mode-keymap* :parent *global-keymap*)) +(defvar *dashboard-mode-keymap* (make-keymap :description '*dashboard-mode-keymap*)) (defvar *dashboard-layout* nil "List of dashboard-item instances; will be drawn in order.") diff --git a/extensions/living-canvas/living-canvas.lisp b/extensions/living-canvas/living-canvas.lisp index ef80b6901..9434b60af 100644 --- a/extensions/living-canvas/living-canvas.lisp +++ b/extensions/living-canvas/living-canvas.lisp @@ -41,7 +41,7 @@ "Current overlay used to highlight the selected function in source view.") (defvar *living-canvas-keymap* - (lem:make-keymap :name '*living-canvas-keymap*)) + (lem:make-keymap :description '*living-canvas-keymap*)) ;;; Attributes diff --git a/extensions/skk-mode/skk-mode.lisp b/extensions/skk-mode/skk-mode.lisp index 014ddad5b..a63c86584 100644 --- a/extensions/skk-mode/skk-mode.lisp +++ b/extensions/skk-mode/skk-mode.lisp @@ -49,7 +49,7 @@ ;;; Keymap (defvar *skk-mode-keymap* - (make-keymap :name '*skk-mode-keymap*) + (make-keymap :description '*skk-mode-keymap*) "Keymap for SKK mode. Binds printable characters for Japanese input.") ;; Bind all lowercase letters to skk-self-insert diff --git a/extensions/transient/demo.lisp b/extensions/transient/demo.lisp new file mode 100644 index 000000000..7c8bc9a17 --- /dev/null +++ b/extensions/transient/demo.lisp @@ -0,0 +1,77 @@ +(in-package :lem/transient) + +(defvar *demo-language* + "lisp" + "a demo variable that stays in sync with an infix.") + +(define-transient *demo-keymap* + :display-style :row + (:keymap + :display-style :column + :description "file operations" + (:key "o" :suffix 'demo-open :description "demo open") + (:key "s" :suffix 'demo-save :description "demo save (disabled)" :active-p nil) + (:key "w" :suffix 'demo-write :description "demo write") + (:key "x" + :suffix (:keymap + (:key "p" :suffix 'demo-pdf :description "pdf") + (:key "h" :suffix 'demo-html :description "html") + (:key "m" :suffix 'demo-md :description "markdown") + (:key "b" :behavior :back :description "back")) + :description "export format")) + (:keymap + :display-style :column + :description "edit operations" + (:key "c" :suffix 'demo-copy) + (:key "v" :suffix 'demo-paste) + (:key "u" :suffix 'demo-undo) + (:key "q" :behavior :cancel :description "quit")) + (:key "f" + :suffix (:keymap + (:key "g" :suffix 'demo-grep :description "grep") + (:key "f" :suffix 'demo-find :description "find") + (:key "r" :suffix 'demo-replace :description "replace")) + :description "search menu") + (:key "t" + :suffix (:keymap + :display-style :row + (:keymap + :description "languages" + (:key "l" + :type :choice + :id :mode + :choices-func (progn + ;; something meaningless + (+ 1 1) + ;; then return value + (list "lisp" "python" "js")) + :value "python" + :description "mode")) + (:keymap + :description "editor" + (:key "v" + :type :choice + :choices '("vim" "emacs") + :description "keys"))) + :description "langs demo") + (:key "a" + :type :choice + :choices '("value1" "value2" "value3") + :description "multi-value infix") + (:key "s" + :type :choice + :id :synced-infix + :choices '("lisp" "python" "js") + :variable '*demo-language* + :description "variable-synced infix") + (:key "R" :suffix 'demo-run :description "run with mode") + (:key "T" :type 'toggle :value t :suffix 'demo-toggle :description "demo toggle") + (:key "e e" :type 'toggle :value t :suffix 'demo-toggle :description "another demo toggle") + (:key "e a" :type 'toggle :value t :suffix 'demo-toggle :description "and another demo toggle")) + +(define-command demo-run () () + (let ((mode-prefix (find-prefix-by-id *demo-keymap* :mode))) + (message "mode thing value: ~A" (prefix-value mode-prefix)) + (message "synced var value: ~A" *demo-language*))) + +(define-key *global-keymap* "C-c t" *demo-keymap*) \ No newline at end of file diff --git a/extensions/transient/keymap.lisp b/extensions/transient/keymap.lisp new file mode 100644 index 000000000..d3e633869 --- /dev/null +++ b/extensions/transient/keymap.lisp @@ -0,0 +1,358 @@ +(in-package :lem/transient) + +(defun resolve-transient-keymap (&optional keymap) + (let ((active-modes (all-active-modes (current-buffer)))) + (cond + ((and keymap (keymap-show-p keymap)) + keymap) + ((loop for mode in active-modes + for mode-keymap = (mode-transient-keymap mode) + when mode-keymap + return (if (and keymap (keymap-contains-p mode-keymap keymap)) + keymap + mode-keymap))) + (*transient-always-show* + keymap)))) + +(defmethod keymap-activate ((keymap keymap)) + (let ((resolved (resolve-transient-keymap keymap))) + (if resolved + (show-transient resolved) + (hide-transient)))) + +(defgeneric mode-transient-keymap (mode) + (:documentation "returns the keymap to be passed to show-transient.") + (:method ((mode mode)) + nil)) + +(defmacro add-property (class-name properties-accessor property-name &optional default-value) + "define - getter and setter methods. + +the getter retrieves from PROPERTIES-ACCESSOR using :PROPERTY-NAME as key. +the setter stores directly." + (let* ((keyword (intern (symbol-name property-name) :keyword)) + (getter-name (intern (format nil "~A-~A" class-name property-name) :lem/transient)) + (obj-sym (gensym "OBJ"))) + `(progn + (defmethod ,getter-name ((,obj-sym ,class-name)) + ,(if default-value + `(getf (,properties-accessor ,obj-sym) ,keyword ,default-value) + `(getf (,properties-accessor ,obj-sym) ,keyword))) + (defmethod (setf ,getter-name) (val (,obj-sym ,class-name)) + (setf (getf (,properties-accessor ,obj-sym) ,keyword) val))))) + +;; some stuff we need for working with "transient keymaps" +(add-property keymap keymap-properties show-p nil) +(add-property keymap keymap-properties display-style :row) +(add-property prefix prefix-properties show-p t) +(add-property prefix prefix-properties id) +;; TODO: it would be better to store the parsed key sequence instead of the stringified one and work with that. +(add-property prefix prefix-properties display-key) + +(defun find-prefix-by-id (keymap id) + (labels ((check-prefix (node) + (if (eql (prefix-id node) id) + node + (let ((suffix (prefix-suffix node))) + (when (or (typep suffix 'keymap) + (typep suffix 'prefix)) + (search-node suffix))))) + (search-node (node) + (cond ((typep node 'keymap) + (dolist (p (keymap-prefixes node)) + (let ((res (check-prefix p))) + (when res (return-from search-node res)))) + (dolist (child (keymap-children node)) + (let ((res (search-node child))) + (when res (return-from search-node res))))) + ((typep node 'prefix) + (check-prefix node))))) + (search-node keymap))) + +(defun keymap-contains-p (keymap target) + "return T if KEYMAP contains TARGET as a direct or indirect child." + (labels ((search-node (node) + (cond ((eq node target) t) + ((typep node 'keymap) + (dolist (p (keymap-prefixes node)) + (when (search-node p) + (return-from search-node t))) + (dolist (child (keymap-children node)) + (when (search-node child) + (return-from search-node t)))) + ((typep node 'prefix) + (let ((suffix (prefix-suffix node))) + (when (or (typep suffix 'keymap) + (typep suffix 'prefix)) + (search-node suffix))))))) + (search-node keymap))) + +(defclass infix (prefix) + ((variable + :accessor infix-variable + :initarg :variable + :initform nil))) + +(defclass choice (infix) + ((choices + :accessor prefix-choices + :initform nil) + (value)) + (:documentation "a prefix that may take on different values.")) + +(defclass toggle (infix) + ((value :initform nil)) + (:documentation "a boolean infix.")) + +(defmethod prefix-value ((prefix prefix)) + (let ((var (infix-variable prefix))) + (if var + (symbol-value var) + (slot-value prefix 'value)))) + +(defmethod prefix-value ((prefix choice)) + (let ((var (infix-variable prefix))) + (if var + (symbol-value var) + (if (slot-boundp prefix 'value) + (slot-value prefix 'value) + (car (prefix-choices prefix)))))) + +(defmethod (setf prefix-value) (new-value (prefix prefix)) + (let ((var (infix-variable prefix))) + (if var + (setf (symbol-value var) new-value) + (setf (slot-value prefix 'value) new-value)))) + +;; infixes dont modify the keymap menu, we drop the key and dont append it to the recorded keyseq +(defmethod prefix-behavior ((prefix infix)) + :drop) + +(defmethod prefix-suffix ((choice choice)) + (labels ((suffix () + (let* ((choices (prefix-choices choice)) + (current-value (prefix-value choice)) + (new-value)) + (with-last-read-key-sequence + (setf new-value + (handler-case + (prompt-for-string "new value: " + :initial-value current-value + :completion-function (lambda (x) + choices)) + (editor-abort () + current-value)))) + (when new-value + (setf (prefix-value choice) new-value))))) + #'suffix)) + +(defmethod prefix-suffix ((prefix toggle)) + (labels ((suffix () + (setf (prefix-value prefix) (not (prefix-value prefix))))) + #'suffix)) + +(defmacro define-transient (name &body bindings) + `(defvar ,name (parse-transient ',bindings))) + +(defmacro define-prefix (name &body args) + `(defvar ,name (parse-prefix ',args))) + +(defmacro define-transient-key (name keymap key &body args) + `(defvar ,name + (assign-transient-key ,keymap ,key (list ,@args)))) + +(defun parse-transient-method (object key val method-name) + "assign a keymap/prefix property using KEY with value VAL to OBJECT. + +OBJECT can be a keymap or a prefix. +METHOD-NAME is a string prefix (\"KEYMAP\" or \"PREFIX\") used to resolve the setter. +resolution order is: +1. if KEY ends in \"-func\", define a method on OBJECT via eql so that the accessor returns VAL at runtime. +2. if a (setf METHOD-NAME-KEY) function exists, call it with (eval VAL). +3. otherwise store KEY/VAL in the object's properties plist." + (let* ((key-string (string key)) + (key-method (intern (format nil "~A-~A" method-name key-string) :lem/transient)) + (len (length key-string)) + (func-str "-func")) + (cond ((and (> len (length func-str)) + (string-equal func-str (subseq key-string (- len (length func-str))))) + (let* ((prefix-key-string (subseq key-string 0 (- len (length func-str)))) + (key-method (intern (format nil "~A-~A" method-name prefix-key-string) + :lem/transient))) + (eval `(defmethod ,key-method ((object (eql ,object))) + ,val)))) + ((fboundp key-method) + (funcall (fdefinition (list 'setf key-method)) (eval val) object)) + (t + (when (slot-exists-p object 'properties) + (setf (getf (slot-value object 'properties) key) (eval val))))))) + +(defun parse-transient (bindings) + "parse BINDINGS and return a new keymap with \"transient\" functionality. + +BINDINGS is a list. an element can be: +- keyword symbol - set a keymap-level property (e.g. :description \"my menu\"). +- symbol - if the symbol's value is a prefix, add it as a prefix. + if its a keymap, add it as a child keymap. +- (:keymap ...) - recursively parse the rest as a sub-keymap and add it as a child. +- (:key KEY ...) - bind KEY in the keymap. forwarded to `assign-transient-key'. + +the returned keymap has `:show-p' set to `t' so it is displayed in the popup." + (let ((keymap (make-keymap))) + (setf (keymap-show-p keymap) t) + (loop for tail = bindings then (cdr tail) + while tail + do (let ((binding (car tail))) + (cond + ;; inline property + ((keywordp binding) + (let ((val (second tail))) + (parse-transient-method keymap binding val "KEYMAP") + ;; advance another cell because we're already consumed it (second tail) + (setf tail (cdr tail)))) + ;; if its a symbol we evaluate it as a variable that might be a prefix + ((and (symbolp binding) (typep (symbol-value binding) 'prefix)) + (keymap-add-prefix keymap (symbol-value binding))) + ;; if its a symbol and evaluates to a keymap, we add it as a child + ((and (symbolp binding) (typep (symbol-value binding) 'keymap)) + (keymap-add-child keymap (symbol-value binding))) + ;; direct child keymap (:keymap ...) + ((eq (car binding) :keymap) + (let ((sub-map (parse-transient (cdr binding)))) + (keymap-add-child keymap sub-map t))) + ;; key binding (:key ...) + ((eq (car binding) :key) + (assign-transient-key keymap (second binding) (cddr binding)))))) + keymap)) + +(defun parse-prefix (args) + "parse the plist ARGS and return a new prefix instance. + +candidates for ARGS: +- `:key' the key string that activates this prefix (required). +- `:type' symbol of class to create an instance from (default: `prefix'). +- `:variable' for infix subclasses, the lisp variable to sync with. +- `:description' label shown in the popup. +- `:suffix' command, lambda or keymap to invoke when the key is pressed. +any other keyword is forwarded to `parse-transient-method'. + +only single-key sequences are supported here. for multi-key sequence behaving as a single-prefix +use `assign-transient-key' instead." + (let* ((prefix-type + (intern (symbol-name + (if (getf args :type) + (eval (getf args :type)) + 'prefix)) + :lem/transient)) + (key (getf args :key)) + (prefix (make-instance prefix-type)) + (parsed-key (parse-keyspec key))) + (setf (prefix-key prefix) (car parsed-key)) + (setf (prefix-suffix prefix) nil) + (loop for (key value) on args by 'cddr + do (let ((final-value) + (should-set t)) + (cond + ((and (listp value) (eq (car value) :keymap)) + (setf final-value (parse-transient (cdr value)))) + ((eq key :variable) + (setf (infix-variable prefix) (eval value)) + (setf should-set nil)) + ((eq key :type) + (setf should-set nil)) + ;; key has already been handled + ((eq key :key) + (setf should-set nil)) + (t + (setf final-value value))) + (when should-set + (parse-transient-method + prefix + key + final-value + "PREFIX")))) + prefix)) + +(defun assign-transient-key (keymap key &optional args) + "add or replace the binding for KEY in transient KEYMAP. + +KEY is a key-spec string (e.g. \"C-c t\"). +ARGS is a plist of keyword properties forwarded to `parse-transient-method'. +recognised keys are the same as in a (:key ...) entry in `parse-prefix'. + +if a binding for KEY already exists it is removed before the new one is added, so repeated +calls do not accumulate duplicate entries." + ;; redefine in place so repeated calls do not accumulate duplicate entries for the same key sequence. + (undefine-key keymap key) + (let* ((prefix-type (intern (symbol-name (if (getf args :type) + (eval (getf args :type)) + 'prefix)) + :lem/transient)) + (prefix (make-instance prefix-type)) + (last-keymap keymap)) + (let ((parsed-key (parse-keyspec key))) + ;; store the full key string for multi-key bindings + (when (cdr parsed-key) + (setf (prefix-display-key prefix) key)) + ;; we need to create intermediate prefixes if the key is longer than one + (loop + for cell on parsed-key + for i from 0 + for lastp = (null (cdr cell)) + for current-key = (car cell) + do (let ((current-prefix + (if lastp + prefix + ;; reuse existing intermediate prefix with same key, or create new one + (let ((existing (find + current-key + (keymap-prefixes last-keymap) + :test (lambda (k child) + (and (prefix-intermediate-p child) + (equal + k + (prefix-key child))))))) + (if existing + (progn + (setf last-keymap (prefix-suffix existing)) + existing) + (let* ((new-prefix (make-instance 'prefix)) + (new-keymap (make-keymap))) + (keymap-add-prefix last-keymap new-prefix t) + (setf (prefix-suffix new-prefix) new-keymap) + (setf (prefix-intermediate-p new-prefix) t) + (setf (keymap-show-p new-keymap) t) + (setf last-keymap new-keymap) + new-prefix)))))) + (setf (prefix-key current-prefix) current-key))) + (keymap-add-prefix last-keymap prefix t) + ;; sometimes the suffix will not be set (e.g. prefix-type is :choice). we + ;; initialize it to nil to avoid unbound errors. + (setf (prefix-suffix prefix) nil) + (loop for (key value) on args by 'cddr + do (let ((final-value) + (should-set t)) + (cond + ;; if the suffix is a keymap we need to parse recursively + ((and (listp value) (eq (car value) :keymap)) + (setf final-value (parse-transient (cdr value)))) + ;; variable syncing: set the variable slot on the infix + ;; we need a special case for it since its "infix-variable" and + ;; not "prefix-variable" since its a slot in the infix class. + ;; there's probably a nicer way to go about things but this is + ;; just for 'parse-transient' which is designed as a + ;; convenience anyway. + ((eq key :variable) + (setf (infix-variable prefix) (eval value)) + (setf should-set nil)) + ((eq key :type) + (setf should-set nil)) + (t + (setf final-value value))) + (when should-set + (parse-transient-method + prefix + key + final-value + "PREFIX"))))) + prefix)) \ No newline at end of file diff --git a/extensions/transient/lem-transient.asd b/extensions/transient/lem-transient.asd new file mode 100644 index 000000000..2c9413d8c --- /dev/null +++ b/extensions/transient/lem-transient.asd @@ -0,0 +1,6 @@ +(defsystem "lem-transient" + :depends-on ("lem/core") + :components ((:file "transient") + (:file "keymap") + (:file "popup") + (:file "demo"))) \ No newline at end of file diff --git a/extensions/transient/popup.lisp b/extensions/transient/popup.lisp new file mode 100644 index 000000000..a62f3a612 --- /dev/null +++ b/extensions/transient/popup.lisp @@ -0,0 +1,532 @@ +(in-package :lem/transient) + +(defvar *transient-popup-window* + nil) + +(defvar *transient-shown-keymap* + nil + "the last keymap passed to show-transient. used to detect same-keymap redraws and preserve scroll position.") + +(defvar *transient-popup-max-lines* + 10 + "max height of the transient buffer (measured in lines).") + +(defvar *transient-vertical-scroll-amount* + 1 + "number of lines to scroll vertically per step.") + +(defvar *transient-horizontal-scroll-amount* + 5 + "number of columns to scroll horizontally per step.") + +(defparameter *transient-column-separator* + " | " + "string used to separate columns in row layout.") + +(defvar *transient-always-show* + nil + "whether to always show the transient buffer. by default only keymaps that have show-p set are shown.") + +(define-attribute transient-matched-key-attribute + (t + :foreground (attribute-foreground (ensure-attribute 'syntax-string-attribute)))) + +(define-attribute transient-key-attribute + (t + :foreground (attribute-foreground (ensure-attribute 'syntax-function-name-attribute)))) + +(define-attribute transient-title-attribute + (t + :foreground (attribute-foreground (ensure-attribute 'document-header1-attribute)) + :bold (attribute-bold (ensure-attribute 'document-header1-attribute)))) + +(define-attribute transient-separator-attribute + (t + :foreground (attribute-foreground (ensure-attribute 'modeline-inactive)))) + +(define-attribute transient-bracket-attribute + (t + :foreground (attribute-foreground (ensure-attribute 'syntax-string-attribute)))) + +(define-attribute transient-inactive-attribute + (t + :foreground (attribute-foreground (ensure-attribute 'syntax-comment-attribute)) + :background (attribute-background (ensure-attribute 'syntax-comment-attribute)))) + +(define-attribute transient-value-attribute + (t + :foreground (attribute-foreground (ensure-attribute 'syntax-constant-attribute)) + :bold t)) + +;; this keymap has a special behavior. we're overriding its 'keymap-find' below. +(define-transient *transient-mode-keymap* + :display-style :row + (:key "M-Shift-Down" + :suffix 'transient-scroll-down + :behavior :drop + :description "scroll down") + (:key "M-Shift-Up" + :suffix 'transient-scroll-up + :behavior :drop + :description "scroll up") + (:key "M-Shift-Right" + :suffix 'transient-scroll-right + :behavior :drop + :description "scroll right") + (:key "M-Shift-Left" + :suffix 'transient-scroll-left + :behavior :drop + :description "scroll left")) + +(defmethod keymap-find ((keymap (eql *transient-mode-keymap*)) key) + (let ((keyseq (etypecase key + (lem-core::key (list key)) + (list key)))) + ;; the keymap needs to work if any key we defined (e.g. M-S-Down) is the last one in our + ;; current key sequence, because we want these keys to be available in any transient + ;; keymap context + (loop for prefix in (keymap-prefixes keymap) + when (equal (prefix-key prefix) (car (last keyseq))) + return prefix))) + +(define-minor-mode transient-mode + (:name "transient-mode" + :global t + :keymap *transient-mode-keymap*)) + +(defstruct layout-separator + "a visual separator between items.") + +(defstruct layout-item + "a single displayable item (prefix binding)" + key + description + (key-attribute 'transient-key-attribute) + description-attribute) + +(defstruct layout-title + "a title/header for a keymap section." + text) + +(defstruct layout-row + "items arranged horizontally." + items) + +(defstruct layout-column + "items arranged vertically." + items + ;; max key width for even spacing + (key-width 0)) + +(defun get-description (prefix) + "returns a description for an entry that could be a prefix or a keymap." + (let ((desc (prefix-description prefix))) + (if desc + (princ-to-string desc) + (let ((suffix (prefix-suffix prefix))) + (cond ((typep suffix 'keymap) + (princ-to-string (or (keymap-description suffix) "+prefix"))) + ((typep suffix 'prefix) + (or (prefix-description suffix) "+prefix")) + (t (princ-to-string suffix))))))) + +(defun prefix-effective-display-key (prefix) + "return the display key for PREFIX, falling back to one returned by prefix-key." + (or (prefix-display-key prefix) + (princ-to-string (prefix-key prefix)))) + +(defun keymap-contains-via-intermediates-p (keymap target) + "return T if TARGET is reachable from KEYMAP through a sequence of intermediate prefixes." + (dolist (p (keymap-prefixes keymap)) + (when (prefix-intermediate-p p) + (let ((suffix (prefix-suffix p))) + (when (and (typep suffix 'keymap) + (or (eq suffix target) + (keymap-contains-via-intermediates-p suffix target))) + (return t)))))) + +;; TODO: this is hacky +(defun make-key-with-highlight (key-str matched-depth) + "return KEY-STR as highlighted segments if MATCHED-DEPTH > 0. + +MATCHED-DEPTH is the number of key parts (space-separated) to highlight." + (if (and matched-depth (> matched-depth 0)) + (let ((pos 0) + (parts-found 0)) + ;; walk through key-str counting space-separated parts + (loop :for i :from 0 :below (length key-str) + :while (< parts-found matched-depth) + :do (if (char= (char key-str i) #\Space) + (incf parts-found) + (setf pos (1+ i)))) + (if (> pos 0) + (let ((matched (subseq key-str 0 pos)) + (unmatched (subseq key-str pos))) + (list (cons matched 'transient-matched-key-attribute) + (cons unmatched 'transient-key-attribute))) + key-str)) + key-str)) + +(defun make-value-description (prefix) + "build description segments for a prefix that displays its value, e.g. 'desc [value]'." + (let ((desc (get-description prefix)) + (value-str (princ-to-string (prefix-value prefix)))) + (list (cons desc nil) + (cons " " nil) + (cons "[" 'transient-bracket-attribute) + (cons value-str 'transient-value-attribute) + (cons "]" 'transient-bracket-attribute)))) + +(defgeneric prefix-render (prefix &optional matched-depth) + (:documentation "return a layout item that should be displayed for the prefix in the popup. + +MATCHED-DEPTH is the number of key parts (space-separated) to highlight.")) + +(defmethod prefix-render ((prefix prefix) &optional matched-depth) + (let ((key-str (prefix-effective-display-key prefix))) + (make-layout-item + :key (make-key-with-highlight key-str matched-depth) + :description (get-description prefix)))) + +(defun prefix-render-with-value (prefix matched-depth) + (let ((key-str (prefix-effective-display-key prefix))) + (make-layout-item + :key (make-key-with-highlight key-str matched-depth) + :description (make-value-description prefix)))) + +(defmethod prefix-render ((prefix choice) &optional matched-depth) + (prefix-render-with-value prefix matched-depth)) + +(defmethod prefix-render ((prefix toggle) &optional matched-depth) + (prefix-render-with-value prefix matched-depth)) + +(defun find-intermediate-root (active-keymap) + "find the effective root keymap for ACTIVE-KEYMAP by searching from *root-keymap* tree. + +returns the nearest ancestor keymap that reaches ACTIVE-KEYMAP through intermediate prefixes, +or ACTIVE-KEYMAP itself if no such ancestor exists." + (labels ((find-root (keymap) + ;; check if this keymap reaches active-keymap via intermediates + (when (keymap-contains-via-intermediates-p keymap active-keymap) + (return-from find-intermediate-root keymap)) + ;; recurse into prefixes that have keymap suffixes + (dolist (p (keymap-prefixes keymap)) + (let ((suffix (prefix-suffix p))) + (when (typep suffix 'keymap) + (find-root suffix)))) + ;; recurse into child keymaps + (dolist (child (keymap-children keymap)) + (find-root child)))) + (find-root *root-keymap*) + active-keymap)) + +(defmethod prefix-render :around ((prefix prefix) &optional matched-depth) + (let ((item (call-next-method))) + (when item + (unless (prefix-active-p prefix) + (setf (layout-item-key-attribute item) 'transient-inactive-attribute) + (setf (layout-item-description-attribute item) 'transient-inactive-attribute))) + item)) + +(defun generate-layout (keymap &optional active-keymap) + "generate layout from keymap structure. + +prefixes always display vertically in their own column. +nested keymaps are arranged based on display-style (:row or :column). +prefixes marked as :intermediate-p are flattened and shown with concatenated keys." + (let ((prefix-items) + (keymap-layouts)) + (labels ((collect-prefix (node &optional (matched-depth 0)) + (when (prefix-show-p node) + (if (prefix-intermediate-p node) + (let* ((suffix (prefix-suffix node)) + (new-depth (if (and active-keymap + (typep suffix 'keymap) + (or (eq suffix active-keymap) + (keymap-contains-via-intermediates-p + suffix active-keymap))) + (1+ matched-depth) + matched-depth))) + (if (typep suffix 'keymap) + (dolist (p (keymap-prefixes suffix)) + (collect-prefix p new-depth)) + (push (prefix-render node new-depth) prefix-items))) + (push (prefix-render + node + (when (prefix-display-key node) + matched-depth)) + prefix-items)))) + (collect-keymap (node) + (alexandria:when-let ((child-layout (generate-layout node active-keymap))) + (push child-layout keymap-layouts)))) + ;; process prefixes and child keymaps separately + (let ((current keymap)) + (loop while current + do (dolist (p (keymap-prefixes current)) + (collect-prefix p)) + (dolist (child (keymap-children current)) + (collect-keymap child)) + (setf current (keymap-base current))))) + ;; build result: title first, then content (prefixes + keymaps arranged by display-style) + (setf prefix-items (nreverse prefix-items)) + (setf keymap-layouts (nreverse keymap-layouts)) + (let ((parts) + (content-items)) + (let ((title (keymap-description keymap))) + (when title + (push (make-layout-title :text title) parts))) + ;; collect prefix column and keymap layouts as content items + (when prefix-items + (let ((max-key-width (reduce 'max + prefix-items + :key (lambda (item) + (let ((key (layout-item-key item))) + (if (listp key) + (segment-line-width key) + (length key)))) + :initial-value 0))) + (push (make-layout-column :items prefix-items :key-width max-key-width) + content-items))) + (dolist (km keymap-layouts) + (when content-items + (push (make-layout-separator) content-items)) + (push km content-items)) + (setf content-items (nreverse content-items)) + ;; arrange content items based on display-style + (when content-items + (ecase (keymap-display-style keymap) + (:row (push (make-layout-row :items content-items) parts)) + (:column (dolist (item content-items) (push item parts))))) + ;; wrap everything in a column (separates title from content, may contain the rest of the items) + (when parts + (make-layout-column :items (nreverse parts)))))) + +(defun render-layout-to-segments (layout &optional (key-width 0)) + "pre-render layout to a list of lines, where each line is a list of (text . attribute) segments." + (cond + ((null layout) nil) + ((layout-title-p layout) + (let ((text (princ-to-string (layout-title-text layout)))) + (list (list (cons "[" 'transient-bracket-attribute) + (cons text 'transient-title-attribute) + (cons "]" 'transient-bracket-attribute))))) + ((layout-separator-p layout) + (list (list (cons "----------------" 'transient-separator-attribute)))) + ((layout-item-p layout) + (let* ((key (layout-item-key layout)) + (key-is-segments (listp key)) + (padding (if key-is-segments + (max 0 (- key-width (segment-line-width key))) + (max 0 (- key-width (length key))))) + (desc (layout-item-description layout)) + (inactive (eq (layout-item-key-attribute layout) 'transient-inactive-attribute)) + (base-segments + (append (if key-is-segments + key + (list (cons key (layout-item-key-attribute layout)))) + (list (cons (make-string padding :initial-element #\space) nil) + (cons " " nil))))) + ;; if desc is a list of segments, append them. otherwise treat as string. + (list (append base-segments + (if (listp desc) + (if inactive + (mapcar + (lambda (seg) + (cons (car seg) 'transient-inactive-attribute)) + desc) + desc) + (list (cons (or desc "") + (layout-item-description-attribute layout)))))))) + ((layout-column-p layout) + (let ((col-key-width (layout-column-key-width layout))) + (loop for item in (layout-column-items layout) + append (render-layout-to-segments item col-key-width)))) + ((layout-row-p layout) + (render-row-as-grid-segments layout)))) + +(defun segment-line-width (segments) + (reduce '+ + segments + :key (lambda (seg) (length (car seg))) + :initial-value 0)) + +(defun insert-segment-line (point segments) + "insert a segment line at point, applying attributes." + (dolist (seg segments) + (let ((text (car seg)) + (attr (cdr seg))) + (if attr + (insert-string point text :attribute attr) + (insert-string point text))))) + +(defun render-row-as-grid-segments (row) + "render row to segment lines (for nested rows in pre-rendering)." + (let* ((items (layout-row-items row)) + ;; map items: for separator use :separator, otherwise generate segments + (columns (mapcar (lambda (item) + (if (layout-separator-p item) + :separator + (render-layout-to-segments item))) + items)) + ;; calculate widths: separator -> length of separator, normal -> max segment line width + (widths (mapcar (lambda (lines) + (if (eq lines :separator) + (length *transient-column-separator*) + (reduce 'max lines :key 'segment-line-width))) + columns)) + ;; max-height: max length of normal columns (ignore separators) + (max-height (reduce 'max + columns + :key (lambda (col) + (if (eq col :separator) + 0 + (length col))) + :initial-value 0)) + (result)) + (dotimes (row-idx max-height) + (let ((line-segments)) + (loop for col-data in columns + for col-width in widths + do (cond + ((eq col-data :separator) + (push (cons *transient-column-separator* 'transient-separator-attribute) + line-segments)) + (t + (let* ((seg-line (when (< row-idx (length col-data)) + (nth row-idx col-data))) + (line-width (if seg-line + (segment-line-width seg-line) + 0)) + (padding (- col-width line-width))) + (when seg-line + (dolist (seg seg-line) + (push seg line-segments))) + (when (> padding 0) + (push (cons (make-string padding :initial-element #\space) nil) + line-segments)))))) + (push (nreverse line-segments) result))) + (nreverse result))) + +(defun insert-segment-lines (point lines) + "insert a list of segment lines into buffer at POINT." + (loop :for line :in lines + :for first := t :then nil + :do (unless first + (insert-character point #\newline)) + (insert-segment-line point line))) + +(defmethod show-transient ((keymap keymap)) + "shows the transient buffer with the contents rendered." + (let ((same-keymap-p (eq keymap *transient-shown-keymap*))) + ;; skip re-render when same keymap, window alive, and no content changes + (let* ((existing-window (and *transient-popup-window* + (not (deleted-window-p *transient-popup-window*)) + *transient-popup-window*)) + (buffer (if existing-window + (window-buffer existing-window) + (make-buffer "*transient*" :temporary t :enable-undo-p nil))) + ;; save vertical scroll position before erase (only for same-keymap re-renders) + (saved-vp-line (when (and existing-window same-keymap-p) + (line-number-at-point (window-view-point existing-window)))) + (root (find-intermediate-root keymap)) + (layout (generate-layout root keymap))) + (setf *transient-shown-keymap* keymap) + (erase-buffer buffer) + (setf (variable-value 'line-wrap :buffer buffer) nil) + (if layout + (insert-segment-lines (buffer-point buffer) (render-layout-to-segments layout)) + (insert-string (buffer-point buffer) "(no bindings)")) + (buffer-start (buffer-point buffer)) + ;; (log:info "transient popup contents:~%~A~%" (buffer-text buffer)) + (let ((height (min (lem/popup-window::compute-buffer-height buffer) + *transient-popup-max-lines*))) + (if existing-window + (unless (= (window-height existing-window) height) + (resize-bottomside-window existing-window height)) + (setf *transient-popup-window* + (make-bottomside-window buffer :height height)))) + ;; restore vertical scroll position for same-keymap re-renders + (when (and saved-vp-line (> saved-vp-line 1)) + (move-to-line (window-view-point *transient-popup-window*) saved-vp-line)) + ;; reset horizontal scroll when switching to a different keymap + (unless same-keymap-p + (setf (window-parameter *transient-popup-window* 'lem-core::horizontal-scroll-start) 0)))) + (modeline-add-status-list 'transient-scroll-status) + (transient-mode t) + (redraw-display)) + +(defun transient-window-alive-p () + "return T if the transient popup window exists and is not deleted." + (and *transient-popup-window* + (not (deleted-window-p *transient-popup-window*)))) + +(defun transient-scroll-status (window) + "modeline status function showing scroll position when the transient buffer overflows." + (when (transient-window-alive-p) + (let* ((tw *transient-popup-window*) + (nlines (buffer-nlines (window-buffer tw))) + (height (window-height tw))) + (when (>= nlines height) + (let ((pos (cond ((first-line-p (window-view-point tw)) + "top") + ((null (line-offset (copy-point (window-view-point tw) :temporary) + height)) + "bot") + (t (format + nil + "~d%" + (floor (* 100 + (float (/ (line-number-at-point (window-view-point tw)) + nlines))))))))) + (values (format nil " transient[~a]" pos) + 'transient-separator-attribute)))))) + +(define-command transient-scroll-down () () + "scroll the transient buffer down by `*transient-vertical-scroll-amount*' lines." + (when (transient-window-alive-p) + (window-scroll *transient-popup-window* *transient-vertical-scroll-amount*) + (redraw-display))) + +(define-command transient-scroll-up () () + "scroll the transient buffer up by `*transient-vertical-scroll-amount*' lines." + (when (transient-window-alive-p) + (window-scroll *transient-popup-window* (- *transient-vertical-scroll-amount*)) + (redraw-display))) + +(define-command transient-scroll-right () () + "scroll the transient buffer to the right by `*transient-vertical-scroll-amount*' columns." + (when (transient-window-alive-p) + (let ((current (or (window-parameter *transient-popup-window* + 'lem-core::horizontal-scroll-start) + 0))) + (setf (window-parameter *transient-popup-window* 'lem-core::horizontal-scroll-start) + (+ current *transient-horizontal-scroll-amount*))) + (redraw-display))) + +(define-command transient-scroll-left () () + "scroll the transient buffer to the left by `*transient-vertical-scroll-amount*' columns." + (when (transient-window-alive-p) + (let ((current (or (window-parameter *transient-popup-window* + 'lem-core::horizontal-scroll-start) + 0))) + (setf (window-parameter *transient-popup-window* 'lem-core::horizontal-scroll-start) + (max 0 (- current *transient-horizontal-scroll-amount*)))) + (redraw-display))) + +(defun hide-transient () + "hide (delete) the transient window." + (when (and *transient-popup-window* + (not (deleted-window-p *transient-popup-window*))) + (modeline-remove-status-list 'transient-scroll-status) + (delete-bottomside-window) + (setf *transient-popup-window* nil) + (setf *transient-shown-keymap* nil) + (transient-mode nil) + (redraw-display))) + +(add-hook *post-command-hook* 'transient-post-command-update) +(defun transient-post-command-update () + (let ((resolved (resolve-transient-keymap))) + (if resolved + (show-transient resolved) + (hide-transient)))) \ No newline at end of file diff --git a/extensions/transient/readme.org b/extensions/transient/readme.org new file mode 100644 index 000000000..2e991ca2d --- /dev/null +++ b/extensions/transient/readme.org @@ -0,0 +1,125 @@ +* behavior +setting ~*transient-always-show*~ to ~t~ makes it show everything but its not the default behavior. unless a specific mode enforces a transient keymap the default behavior is to not show anything. +~shift+alt+up/down/right/left~ scroll the keybinding popup. +this design is because it might make some sense to enable the transient popup for specific modes/popups but not others. but this variable i mentioned that makes it show everything everywhere. +keymaps that dont define the transient properties explicitly inherit default display properties, which makes them show up as a simple grid. +* design +the code for the transient extension is only vaguely inspired by emacs' transient since i never really used it much and only skimmed briefly through the code of transient.el for initial inspiration. the implementation i ended up with is the one that made the most sense to me at the time. +the design is relatively simple. it mainly makes use of 2 concepts, a keymap and a prefix. +- a prefix is essentially a single key. a key sequence is basically a sequence of prefixes each leading to one another (via intermediate keymaps that store these prefixes as children). + a prefix contains the field ~suffix~, which is what comes "after" the prefix. a suffix can be one of + - command: if the suffix is a command, when this prefix is reached, we run the command. + - keymap: if the suffix is a keymap, then we call this keymap a "prefixed keymap", as there is a prefix that leads to it. when this prefix is entered, we arrive at this keymap. +- a keymap stores a list of prefixes, and a list of keymaps. the prefixes it stores represent the keys that are bound in this keymap. + keymaps can be thought of as containers, the keymaps that are stored directly as children are mostly for maintaining a structure and possibly for separating different functionalities that are related. but they also are used to decide the visual structure of the popup later in the transient extension. +** keymap hierarchy +currently, the keymap structure uses different concepts of a 'hierarchy' for different use cases, such as a hierarchy for keymap precedence, another for keymap inheritance, and another for keymap prefixing. the 3rd is naturally distinct but the first 2 have some form of relation and im thinking of a way to unify them (and possibly turning keymaps into types instead of just instances). +* issues +- we need to turn lambda suffixes into commands. together with rewriting the event/key-reading loop to make help keys work properly. currently running help-key on a key sequence that is bound to a lambda doesnt function like you'd expect. +- performance may be a concern since the original implementation had hashmaps which made the traversal as fast as ~O(log n)~ (its actually ~O(1)~ because the key sequences are always gonna be constant in length) while the new one traverses the entire tree to find a key which is ~O(n)~. i dont think its really an issue unless lem is used in a script since the keymap traversal happens as a person types and it would be absurd if you could type keys faster than a computer could traverse a simple keybinding tree. but there is no reason that we couldnt make the new data structure traverse things in ~O(log n)~ time anyway. +* simple example +defining a keymap with a few keys can be done like: +#+begin_src lisp :eval no + (define-command example-command () () + (message "example message")) + + (lem/transient:define-transient *demo-keymap-simple* + :description "my demo keymap" + (:key "a" :suffix 'example-command :description "demo prefix 1") + (:key "b" :suffix 'example-command :description "demo prefix 2" :active-p nil)) + + (define-key *global-keymap* "C-c t" *demo-keymap-simple*) +#+end_src +this will define a keymap with some special properties that make it behave as a "transient" keymap. but this still just defines a keymap instance, it just assigns some properties that give a special behavior to that instance. +when a key sequence is assigned to a keymap, it means that once that key is invoked the keymap will be entered. and if that keymap has the property ~:show-p~ set to ~t~ a popup will appear at the bottom showing the keybindings. the macro ~define-transient~ sets ~:show-p~ to ~t~ by default. +this example assigns ~C-c t~ to a keymap, so when we hit ~C-c t~ the popup will contain the following text: +#+begin_src text + [my demo keymap] + a demo prefix 1 + b demo prefix 2 +#+end_src +(in the actual popup some things will be colorized to distinguish them.) +* vertical alignment +keymaps can act as visual containers, we can have keymaps display as separate columns. the way children keymaps are layed out is determined by the ~:display-style~ property which defaults to ~:row~. +#+begin_src lisp :eval no + (define-command example-command () () + (message "example message")) + + (lem/transient:define-transient *demo-keymap-columns* + :description "my demo keymap" + (:keymap + (:key "a" :suffix 'example-command :description "demo prefix 1") + (:key "b" :suffix 'example-command :description "demo prefix 2")) + (:keymap + (:key "c" :suffix 'example-command :description "demo prefix 3") + (:key "d" :suffix 'example-command :description "demo prefix 4"))) + + (define-key *global-keymap* "C-c t" *demo-keymap-columns*) +#+end_src +notice that children prefixes are always displayed in a column. +#+begin_src text + [my demo keymap] + a demo prefix 1 | c demo prefix 3 + b demo prefix 2 | d demo prefix 4 +#+end_src +* CLOS overrides +the code makes heavy use of CLOS. properties are stored in a plist but grabbed/modified using generic methods. consider the following example which defines behavior using generic method overrides, and allows for "dynamic" behavior depending on the context. +#+begin_src lisp :eval no + (lem/transient:define-prefix *prefix-1* + :key "M-h" + :behavior :drop + :description "my prefix 1") + + (lem/transient:define-prefix *prefix-2* + :key "M-l" + :behavior :drop + :description "my prefix 2") + + (lem/transient:define-transient *keymap-1* + :description "keymap 1 description" + ,*prefix-1* + ,*prefix-2*) + + (define-key *global-keymap* "C-c t" *keymap-1*) + + ;; this will 'override' the :description provided above + (defmethod keymap-description ((p (eql *keymap-1*))) + "my new description") + + ;; make the prefix M-h active only if the cursor is at the beginning of the line + (defmethod prefix-active-p ((p (eql *prefix-1*))) + (start-line-p (current-point))) + + ;; provide dynamic description depending on context + (defmethod prefix-description ((p (eql *prefix-1*))) + (if (prefix-active-p p) + "is active!" + "is inactive!")) + + (define-command example-command () () + (message "example message")) + + (defmethod prefix-suffix ((p (eql *prefix-1*))) + 'example-command) +#+end_src +the ~:drop~ property makes the keys not drop the whole sequence, so that we dont have to type ~C-c t~ more than once if we want to execute keybindings from ~*keymap-1*~ multiple times. +* infixes and variables +infixes can eb useful for adjusting values using keybindings. consider the following example which provides a way to toggle a boolean using an "infix". +#+begin_src lisp :eval no + (defvar *my-bool* + nil + "a demo variable that stays in sync with an infix.") + + (lem/transient:define-transient *keymap-with-infix* + :description "keymap 1 description" + (:key "t" + :type 'toggle + :variable '*my-bool* + :description "demo toggle") + (:key "r" :suffix 'demo-run :description "demo run")) + + (define-key *global-keymap* "C-c t" *keymap-with-infix*) + + (define-command demo-run () () + (message "variable value: ~A" *my-bool*)) +#+end_src \ No newline at end of file diff --git a/extensions/transient/transient.lisp b/extensions/transient/transient.lisp new file mode 100644 index 000000000..17c3cd61c --- /dev/null +++ b/extensions/transient/transient.lisp @@ -0,0 +1,22 @@ +(defpackage :lem/transient + (:use :cl :lem) + (:export + :define-transient + :define-prefix + :parse-prefix + :assign-transient-key + :define-transient-key + :mode-transient-keymap + :prefix-value + :prefix-render + :make-layout-item + :prefix-effective-display-key + :make-key-with-highlight + :transient-bracket-attribute + :transient-value-attribute + :prefix-active-p + :prefix-suffix + :transient-mode + :*transient-mode-keymap*)) + +(in-package :lem/transient) \ No newline at end of file diff --git a/extensions/vi-mode/binds.lisp b/extensions/vi-mode/binds.lisp index 2732a15c6..5282af236 100644 --- a/extensions/vi-mode/binds.lisp +++ b/extensions/vi-mode/binds.lisp @@ -7,8 +7,6 @@ :lem-vi-mode/commands :lem-vi-mode/ex :lem-vi-mode/visual) - (:import-from :lem-core - :keymap-table) (:import-from :lem/prompt-window :prompt-previous-history :prompt-next-history)) @@ -201,11 +199,19 @@ (define-key *outer-text-objects-keymap* "p" 'vi-a-paragraph) (define-key *inner-text-objects-keymap* "p" 'vi-inner-paragraph) -(setf (gethash (lem:make-key :sym "a") (keymap-table *operator-keymap*)) - (keymap-table *outer-text-objects-keymap*)) -(setf (gethash (lem:make-key :sym "i") (keymap-table *operator-keymap*)) - (keymap-table *inner-text-objects-keymap*)) -(setf (gethash (lem:make-key :sym "a") (keymap-table *visual-keymap*)) - (keymap-table *outer-text-objects-keymap*)) -(setf (gethash (lem:make-key :sym "i") (keymap-table *visual-keymap*)) - (keymap-table *inner-text-objects-keymap*)) +(lem-core:keymap-add-prefix + *operator-keymap* + (lem:make-prefix :key (lem:make-key :sym "a") + :suffix *outer-text-objects-keymap*)) +(lem-core:keymap-add-prefix + *operator-keymap* + (lem:make-prefix :key (lem:make-key :sym "i") + :suffix *inner-text-objects-keymap*)) +(lem-core:keymap-add-prefix + *visual-keymap* + (lem:make-prefix :key (lem:make-key :sym "a") + :suffix *outer-text-objects-keymap*)) +(lem-core:keymap-add-prefix + *visual-keymap* + (lem:make-prefix :key (lem:make-key :sym "i") + :suffix *inner-text-objects-keymap*)) diff --git a/extensions/vi-mode/commands.lisp b/extensions/vi-mode/commands.lisp index 8b7c55cf2..1c8f37120 100644 --- a/extensions/vi-mode/commands.lisp +++ b/extensions/vi-mode/commands.lisp @@ -164,7 +164,8 @@ (defun extract-count-keys (keys) (loop for key in keys - for cmd = (lem-core::keymap-find-keybind *motion-keymap* key nil) + for prefix = (lem-core::keymap-find *motion-keymap* key) + for cmd = (when prefix (prefix-suffix prefix)) unless (member cmd '(lem/universal-argument:universal-argument-0 lem/universal-argument:universal-argument-1 lem/universal-argument:universal-argument-2 diff --git a/extensions/vi-mode/core.lisp b/extensions/vi-mode/core.lisp index c1932d427..c79adc8fd 100644 --- a/extensions/vi-mode/core.lisp +++ b/extensions/vi-mode/core.lisp @@ -275,16 +275,14 @@ `(let ((*vi-current-window* ,window)) ,@body)) -(defstruct (vi-keymap (:include keymap) - (:constructor %make-vi-keymap))) - -(defun make-vi-keymap (&rest args &key undef-hook parent name) - (declare (ignore undef-hook parent name)) - (let ((keymap (apply #'%make-vi-keymap args))) - (push keymap *keymaps*) - keymap)) - -(defmacro define-keymap (name &key undef-hook parent) - `(defvar ,name (make-vi-keymap :name ',name - :undef-hook ,undef-hook - :parent ,parent))) +(defclass vi-keymap (keymap*) + ()) + +(defun make-vi-keymap (&rest args &key undef-hook base description) + (declare (ignore undef-hook base description)) + (apply 'make-instance 'vi-keymap (alexandria:remove-from-plist args :base))) + +(defmacro define-keymap (name &key undef-hook) + (declare (ignore parent)) + `(defvar ,name (make-vi-keymap :description ',name + :undef-hook ,undef-hook))) diff --git a/extensions/vi-mode/ex.lisp b/extensions/vi-mode/ex.lisp index b3549d0b2..ab184b82d 100644 --- a/extensions/vi-mode/ex.lisp +++ b/extensions/vi-mode/ex.lisp @@ -14,7 +14,7 @@ :*ex-keymap*)) (in-package :lem-vi-mode/ex) -(defvar *ex-keymap* (make-keymap :name '*ex-keymap*)) +(defvar *ex-keymap* (make-keymap :description '*ex-keymap*)) (define-state ex () () (:default-initargs diff --git a/extensions/vi-mode/leader.lisp b/extensions/vi-mode/leader.lisp index 12f92dcc0..a082fac2d 100644 --- a/extensions/vi-mode/leader.lisp +++ b/extensions/vi-mode/leader.lisp @@ -19,12 +19,12 @@ (defun leader-key () (make-key :sym "Leader")) -(defmethod keymap-find-keybind ((keymap vi-keymap) (key lem-core::key) cmd) +(defmethod keymap-find ((keymap vi-keymap) (key lem-core::key)) (if (mapleader-key-p key) - (call-next-method keymap (leader-key) cmd) + (call-next-method keymap (leader-key)) (call-next-method))) -(defmethod keymap-find-keybind ((keymap vi-keymap) (key cons) cmd) +(defmethod keymap-find ((keymap vi-keymap) (key cons)) (if (mapleader-key-p (first key)) - (call-next-method keymap (cons (leader-key) (rest key)) cmd) + (call-next-method keymap (cons (leader-key) (rest key))) (call-next-method))) diff --git a/extensions/vi-mode/states.lisp b/extensions/vi-mode/states.lisp index af09a2d66..add88e4ab 100644 --- a/extensions/vi-mode/states.lisp +++ b/extensions/vi-mode/states.lisp @@ -44,7 +44,8 @@ (defvar *emacs-keymap* *global-keymap*) (define-keymap *motion-keymap*) -(define-keymap *normal-keymap* :parent *motion-keymap*) +(define-keymap *normal-keymap*) +(keymap-add-child *normal-keymap* *motion-keymap*) (define-keymap *insert-keymap*) (define-keymap *operator-keymap*) (define-keymap *replace-char-state-keymap* :undef-hook 'return-last-read-char) diff --git a/extensions/vi-mode/visual.lisp b/extensions/vi-mode/visual.lisp index eafc2e962..4c698dfb0 100644 --- a/extensions/vi-mode/visual.lisp +++ b/extensions/vi-mode/visual.lisp @@ -34,7 +34,7 @@ :vi-visual-opposite-side)) (in-package :lem-vi-mode/visual) -(defvar *visual-keymap* (make-keymap :name '*visual-keymap*)) +(defvar *visual-keymap* (make-keymap :description '*visual-keymap*)) (defmethod make-region-overlays-using-global-mode ((global-mode vi-mode) cursor) (let ((buffer (point-buffer cursor))) diff --git a/lem.asd b/lem.asd index 39c77a87d..2e52a0ef2 100644 --- a/lem.asd +++ b/lem.asd @@ -33,6 +33,7 @@ "dexador" "cl-mustache" ;; "lem-encodings" + "cltpt" #+sbcl sb-concurrency "lem-mailbox" @@ -296,7 +297,9 @@ "lem-copilot" "lem-claude-code" "lem-bookmark" + "organ-mode" "lem-mcp-server" + "lem-transient" #+sbcl "lem-living-canvas" "lem-tree-sitter" diff --git a/qlfile b/qlfile index 35498f370..9ee4fa32b 100644 --- a/qlfile +++ b/qlfile @@ -10,4 +10,6 @@ git cl-sdl2-image https://github.com/lem-project/cl-sdl2-image.git git jsonrpc https://github.com/cxxxr/jsonrpc.git git lem-extension-manager https://github.com/lem-project/lem-extension-manager.git git webview https://github.com/lem-project/webview.git +git cltpt https://github.com/mahmoodsh36/cltpt +git organ-mode https://github.com/mahmoodsh36/organ-mode git tree-sitter-cl https://github.com/lem-project/tree-sitter-cl.git diff --git a/qlfile.lock b/qlfile.lock index 8568cc4c6..3b98a0e00 100644 --- a/qlfile.lock +++ b/qlfile.lock @@ -50,6 +50,14 @@ (:class qlot/source/git:source-git :initargs (:remote-url "https://github.com/lem-project/webview.git") :version "git-607daff93e9e716a76c5dbd08c48b5233c96b9a3")) +("cltpt" . + (:class qlot/source/git:source-git + :initargs (:remote-url "https://github.com/mahmoodsh36/cltpt") + :version "git-242d7535f0266d8e622d37b22f232f848089229e")) +("organ-mode" . + (:class qlot/source/git:source-git + :initargs (:remote-url "https://github.com/mahmoodsh36/organ-mode") + :version "git-c953907aaf8b6b5d95d15f706b5eb563ee73c189")) ("tree-sitter-cl" . (:class qlot/source/git:source-git :initargs (:remote-url "https://github.com/lem-project/tree-sitter-cl.git") diff --git a/src/commands/help.lisp b/src/commands/help.lisp index 2906dd79a..5673f95aa 100644 --- a/src/commands/help.lisp +++ b/src/commands/help.lisp @@ -28,7 +28,7 @@ (terpri s)) (let ((column-width 16)) (loop :while keymap - :do (format s "~A (~(~A~))~%" name (keymap-name keymap)) + :do (format s "~A (~(~A~))~%" name (keymap-description keymap)) (format s "~va~a~%" column-width "key" "binding") (format s "~va~a~%" column-width "---" "-------") (traverse-keymap keymap @@ -38,7 +38,6 @@ column-width (keyseq-to-string kseq) (symbol-name command))))) - (setf keymap (keymap-parent keymap)) (terpri s)))) (define-command describe-bindings () () diff --git a/src/display/physical-line.lisp b/src/display/physical-line.lisp index efb3b3e92..efe3a9873 100644 --- a/src/display/physical-line.lisp +++ b/src/display/physical-line.lisp @@ -461,17 +461,17 @@ (+ cursor-x (object-width cursor-object))) (setf (horizontal-scroll-start window) (+ (- cursor-x width) - (object-width cursor-object)))))) - (setf objects - (extract-object-in-display-range - (mapcan (lambda (object) - (if (typep object 'text-object) - (explode-object object) - (list object))) - objects) - (horizontal-scroll-start window) - (+ (horizontal-scroll-start window) - (window-view-width window))))) + (object-width cursor-object))))))) + (setf objects + (extract-object-in-display-range + (mapcan (lambda (object) + (if (typep object 'text-object) + (explode-object object) + (list object))) + objects) + (horizontal-scroll-start window) + (+ (horizontal-scroll-start window) + (window-view-width window)))) (render-line-with-caching window 0 y (append left-side-objects objects) height)) height))) diff --git a/src/ext/completion-mode.lisp b/src/ext/completion-mode.lisp index 0abb0d1c1..1e90e52c8 100644 --- a/src/ext/completion-mode.lisp +++ b/src/ext/completion-mode.lisp @@ -98,7 +98,7 @@ (declare (ignore label chunks detail start end focus-action)) (apply #'make-instance 'completion-item initargs)) -(defvar *completion-mode-keymap* (make-keymap :name '*completion-mode-keymap* +(defvar *completion-mode-keymap* (make-keymap :description '*completion-mode-keymap* :undef-hook 'completion-self-insert)) (define-minor-mode completion-mode (:name "completion" diff --git a/src/ext/frame-multiplexer.lisp b/src/ext/frame-multiplexer.lisp index b2a8edd23..0a7721c31 100644 --- a/src/ext/frame-multiplexer.lisp +++ b/src/ext/frame-multiplexer.lisp @@ -53,7 +53,7 @@ (frame-multiplexer-off)))) (defvar *keymap* - (make-keymap :name '*frame-multiplexer-keymap*) + (make-keymap :description '*frame-multiplexer-keymap*) "Keymap for commands related to the frame-multiplexer.") (define-key *keymap* "c" 'frame-multiplexer-create-with-new-buffer-list) diff --git a/src/ext/grep.lisp b/src/ext/grep.lisp index 4a0d7a522..9b60e0ee3 100644 --- a/src/ext/grep.lisp +++ b/src/ext/grep.lisp @@ -182,8 +182,8 @@ ""))) (format s "~%"))) -(defvar *peek-grep-mode-keymap* (make-keymap :name '*peek-grep-mode-keymap* - :parent lem/peek-source:*peek-source-keymap*)) +(defvar *peek-grep-mode-keymap* (make-keymap :description '*peek-grep-mode-keymap* + :base lem/peek-source:*peek-source-keymap*)) (define-minor-mode peek-grep-mode (:name "Peek" :keymap *peek-grep-mode-keymap*)) diff --git a/src/ext/isearch.lisp b/src/ext/isearch.lisp index d565b1b6e..534714eda 100644 --- a/src/ext/isearch.lisp +++ b/src/ext/isearch.lisp @@ -37,7 +37,7 @@ (:lock t)) (in-package :lem/isearch) -(defvar *isearch-keymap* (make-keymap :name '*isearch-keymap* +(defvar *isearch-keymap* (make-keymap :description '*isearch-keymap* :undef-hook 'isearch-self-insert)) (defvar *isearch-prompt*) (defvar *isearch-string*) diff --git a/src/ext/prompt-window.lisp b/src/ext/prompt-window.lisp index 16f82c2c3..a10d1e096 100644 --- a/src/ext/prompt-window.lisp +++ b/src/ext/prompt-window.lisp @@ -522,7 +522,7 @@ (setf *prompt-buffer-completion-function* 'prompt-buffer-completion) (setf *prompt-command-completion-function* 'prompt-command-completion) -(defvar *file-prompt-keymap* (make-keymap :name '*file-mode-prompt-keymap*)) +(defvar *file-prompt-keymap* (make-keymap :description '*file-mode-prompt-keymap*)) (define-key *file-prompt-keymap* "C-Backspace" 'file-prompt-parent-folder) (define-command file-prompt-parent-folder () () diff --git a/src/ext/rectangle.lisp b/src/ext/rectangle.lisp index 9e779fb76..031404940 100644 --- a/src/ext/rectangle.lisp +++ b/src/ext/rectangle.lisp @@ -9,7 +9,7 @@ (defvar *overlays* '()) (defvar *rectangle-mark-mode-keymap* - (make-keymap :name '*rectangle-mark-mode-keymap* + (make-keymap :description '*rectangle-mark-mode-keymap* :undef-hook 'rectangle-self-insert)) (define-minor-mode rectangle-mark-mode diff --git a/src/ext/universal-argument.lisp b/src/ext/universal-argument.lisp index a6121a90c..f8bb028e0 100644 --- a/src/ext/universal-argument.lisp +++ b/src/ext/universal-argument.lisp @@ -30,7 +30,7 @@ (defvar *argument* (make-arg-state)) (defvar *universal-argument-keymap* - (make-keymap :name '*universal-argument-keymap* + (make-keymap :description '*universal-argument-keymap* :undef-hook 'universal-argument-default)) (define-editor-variable universal-argument-function diff --git a/src/frame.lisp b/src/frame.lisp index 16771619f..6986e2e24 100644 --- a/src/frame.lisp +++ b/src/frame.lisp @@ -73,7 +73,10 @@ redraw-display関数でキャッシュを捨てて画面全体を再描画しま :accessor frame-leftside-window) (rightside-window :initform nil - :accessor frame-rightside-window))) + :accessor frame-rightside-window) + (bottomside-window + :initform nil + :accessor frame-bottomside-window))) (defmethod frame-window-bottom-margin ((frame frame)) (if (frame-enable-window-modeline-per-window frame) @@ -149,7 +152,8 @@ redraw-display関数でキャッシュを捨てて画面全体を再描画しま (find window (frame-floating-windows frame)) (find window (frame-header-windows frame)) (eq window (frame-leftside-window frame)) - (eq window (frame-rightside-window frame))) + (eq window (frame-rightside-window frame)) + (eq window (frame-bottomside-window frame))) t)) (defun get-frame-of-window (window) @@ -198,7 +202,10 @@ redraw-display関数でキャッシュを捨てて画面全体を再描画しま (defun max-window-height (frame) (- (display-height) - (topleft-window-y frame))) + (topleft-window-y frame) + (if (frame-bottomside-window frame) + (window-height (frame-bottomside-window frame)) + 0))) (defun within-window-p (window x y) diff --git a/src/fundamental-mode.lisp b/src/fundamental-mode.lisp index d4d33d38f..e132c3ac2 100644 --- a/src/fundamental-mode.lisp +++ b/src/fundamental-mode.lisp @@ -3,7 +3,7 @@ (define-major-mode lem/buffer/fundamental-mode:fundamental-mode nil (:name "Fundamental")) -(defvar *global-keymap* (make-keymap :name '*global-keymap*)) +(defvar *global-keymap* (make-keymap :description '*global-keymap*)) (define-global-mode emacs-mode () (:name "emacs" diff --git a/src/input.lisp b/src/input.lisp index bbb359703..edeaf9bd4 100644 --- a/src/input.lisp +++ b/src/input.lisp @@ -29,6 +29,14 @@ Examples: (defun set-last-read-key-sequence (key-sequence) (setf last-read-key-sequence key-sequence))) +(defmacro with-last-read-key-sequence (&body body) + "execute BODY with `last-read-key-sequence' temporarily set to NIL, preserving its original value." + (alexandria:with-gensyms (old-value) + `(let ((,old-value (last-read-key-sequence))) + (set-last-read-key-sequence nil) + (unwind-protect (progn ,@body) + (set-last-read-key-sequence ,old-value))))) + (let ((key-recording-status-name " Def")) (defun start-record-key () (modeline-add-status-list key-recording-status-name) @@ -139,6 +147,28 @@ Pressing the same prefix key twice produces that key." (pop *this-command-keys*) (push key *unread-keys*)) +(defun count-intermediate-keys (keymap kseq) + "count how many keys in KSEQ traversed through intermediate prefixes." + (let ((count 0)) + (labels ((find-prefix-matches (km key) + "find prefix children of KM matching KEY, recursing into child keymaps." + (when (and (typep km 'keymap) (keymap-active-p km)) + (append (loop for item in (keymap-prefixes km) + when (and (prefix-active-p item) + (equal (prefix-key item) key)) + collect item) + (loop for child in (keymap-children km) + append (find-prefix-matches child key))))) + (walk (binding keys) + (when keys + (let ((matches (find-prefix-matches binding (car keys)))) + (dolist (match matches) + (when (prefix-intermediate-p match) + (incf count)) + (walk (prefix-suffix match) (cdr keys))))))) + (walk keymap kseq)) + count)) + (defun read-command () (let ((event (read-event))) (etypecase event @@ -146,16 +176,70 @@ Pressing the same prefix key twice produces that key." (set-last-mouse-event event) (find-mouse-command event)) (key - (let* ((cmd (lookup-keybind event)) - (kseq (list event))) - (loop - (cond ((prefix-command-p cmd) - (let ((event (read-key))) - (setf kseq (nconc kseq (list event))) - (setf cmd (lookup-keybind kseq)))) - (t - (set-last-read-key-sequence kseq) - (return cmd))))))))) + (let ((prefix) + (suffix) + (behavior) + (kseq (list event))) + (labels ((reset () + (setf prefix (lookup-keybind kseq)) + (setf suffix (when prefix (prefix-suffix prefix))) + (setf behavior (when prefix (prefix-behavior prefix))))) + (loop + (reset) + (when prefix + (prefix-invoke prefix)) + ;; if suffix was a function we call it and set to NIL so that we dont return it + (when (functionp suffix) + (funcall suffix) + (setf suffix nil)) + (cond ((prefix-command-p suffix) + (when (typep suffix 'keymap) + (keymap-activate suffix)) + (let ((event (read-key))) + (setf kseq (nconc kseq (list event))) + (reset))) + (t + (cond + ;; note: menu in these comments might mean keymaps, i used menu because + ;; this is mostly intended for transient keymaps (i.e. key menus). + ;; :drop removes the current key from kseq without changing "menus". + ;; used for "infix" keys (toggles, choices) that act in-place. + ;; also pops any intermediate prefix keys so the recorded + ;; sequence reflects only the menu-level key that was pressed. + ((eq behavior :drop) + ;; command symbols are executed via call-command before dropping. + (when suffix + (call-command suffix nil)) + (setf kseq (butlast kseq)) + (dotimes (_ (count-intermediate-keys *root-keymap* kseq)) + (setf kseq (butlast kseq))) + (set-last-read-key-sequence kseq) + ;; TODO: this check here shouldnt be necessary but it currently is. + (if (null kseq) + (progn + (keymap-activate *root-keymap*) + (return nil)) + (reset))) + ;; :back removes the current key and the key that entered + ;; the current menu, navigating up one menu level. + ;; also pops any intermediate prefix keys in between. + ((eq behavior :back) + (setf kseq (butlast kseq)) + (dotimes (_ (count-intermediate-keys *root-keymap* kseq)) + (setf kseq (butlast kseq))) + ;; pop the key that entered the current "menu" + (setf kseq (butlast kseq)) + (set-last-read-key-sequence kseq) + (reset)) + ((eq behavior :cancel) + (setf kseq nil) + (set-last-read-key-sequence nil) + (keymap-activate *root-keymap*) + (return nil)) + (t + (set-last-read-key-sequence kseq) + (keymap-activate *root-keymap*) + (return suffix)))))))))))) (defun read-key-sequence () (read-command) @@ -171,8 +255,9 @@ Pressing the same prefix key twice produces that key." (do-command-loop (:interactive nil) (when (null *unread-keys*) (return)) - (let ((*this-command-keys* nil)) - (call-command (read-command) nil))))) + (let* ((*this-command-keys* nil) + (cmd (read-command))) + (call-command cmd nil))))) (defun sit-for (seconds &optional (update-window-p t) (force-update-p nil)) (when update-window-p (redraw-display :force force-update-p)) diff --git a/src/internal-packages.lisp b/src/internal-packages.lisp index b3f740366..442ed41f0 100644 --- a/src/internal-packages.lisp +++ b/src/internal-packages.lisp @@ -206,6 +206,7 @@ :frame-message-window :frame-leftside-window :frame-rightside-window + :frame-bottomside-window :notify-frame-redisplay-required :map-frame :get-frame @@ -385,7 +386,10 @@ :make-leftside-window :delete-leftside-window :make-rightside-window - :delete-rightside-window) + :delete-rightside-window + :make-bottomside-window + :delete-bottomside-window + :resize-bottomside-window) ;; popup.lisp (:export :*default-popup-message-timeout* @@ -440,6 +444,7 @@ (:export :ensure-mode-object :major-mode + :mode :mode-name :mode-description :mode-keymap @@ -449,6 +454,7 @@ :mode-active-p :major-modes :minor-modes + :all-active-modes :find-mode :toggle-minor-mode :define-major-mode @@ -468,12 +474,27 @@ :paste-using-mode) ;; keymap.lisp (:export - :*keymaps* :keymap - :keymap-name - :keymap-parent + :prefix + :keymap* + :*root-keymap* + :prefix-active-p + :prefix-intermediate-p + :prefix-behavior + :keymap-prefixes + :keymap-children + :keymap-description + :keymap-properties + :keymap-base + :parse-keyspec + :prefix-properties :keymap-undef-hook + :keymap-activate :make-keymap + :make-prefix + :prefix-description + :prefix-key + :prefix-suffix :*global-keymap* :define-key :define-keys @@ -483,13 +504,16 @@ :find-keybind :insertion-key-p :lookup-keybind - :keymap-find-keybind + :keymap-find :*abort-key* :abort-key-p :with-special-keymap :traverse-keymap :compute-keymaps - :collect-command-keybindings) + :collect-command-keybindings + :keymap-add-child + :keymap-add-prefix + :prefix-invoke) ;; reexport common/timer (:export :timer @@ -523,6 +547,7 @@ :*input-hook* :meta-prefix-keys :last-read-key-sequence + :with-last-read-key-sequence :start-record-key :stop-record-key :key-recording-p diff --git a/src/interp.lisp b/src/interp.lisp index 28d06d408..74d51b52a 100644 --- a/src/interp.lisp +++ b/src/interp.lisp @@ -81,7 +81,8 @@ (unless (or (eq cmd ') (eq cmd ')) (message nil)) - (call-command cmd nil))) + (when cmd + (call-command cmd nil)))) (editor-abort-handler (c) (declare (ignore c)) diff --git a/src/keymap.lisp b/src/keymap.lisp index 12d8bc14e..c96f0f5ba 100644 --- a/src/keymap.lisp +++ b/src/keymap.lisp @@ -1,8 +1,204 @@ (in-package :lem-core) -(defvar *keymaps* nil) +(defclass prefix () + ((key + :initarg :key + :documentation "the key defined for the prefix. could be a function that returns a key.") + (description + :initarg :description + :initform nil) + (suffix + :initarg :suffix + :documentation "the suffix defined for the prefix, could be another prefix or a keymap or a function that returns one.") + (active-p + :initarg :active-p + :documentation "whether a prefix is active." + :initform t) + ;; intermediate-p means a prefix is just a "continuation" of another and servers as an intermediate key + (intermediate-p + :initarg :intermediate-p + :documentation "whether a prefix is an intermediary to another, this effects the :drop and :back behavior." + :initform nil) + (behavior + :initarg :behavior + :initform nil + :documentation "should be one of `:drop', `:back', `:cancel', or NIL to decide the effect of the suffix on the key sequence. -(defvar *special-keymap* nil) +:cancel to drop the current key sequence entirely without invoking a command. +:drop to avoid adding the current key to the key sequence, which makes the prefix act as an \"infix\" key. +:back to avoid adding the current key and to pop the last recorded key which has the effect of \"going back\" to parent menu in the transient popup. +NIL to append it to the key sequence normally.") + (properties + :initarg :properties + :accessor prefix-properties + :initform nil + :documentation "extra metadata that a prefix may hold."))) + +(defgeneric prefix-key (prefix) + (:method ((prefix prefix)) + (slot-value prefix 'key))) + +(defgeneric (setf prefix-key) (new-value prefix) + (:method (new-value (prefix prefix)) + (setf (slot-value prefix 'key) new-value))) + +(defgeneric prefix-suffix (prefix) + (:method ((prefix prefix)) + (slot-value prefix 'suffix))) + +(defgeneric (setf prefix-suffix) (new-value prefix) + (:method (new-value (prefix prefix)) + (setf (slot-value prefix 'suffix) new-value))) + +(defgeneric prefix-description (prefix) + (:method ((prefix prefix)) + (slot-value prefix 'description))) + +(defgeneric (setf prefix-description) (new-value prefix) + (:method (new-value (prefix prefix)) + (setf (slot-value prefix 'description) new-value))) + +(defgeneric prefix-active-p (prefix) + (:method ((prefix prefix)) + (slot-value prefix 'active-p))) + +(defgeneric (setf prefix-active-p) (new-value prefix) + (:method (new-value (prefix prefix)) + (setf (slot-value prefix 'active-p) new-value))) + +(defun make-prefix (&key key suffix description) + (let ((prefix (make-instance + 'prefix + :key key + :suffix suffix + :description description))) + prefix)) + +(defclass keymap () + ((prefixes + :initarg :prefixes + :initform nil + :documentation "prefix bindings owned by this keymap.") + (children + :initarg :children + :initform nil + :documentation "child keymaps.") + (properties + :initarg :properties + :accessor keymap-properties + :initform nil + :documentation "additional metadata that a keymap holds.") + (description + :initarg :description + :initform nil) + (active-p + :initarg :active-p + :documentation "whether a prefix is active." + :initform t) + (base + :initarg :base + :accessor keymap-base + :initform nil + :documentation "the keymap that this keymap extends."))) + +(defgeneric keymap-prefixes (keymap) + (:method ((keymap keymap)) + (slot-value keymap 'prefixes))) + +(defgeneric (setf keymap-prefixes) (new-value keymap) + (:method (new-value (keymap keymap)) + (setf (slot-value keymap 'prefixes) new-value))) + +(defgeneric keymap-children (keymap) + (:method ((keymap keymap)) + (slot-value keymap 'children))) + +(defgeneric (setf keymap-children) (new-value keymap) + (:method (new-value (keymap keymap)) + (setf (slot-value keymap 'children) new-value))) + +(defgeneric keymap-description (keymap) + (:method ((keymap keymap)) + (slot-value keymap 'description))) + +(defgeneric (setf keymap-description) (new-value keymap) + (:method (new-value (keymap keymap)) + (setf (slot-value keymap 'description) new-value))) + +(defgeneric keymap-active-p (keymap) + (:method ((keymap keymap)) + (slot-value keymap 'active-p))) + +(defgeneric (setf keymap-active-p) (new-value keymap) + (:method (new-value (keymap keymap)) + (setf (slot-value keymap 'active-p) new-value))) + +(defmethod keymap-add-prefix ((keymap keymap) (prefix prefix) &optional after) + (unless (find prefix (keymap-prefixes keymap)) + (if after + (setf (keymap-prefixes keymap) (append (slot-value keymap 'prefixes) (list prefix))) + (push prefix (slot-value keymap 'prefixes))))) + +(defmethod keymap-add-child ((keymap keymap) (keymap2 keymap) &optional after) + (unless (find keymap2 (keymap-children keymap)) + (if after + (setf (keymap-children keymap) (append (slot-value keymap 'children) (list keymap2))) + (push keymap2 (slot-value keymap 'children))))) + +(defgeneric prefix-p (keymap) + (:documentation "check whether this is a prefix of another prefix. + +a prefix is a prefix of another if its a keymap or if its suffix is a prefix.")) + +(defmethod prefix-p ((km keymap)) + t) + +(defmethod prefix-p ((p prefix)) + (or (typep (prefix-suffix p) 'prefix) + (typep (prefix-suffix p) 'keymap))) + +(defmethod (setf prefix-behavior) (new-value (prefix prefix)) + (setf (slot-value prefix 'behavior) new-value)) + +(defmethod prefix-behavior ((prefix prefix)) + (slot-value prefix 'behavior)) + +(defmethod (setf prefix-intermediate-p) (new-value (prefix prefix)) + (setf (slot-value prefix 'intermediate-p) new-value)) + +(defmethod prefix-intermediate-p ((prefix prefix)) + (slot-value prefix 'intermediate-p)) + +(defgeneric keymap-activate (keymap) + (:documentation "a hook for when a keymap is entered by some prefix.") + ;; default keymap-activate does nothing + (:method ((keymap t)) + nil)) + +(defgeneric prefix-invoke (prefix) + (:documentation "a hook for when a prefix is reached.") + (:method ((prefix t)) nil)) + +(defun find-prefix-matches (keymap key &key active-only) + (loop for item in (keymap-prefixes keymap) + when (and (equal (prefix-key item) key) + (or (not active-only) + (prefix-active-p item))) + collect item)) + +(defun first-prefix-match (keymap key &key active-only) + (loop for item in (keymap-prefixes keymap) + when (and (equal (prefix-key item) key) + (or (not active-only) + (prefix-active-p item))) + return item)) + +(defun search-with-base (keymap fn) + (or (funcall fn keymap) + (when (typep keymap 'keymap) + (let ((base (keymap-base keymap))) + (when base + (search-with-base base fn)))))) (deftype key-sequence () '(trivial-types:proper-list key)) @@ -11,30 +207,42 @@ (check-type key-sequence key-sequence) (format nil "~{~A~^ ~}" key-sequence)) -(defstruct (keymap (:constructor %make-keymap)) - undef-hook - parent - (table (make-hash-table :test 'eq)) - (function-table (make-hash-table :test 'eq)) - name) +;; this is for backwards compatibility for now +(defclass keymap* (keymap) + ((undef-hook + :initarg :undef-hook + :accessor keymap-undef-hook + :initform nil) + (function-table + :initarg :function-table + :accessor keymap-function-table + :initform (make-hash-table :test 'eq)))) + +;; *root-keymap* contains the full keymap hierarchy +(defvar *root-keymap* (make-instance 'keymap)) + +(defvar *special-keymap* nil) (defmethod print-object ((object keymap) stream) (print-unreadable-object (object stream :identity t :type t) - (when (keymap-name object) - (princ (keymap-name object) stream)))) - -(defun make-keymap (&key undef-hook parent name) - (let ((keymap (%make-keymap - :undef-hook undef-hook - :parent parent - :name name))) - (push keymap *keymaps*) + (when (keymap-description object) + (princ (keymap-description object) stream)))) + +(defun make-keymap (&key undef-hook prefixes children description base) + (let ((keymap (make-instance 'keymap* + :undef-hook undef-hook + :prefixes prefixes + :children children + :description description + :base base))) keymap)) (defun prefix-command-p (command) - (hash-table-p command)) + (and (or (typep command 'keymap) + (typep command 'prefix)) + (prefix-p command))) -(defun define-key (keymap keyspec command-name) +(defmethod define-key ((keymap keymap) keyspec command-name) "Bind a command COMMAND-NAME to a KEYSPEC in a KEYMAP. Global bindings use `*global-keymap*' as KEYMAP argument. @@ -58,23 +266,49 @@ Example: (define-key *global-keymap* \"C-'\" 'list-modes)" `(progn ,@(mapcar (lambda (binding) `(define-key ,keymap - ,(first binding) + ,(first binding) ,(second binding))) bindings))) -(defun define-key-internal (keymap keys symbol) - (loop :with table := (keymap-table keymap) - :for rest :on (uiop:ensure-list keys) - :for k := (car rest) - :do (cond ((null (cdr rest)) - (setf (gethash k table) symbol)) - (t - (let ((next (gethash k table))) - (if (and next (prefix-command-p next)) - (setf table next) - (let ((new-table (make-hash-table :test 'eq))) - (setf (gethash k table) new-table) - (setf table new-table)))))))) +(defun prefix-for-key (keymap key) + "find a prefix matching KEY in KEYMAP, searching child keymaps recursively." + (or (first-prefix-match keymap key) + (loop for child in (keymap-children keymap) + thereis (prefix-for-key child key)))) + +(defmethod define-key-internal ((keymap keymap) keys symbol) + (let* ((rest (uiop:ensure-list keys)) + (first-key (car rest))) + (if (null (cdr rest)) + ;; if theres no more keys in the sequence we simply bind the last key. + (let ((prefix (prefix-for-key keymap first-key))) + (if prefix + (setf (prefix-suffix prefix) symbol) + ;; if we didnt find a pre-existing prefix we insert one + (keymap-add-prefix keymap (make-prefix :key first-key :suffix symbol)))) + ;; here we're creating intermediate keymaps to bind the keys in the sequence + ;; one by one. which is the way emacs does it, and the way lem used to it. + ;; but it should be possible to completely bind the sequence to prefixes that + ;; lead to one another. + (let* ((next-prefix (prefix-for-key keymap first-key)) + (next-keymap)) + ;; we expect the suffix of next-prefix to be a keymap, if next-prefix isnt yet + ;; existent we create a prefixed keymap and work with it. + (if next-prefix + (let ((suffix (prefix-suffix next-prefix))) + (if (typep suffix 'keymap) + (setf next-keymap suffix) + ;; suffix is a command, need to create intermediate keymap. but why would we get here? + (progn + (setf next-keymap (make-instance 'keymap)) + (setf (prefix-suffix next-prefix) next-keymap)))) + (progn + (setf next-keymap (make-instance 'keymap)) + (setf next-prefix + (make-prefix :suffix next-keymap + :key first-key)) + (keymap-add-prefix keymap next-prefix))) + (define-key-internal next-keymap (cdr rest) symbol))))) (defun undefine-key (keymap keyspec) "Remove a binding for a KEYSPEC in a KEYMAP. @@ -100,15 +334,16 @@ Example: (undefine-key *paredit-mode-keymap* \"C-k\")" bindings))) (defun undefine-key-internal (keymap keys) - (loop :with table := (keymap-table keymap) - :for rest :on (uiop:ensure-list keys) - :for k := (car rest) - :do (cond ((null (cdr rest)) - (remhash k table)) - (t - (let ((next (gethash k table))) - (when (prefix-command-p next) - (setf table next))))))) + (labels ((search-tree (binding keys-to-find) + (when (and keys-to-find (typep binding 'keymap)) + (let ((matches (find-prefix-matches binding (car keys-to-find) :active-only t))) + (loop for match in matches + for suffix = (prefix-suffix match) + do (if (cdr keys-to-find) + (search-tree suffix (cdr keys-to-find)) + (setf (keymap-prefixes binding) + (delete match (keymap-prefixes binding))))))))) + (search-tree keymap keys))) (defun parse-keyspec (string) (labels ((fail () @@ -141,44 +376,119 @@ Example: (undefine-key *paredit-mode-keymap* \"C-k\")" str)))))))) (mapcar #'parse (uiop:split-string string :separator " ")))) -(defun traverse-keymap (keymap fun) - (labels ((f (table prefix) - (maphash (lambda (k v) - (cond ((prefix-command-p v) - (f v (cons k prefix))) - ((keymap-p v) - (f (keymap-table v) (cons k prefix))) - (t (funcall fun (reverse (cons k prefix)) v)))) - table))) - (f (keymap-table keymap) nil))) - -(defgeneric keymap-find-keybind (keymap key cmd) - (:method ((keymap t) key cmd) - (let ((table (keymap-table keymap))) - (labels ((f (k) - (let ((cmd (gethash k table))) - (cond ((prefix-command-p cmd) - (setf table cmd)) - ((keymap-p cmd) - (setf table (keymap-table cmd))) - (t cmd))))) - (let ((parent (keymap-parent keymap))) - (when parent - (setf cmd (keymap-find-keybind parent key cmd)))) - (or (etypecase key - (key - (f key)) - (list - (let (cmd) - (dolist (k key) - (unless (setf cmd (f k)) - (return))) - cmd))) - (gethash cmd (keymap-function-table keymap)) - (keymap-undef-hook keymap) - cmd))))) +(defun find-in-function-table (binding key) + "search function-table of keymaps in hierarchy for KEY." + (search-with-base + binding + (lambda (km) + (cond ((typep km 'keymap*) + (let ((result)) + (maphash (lambda (bound-key bound-cmd) + (when (and (null result) (equal bound-key key)) + (setf result (if (prefix-command-p bound-cmd) + bound-cmd + (make-prefix :key bound-key :suffix bound-cmd))))) + (keymap-function-table km)) + (or result + (loop for child in (keymap-children km) + thereis (or (find-in-function-table child key) + (and (typep child 'keymap*) + (keymap-undef-hook child))))))) + ((typep km 'keymap) + (loop for child in (keymap-children km) + thereis (find-in-function-table child key))))))) + +;; TODO: this search exists because the old sequential keymap code +;; accumulated `cmd' across keymaps, so function-table remapping (e.g. +;; self-insert -> undefined-key in vi *motion-keymap*) happened naturally. +;; the new tree-based keymap-find doesn't accumulate, so we need this explicit +;; search. ideally function-table remapping should be replaced with a mechanism +;; that fits the new keymap design (e.g. prefix properties or keymap flags). +(defun remap-command-in-keymap (keymap cmd) + "search KEYMAP and its children's function-tables for a remapping of CMD. +used to check if a undef-hook command (e.g. self-insert) is remapped by a +higher-priority keymap (e.g. vi normal mode remaps self-insert to undefined-key)." + (or (when (typep keymap 'keymap*) + (gethash cmd (keymap-function-table keymap))) + (dolist (child (keymap-children keymap)) + (when (keymap-active-p child) + (let ((result (remap-command-in-keymap child cmd))) + (when result (return result))))))) + +(defmethod keymap-find ((keymap keymap) key) + "finds key sequence in keymap, returns the matched prefix or nil." + (let ((keyseq (etypecase key + (key (list key)) + (list key)))) + (when (keymap-active-p keymap) + ;; collect prefix matches from the prefixes slot + (let ((prefix-matches + (loop for item in (keymap-prefixes keymap) + when (and (prefix-active-p item) + (equal (prefix-key item) (car keyseq))) + collect item)) + (prefix-found) + (undef-hook-keymap)) + ;; search nested keymaps + (loop for child in (keymap-children keymap) + when (keymap-active-p child) + do (let ((child-result (keymap-find child keyseq))) + (when child-result + (setf prefix-found child-result) + (return))) + ;; record first undef-hook keymap but continue searching + ;; so that function-table remapping can resolve against the base command + (when (and (not undef-hook-keymap) + (typep child 'keymap*) + (keymap-undef-hook child)) + (setf undef-hook-keymap child))) + ;; if a higher-priority keymap had a undef-hook, apply function-table remapping + ;; or fall back to the undef-hook (priority: remap > undef-hook > base cmd). + (when (and undef-hook-keymap prefix-found) + (let* ((cmd (prefix-suffix prefix-found)) + (remapped (gethash cmd (keymap-function-table undef-hook-keymap)))) + (if remapped + (setf prefix-found (make-prefix :key (prefix-key prefix-found) :suffix remapped)) + (setf prefix-found (make-prefix :suffix (keymap-undef-hook undef-hook-keymap)))))) + (or prefix-found + (when undef-hook-keymap + (let* ((hook (keymap-undef-hook undef-hook-keymap)) + (remapped (remap-command-in-keymap keymap hook))) + (make-prefix :suffix (or remapped hook)))) + ;; try collected prefix matches + (loop for match in prefix-matches + for suffix = (prefix-suffix match) + for result = (cond + ;; last key, return the matched prefix. + ((null (cdr keyseq)) + match) + ;; more keys, suffix is a keymap, recurse through keymap-find. + ((typep suffix 'keymap) + (keymap-find suffix (cdr keyseq))) + (t nil)) + when result + return result) + (let ((base (keymap-base keymap))) + (when base + (keymap-find base keyseq)))))))) + +;; this is currently here for backwards compatibility +;; im not yet sure whether 'cmd' or function-table lookup is necessary (i think so but im not sure how to get rid of it.) +(defmethod keymap-find ((keymap keymap*) key) + "finds key sequence in keymap, returns the matched prefix or nil." + (or (call-next-method) + (let ((keyseq (etypecase key + (key (list key)) + (list key)))) + (let ((result (find-in-function-table keymap (car keyseq)))) + (when result + (if (typep result 'prefix) + result + (make-prefix :key (car keyseq) :suffix result))))))) (defun insertion-key-p (key) + (when (and (listp key) (cdr key)) + (return-from insertion-key-p nil)) (let* ((key (typecase key (list (first key)) (otherwise key))) @@ -193,30 +503,67 @@ Example: (undefine-key *paredit-mode-keymap* \"C-k\")" (defgeneric compute-keymaps (global-mode) (:method ((mode global-mode)) nil)) -(defun all-keymaps () - (let* ((keymaps (compute-keymaps (current-global-mode))) - (keymaps - (append keymaps - (alexandria:when-let* ((mode (major-mode-at-point (current-point))) - (keymap (mode-keymap mode))) - (list keymap)) - (loop :for mode :in (all-active-modes (current-buffer)) - :when (mode-keymap mode) - :collect :it)))) +(defun other-keymaps () + (let ((keymaps)) + ;; this one collects active modes. local shadows global. + (dolist (mode (reverse (all-active-modes (current-buffer)))) + (alexandria:when-let ((keymap (mode-keymap mode))) + (push keymap keymaps))) + ;; major mode keymaps at point (context-specific). + (alexandria:when-let* ((mode (major-mode-at-point (current-point))) + (keymap (mode-keymap mode))) + (push keymap keymaps)) + ;; state keymaps (e.g. vi modes) + (dolist (km (reverse (compute-keymaps (current-global-mode)))) + (push km keymaps)) + ;; special keymap (highest priority) (when *special-keymap* (push *special-keymap* keymaps)) - (delete-duplicates (nreverse keymaps)))) + (delete-duplicates keymaps :from-end t))) + +(defvar *other-keymaps-root* + (make-instance 'keymap :description '*other-keymaps-root*)) + +;; this is for some "other" keymaps that i need to inject into the root-keymap (atleast this way for now). +(defmethod keymap-children ((keymap (eql *other-keymaps-root*))) + (other-keymaps)) -(defun lookup-keybind (key &key (keymaps (all-keymaps))) - (let (cmd) - (loop :for keymap :in keymaps - :do (setf cmd (keymap-find-keybind keymap key cmd))) - cmd)) +(defmethod keymap-children ((keymap (eql *root-keymap*))) + (cons *other-keymaps-root* + (slot-value keymap 'children))) + +(defun lookup-keybind (key) + (or (keymap-find *root-keymap* key) + ;; find undef-hook in hierarchy (e.g. self-insert) + (let ((hook (loop for km in (other-keymaps) + when (and (typep km 'keymap*) (keymap-undef-hook km)) + return (keymap-undef-hook km)))) + (when hook + (make-prefix :suffix hook))))) (defun find-keybind (key) - (let ((cmd (lookup-keybind key))) - (when (symbolp cmd) - cmd))) + (let ((prefix (keymap-find *root-keymap* key))) + (when prefix + (prefix-suffix prefix)))) + +(defun traverse-keymap (keymap fun) + (labels ((traverse-prefix (node prefix) + (let ((key (prefix-key node)) + (suffix (prefix-suffix node))) + (cond ((or (typep suffix 'keymap) + (typep suffix 'prefix)) + (traverse-node suffix (cons key prefix))) + (t + (funcall fun (reverse (cons key prefix)) suffix))))) + (traverse-node (node prefix) + (cond ((typep node 'keymap) + (mapc (lambda (p) (traverse-prefix p prefix)) + (keymap-prefixes node)) + (mapc (lambda (child) (traverse-node child prefix)) + (keymap-children node))) + ((typep node 'prefix) + (traverse-prefix node prefix))))) + (traverse-node keymap nil))) (defun collect-command-keybindings (command keymap) (let ((bindings '())) @@ -230,8 +577,9 @@ Example: (undefine-key *paredit-mode-keymap* \"C-k\")" (defun abort-key-p (key) (and (key-p key) - (eq *abort-key* (lookup-keybind key)))) + (let ((prefix (lookup-keybind key))) + (and prefix (eq *abort-key* (prefix-suffix prefix)))))) (defmacro with-special-keymap ((keymap) &body body) `(let ((*special-keymap* (or ,keymap *special-keymap*))) - ,@body)) + ,@body)) \ No newline at end of file diff --git a/src/mode.lisp b/src/mode.lisp index 50216181b..63846624f 100644 --- a/src/mode.lisp +++ b/src/mode.lisp @@ -149,8 +149,8 @@ ,@(when mode-hook `((defvar ,mode-hook '()))) ,@(when keymap - `((defvar ,keymap (make-keymap :name ',keymap - :parent ,(when parent-mode + `((defvar ,keymap (make-keymap :description ',keymap + :base ,(when parent-mode `(mode-keymap ',parent-mode)))))) (define-command (,major-mode (:class ,command-class-name)) () () (clear-editor-local-variables (current-buffer)) @@ -205,7 +205,7 @@ (let ((command-class-name (make-mode-command-class-name minor-mode))) `(progn ,@(when keymapp - `((defvar ,keymap (make-keymap :name ',keymap)))) + `((defvar ,keymap (make-keymap :description ',keymap)))) (define-command (,minor-mode (:class ,command-class-name)) (&optional (arg nil arg-p)) (:universal) (cond ((not arg-p) (toggle-minor-mode ',minor-mode)) @@ -252,8 +252,8 @@ `(progn ,@(when keymap `((defvar ,keymap - (make-keymap :name ',keymap - :parent (alexandria:when-let ((,parent-mode + (make-keymap :description ',keymap + :base (alexandria:when-let ((,parent-mode ,(when parent `(get-mode-object ',parent)))) (mode-keymap ,parent-mode)))))) diff --git a/src/window/side-window.lisp b/src/window/side-window.lisp index bfad7c1d2..7a5d62eac 100644 --- a/src/window/side-window.lisp +++ b/src/window/side-window.lisp @@ -97,3 +97,47 @@ (window-height window)) (balance-windows) t))) + +(defclass bottomside-window (side-window) ()) + +(defun make-bottomside-window (buffer &key (height 10)) + "create a bottom-side window displaying BUFFER with the given HEIGHT. + +if a bottom-side window already exists, switch its buffer instead." + (let ((frame (current-frame))) + (cond ((frame-bottomside-window frame) + (let ((window (frame-bottomside-window frame))) + (set-window-buffer window buffer) + window)) + (t + (let* ((y (- (display-height) height)) + (window (make-instance 'bottomside-window + :buffer buffer + :x (topleft-window-x frame) + :y y + :width (max-window-width frame) + :height height + :use-modeline-p nil + :background-color nil + :border 0))) + (setf (frame-bottomside-window frame) window) + (balance-windows) + window))))) + +(defun delete-bottomside-window () + "delete the bottom-side window." + (let ((frame (current-frame))) + (when (frame-bottomside-window frame) + (delete-window (frame-bottomside-window frame)) + (setf (frame-bottomside-window frame) nil) + (balance-windows)))) + +(defun resize-bottomside-window (window height) + "resize the bottom-side WINDOW to HEIGHT lines and reposition it." + (check-type window bottomside-window) + (let ((frame (current-frame))) + (window-set-size window (max-window-width frame) height) + (window-set-pos window + (topleft-window-x frame) + (- (display-height) height)) + (balance-windows))) diff --git a/src/window/window.lisp b/src/window/window.lisp index 87f060cd7..17e5d6e98 100644 --- a/src/window/window.lisp +++ b/src/window/window.lisp @@ -1047,6 +1047,8 @@ You can pass in the optional argument WINDOW-LIST to replace the default (window-set-size window (display-width) 1)) (alexandria:when-let (window (frame-rightside-window (current-frame))) (resize-rightside-window window)) + (alexandria:when-let (window (frame-bottomside-window (current-frame))) + (resize-bottomside-window window (window-height window))) (balance-windows)) (defun update-on-display-resized ()