Skip to content

Instantly share code, notes, and snippets.

@minad

minad/polyp.md

Last active Nov 11, 2020
Embed
What would you like to do?
Polyp: Small child of the Hydra

Polyp: Small child of the Hydra

;; The undo keybindings `C-x u` and `C-_` enter the polyp.
(defpolyp polyp-undo
  "_u_ndo  _r_edo"
  ("u" undo-fu-only-undo "C-x u" "C-_")
  ("r" undo-fu-only-redo))

I wanted to learn how Hydra and transient keymaps works, so I made a small version of it called Polyp. Obviously it is more restricted than the grown up Hydra. I reuse the lv-message mechanism of Hydra to show the hints.

There is a single macro defpolyp, where you specify the name, a possible hint and a list of bindings. Bindings specify a key, the function name and the type of the binding. Bindings can either :hide or show the Polyp. For bindings which show the Polyp, the global keybindings can be specified. The macro defines a function name which enters the Polyp. Furthermore defpolyp generates a function name/function for each binding.

NOTE: While I have been an Emacs user for quite some time, I wouldn't consider myself well-versed in Elisp. Please feel free to point out mistakes or provide any kind of other feedback!

Some examples

I am mostly using Hydra (or Polyp) for small modal keybindings, like the polyp-undo shown above.

(defpolyp polyp-buffer
  "_←_ buffer _→_"
  ("<prior>" previous-buffer "C-<next>")
  ("<next>"  next-buffer     "C-<prior>"))

No hint is shown for polyp-move.

(defpolyp polyp-move
  nil ;; No hint!
  ("n" next-line           "C-n")
  ("p" previous-line       "C-p")
  ("f" forward-char        "C-f")
  ("b" backward-char       "C-b")
  ("N" (forward-line 5)    "C-S-n")
  ("P" (forward-line -5)   "C-S-p")
  ("F" (forward-char 5)    "C-S-f")
  ("B" (backward-char 5)   "C-S-b")
  ("v" scroll-up-command   "C-v")
  ("V" scroll-down-command "C-S-v")
  ("l" recenter-top-bottom "C-l")
  ("a" move-beginning-of-line)
  ("e" move-end-of-line))

The window management Polyp polyp-win is entered with C-x w.

(bind-key "C-x w"
          (defpolyp polyp-win
            "_0123_  _↔↕_:move  _C-↔↕_:resize  _M-↔↕_:swap"
            ("0"         delete-window)
            ("1"         delete-other-windows)
            ("2"         split-window-below)
            ("3"         split-window-right)
            ("<left>"    windmove-left)
            ("<down>"    windmove-down)
            ("<up>"      windmove-up)
            ("<right>"   windmove-right)
            ("C-<up>"    shrink-window)
            ("C-<down>"  enlarge-window)
            ("C-<left>"  shrink-window-horizontally)
            ("C-<right>" enlarge-window-horizontally)
            ("M-<up>"    buffer-swap-up)
            ("M-<down>"  buffer-swap-down)
            ("M-<left>"  buffer-swap-left)
            ("M-<right>" buffer-swap-right)))

The vim-like polyp-nav stays alive even if foreign keys are pressed. An explicit quit head is provided.

