Overwrite org capture dialouge functions with visally nicer versions

config.org

@@ -968,6 +968,7 @@ Let's setup some org-capture templates
   :commands (doct))
 
 (after! org-capture
+  <<prettify-capture>>
   (add-transient-hook! 'org-capture-select-template
     (setq org-capture-templates
           (doct `((,(format "%s\tPersonal todo" (all-the-icons-octicon "checklist" :face 'all-the-icons-green :v-adjust 0.01))
@@ -1114,6 +1115,116 @@ Let's setup some org-capture templates
                                :file +org-capture-central-project-changelog-file))
                    ))))))
 #+END_SRC
+It would also be nice to improve how the capture dialouge looks
+#+NAME: prettify-capture
+#+BEGIN_SRC emacs-lisp :tangle no
+(defun org-capture-select-template-prettier (&optional keys)
+  "Select a capture template, in a prettier way than default
+Lisp programs can force the template by setting KEYS to a string."
+  (let ((org-capture-templates
+         (or (org-contextualize-keys
+              (org-capture-upgrade-templates org-capture-templates)
+              org-capture-templates-contexts)
+             '(("t" "Task" entry (file+headline "" "Tasks")
+                "* TODO %?\n  %u\n  %a")))))
+    (if keys
+        (or (assoc keys org-capture-templates)
+            (error "No capture template referred to by \"%s\" keys" keys))
+      (org-mks org-capture-templates
+               "Select a capture template\n━━━━━━━━━━━━━━━━━━━━━━━━━"
+               "Template key: "
+               `(("q" ,(concat (all-the-icons-octicon "stop" :face 'all-the-icons-red :v-adjust 0.01) "\tAbort")))))))
+(advice-add 'org-capture-select-template :override #'org-capture-select-template-prettier)
+
+(defun org-mks-pretty (table title &optional prompt specials)
+  "Select a member of an alist with multiple keys. Prettified.
+
+TABLE is the alist which should contain entries where the car is a string.
+There should be two types of entries.
+
+1. prefix descriptions like (\"a\" \"Description\")
+   This indicates that `a' is a prefix key for multi-letter selection, and
+   that there are entries following with keys like \"ab\", \"ax\"…
+
+2. Select-able members must have more than two elements, with the first
+   being the string of keys that lead to selecting it, and the second a
+   short description string of the item.
+
+The command will then make a temporary buffer listing all entries
+that can be selected with a single key, and all the single key
+prefixes.  When you press the key for a single-letter entry, it is selected.
+When you press a prefix key, the commands (and maybe further prefixes)
+under this key will be shown and offered for selection.
+
+TITLE will be placed over the selection in the temporary buffer,
+PROMPT will be used when prompting for a key.  SPECIALS is an
+alist with (\"key\" \"description\") entries.  When one of these
+is selected, only the bare key is returned."
+  (save-window-excursion
+    (let ((inhibit-quit t)
+    (buffer (org-switch-to-buffer-other-window "*Org Select*"))
+    (prompt (or prompt "Select: "))
+    case-fold-search
+    current)
+      (unwind-protect
+    (catch 'exit
+      (while t
+        (setq-local evil-normal-state-cursor (list nil))
+        (erase-buffer)
+        (insert title "\n\n")
+        (let ((des-keys nil)
+        (allowed-keys '("\C-g"))
+        (tab-alternatives '("\s" "\t" "\r"))
+        (cursor-type nil))
+    ;; Populate allowed keys and descriptions keys
+    ;; available with CURRENT selector.
+    (let ((re (format "\\`%s\\(.\\)\\'"
+          (if current (regexp-quote current) "")))
+          (prefix (if current (concat current " ") "")))
+      (dolist (entry table)
+        (pcase entry
+          ;; Description.
+          (`(,(and key (pred (string-match re))) ,desc)
+           (let ((k (match-string 1 key)))
+       (push k des-keys)
+       ;; Keys ending in tab, space or RET are equivalent.
+       (if (member k tab-alternatives)
+           (push "\t" allowed-keys)
+         (push k allowed-keys))
+       (insert (propertize prefix 'face 'font-lock-comment-face) (propertize k 'face 'bold) (propertize "›" 'face 'font-lock-comment-face) "  " desc "…" "\n")))
+          ;; Usable entry.
+          (`(,(and key (pred (string-match re))) ,desc . ,_)
+           (let ((k (match-string 1 key)))
+       (insert (propertize prefix 'face 'font-lock-comment-face) (propertize k 'face 'bold) "   " desc "\n")
+       (push k allowed-keys)))
+          (_ nil))))
+    ;; Insert special entries, if any.
+    (when specials
+      (insert "─────────────────────────\n")
+      (pcase-dolist (`(,key ,description) specials)
+        (insert (format "%s   %s\n" (propertize key 'face '(bold all-the-icons-red)) description))
+        (push key allowed-keys)))
+    ;; Display UI and let user select an entry or
+    ;; a sub-level prefix.
+    (goto-char (point-min))
+    (unless (pos-visible-in-window-p (point-max))
+      (org-fit-window-to-buffer))
+    (let ((pressed (org--mks-read-key allowed-keys prompt)))
+      (setq current (concat current pressed))
+      (cond
+       ((equal pressed "\C-g") (user-error "Abort"))
+       ;; Selection is a prefix: open a new menu.
+       ((member pressed des-keys))
+       ;; Selection matches an association: return it.
+       ((let ((entry (assoc current table)))
+          (and entry (throw 'exit entry))))
+       ;; Selection matches a special entry: return the
+       ;; selection prefix.
+       ((assoc current specials) (throw 'exit current))
+       (t (error "No entry available")))))))
+  (when buffer (kill-buffer buffer))))))
+(advice-add 'org-mks :override #'org-mks-pretty)
+#+END_SRC
 **** Nicer headings
 Thanks to alphapapa's [[https://github.com/alphapapa/unpackaged.el#export-to-html-with-useful-anchors][unpackaged.el]].
 Unfortunately this currently seems to break some of the other modifications I've made.