(defvar polyp-nav-cursor-color (cdr (assoc 'cursor-color (frame-parameters))))
(bind-key "C-z"
          (defpolyp polyp-nav
            "_hjkl_  _m_ark  _a_nfang  _e_nd  *d*el  *y*ank  *q*uit"
            :pre (set-cursor-color "green")
            :post (set-cursor-color polyp-nav-cursor-color)
            :foreign 'ignore
            ("h" backward-char)
            ("j" next-line)
            ("k" previous-line)
            ("l" forward-char)
            ("H" (backward-char 5))
            ("J" (forward-line 5))
            ("K" (forward-line -5))
            ("L" (forward-char 5))
            ("m" set-mark-command)
            ("a" move-beginning-of-line)
            ("e" move-end-of-line)
            ("d" delete-region :hide) ;; Note the :hide!
            ("y" kill-ring-save :hide)
            ("q" ignore :hide)))

There is support for pre- and post-actions.

(defpolyp polyp-line
  "_g_oto  _m_ark"
  :pre (linum-mode 1)
  :post (linum-mode -1)
  ("g" goto-line "M-g g")
  ("m" set-mark-command))

The macro

(defun polyp--set-transient-map (map pred exit)
  (let* ((clearfun (make-symbol "polyp--clear-transient-map"))
         (pushfun (lambda ()
                    (add-hook 'pre-command-hook clearfun)
                    (internal-push-keymap map 'overriding-terminal-local-map)))
         (popfun (lambda ()
                   (internal-pop-keymap map 'overriding-terminal-local-map)
                   (remove-hook 'pre-command-hook clearfun)))
         (actfun (lambda (f)
                    (funcall popfun)
                    (if f (unwind-protect (call-interactively f) (funcall pushfun))
                      (funcall exit)))))
    (fset clearfun (lambda ()
                     (unless (funcall pred)
                       (funcall popfun)
                       (funcall exit))))
    (funcall pushfun)
    actfun))

(defmacro defpolyp (name hint &rest opts)
  (let ((opt-map (plist-get opts :map))
        (opt-foreign (plist-get opts :foreign))
        (opt-pre (plist-get opts :pre))
        (opt-post (plist-get opts :post))
        (km  (intern (format "%s/map" name)))
        (act (intern (format "%s/active" name)))
        (show nil)
        (hide nil)
        (rest nil))

    ;; Apply colors to the hint if there is one.
    (when hint
      (save-match-data
        (while (string-match "\\([_*=]\\)\\([^_*=]+\\)\\1" hint)
          (let ((face (pcase-exhaustive (match-string 1 hint)
                        ("_" 'font-lock-function-name-face)
                        ("*" 'font-lock-constant-face)
                        ("=" 'font-lock-warning-face))))
            (setq hint (replace-match (propertize (match-string 2 hint) 'face face) t nil hint)))))
      (setq show `(lv-message ,hint)
            hide '(lv-delete-window)))
    (add-face-text-property 0 (length hint) `(:height ,(face-attribute 'mode-line :height)) nil hint)

    ;; Filter options
    (let ((tmp opts))
      (while tmp
        (if (memq (car tmp) '(:map :pre :post :foreign))
            (setq tmp (cddr tmp))
          (setq rest (cons (car tmp) rest))
          (setq tmp (cdr tmp))))
      (setq rest (nreverse rest)))

    `(progn
       (defvar ,km (copy-keymap universal-argument-map)
         ,(format "Transient keymap of polyp `%s'." name))
       (define-key ,km [switch-frame] nil)
       (defvar ,act nil
         ,(format "Non-nil if polyp `%s' is active." name))

       ;; The main function of the polyp
       (defun ,name ()
         ,(format "Enter polyp `%s'." name)
         (interactive)
         (unless ,act
           ,opt-pre
           ,show
           (setq ,act (polyp--set-transient-map ,km
              ;; Predicate function of persistent, transient maps.
              (lambda ()
                (cond
                 ;; Always honor handle-switch-frame/keyboard-quit and exit.
                 ((memq this-command '(handle-switch-frame keyboard-quit)) nil)

                 ;; Key found - keep the transient map alive.
                 ((eq this-command (lookup-key ,km (this-single-command-keys))) t)

                 ;; Foreign key
                 (t ,@(pcase-exhaustive opt-foreign
                        (`'run '(t))
                        (`'ignore '((setq this-command 'ignore) t))
                        ('nil '(nil))))))

              ;; Exit function of the transient map - hide the polyp.
              (lambda ()
                (when ,act
                  (setq ,act nil)
                  ,hide
                  ,opt-post))))))

       ;; Generate code for the bindings
       ,@(mapcar
          (lambda (bind)
            (pcase-exhaustive bind
              ;; Binding which hides the polyp
              (`(,key ,fun :hide)
               `(define-key ,km ,(kbd key)
                  (defun ,(intern (format "%s/%s" name fun)) ()
                    ,(format "Hide polyp `%s' and call `%s'." name fun)
                    (interactive)
                    (when ,act (funcall ,act nil))
                    ,(if (symbolp fun)
                         `(call-interactively ',fun)
                       fun))))

              ;; Binding which shows the polyp
              (`(,key ,fun . ,keys)
               (let* ((id (intern (format "%s/%s" name fun))))
                 `(progn
                    ;; Generate show function
                    (defun ,id ()
                      ,(format "Show polyp `%s' and call `%s'." name fun)
                      (interactive)
                      (,name)
                      (funcall ,act ,(if (symbolp fun)
                                         `',fun
                                       `(lambda () (interactive) ,fun))))

                    ;; Add the key to the transient keymap
                    (define-key ,km ,(kbd key) ',id)

                    ;; Add global bindings to both the global the transient keymap
                    ,@(mapcar (lambda (g) `(progn
                                             (define-key ,km ,(kbd g) ',id)
                                             (bind-key ,g ',id ,opt-map)))
                              keys))))))
          rest)
       ',name)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.