How can I create custom menu prompts in elisp?

Question

I have two elisp functions:

$ cat ~/myelisp/myoptions.el

(defun get-my-name (arg)
  "Prompt user to enter a string, with input history support."
  (interactive
   (list
    (read-string "Enter your name: ")))
  (message "Your name is %s." arg))

(defun get-my-directory (arg)
  "Prompt user to enter a file path, with file name completion
and input history support."
  (interactive
   (list
    (read-file-name "Enter your directory: ")))
  (message "Path is: %s" arg))

I'd like to organize these functions into a menu. Ideally, I would like to be able to issue something like M-x my-info and have a buffer pop up displaying something like

Press key for command:
----------------------
n Get user's name
d Get user's directory

q quit

Of course, pressing n should call get-my-name and pressing d should call get-my-directory. I've seen similar menus in many emacs packages (like org-agenda, for example). Is this menu easy to code in elisp?

Answer 1

A much simpler way, using a hydra, is

(require 'hydra)
(defhydra my-info (nil nil :foreign-keys nil :hint nil :exit t)
  "
Press key for command:
----------------------
_n_ Get user's name
_d_ Get user's directory

_q_ quit"
  ("q" nil)
  ("n" get-my-name)
  ("d" get-my-directory))
(global-set-key (kbd "C-c u") 'my-info/body)

Answer 2

The function choices is a variation of org-capture and the variable choices-template is a variation of org-capture-templates.

USAGE:  M-x choices

(require 'cl)

(defcustom choices-template
  '(("1" "Group 1")
    ("1a" "Sub-Function #1a" butterfly)
    ("1b" "Sub-Function #1b" help-for-help)
    ("2" "Function #2" (lambda () "test 2"))
    ("3" "Function #3" (lambda () "test 3"))
    ("4" "Function #4" (lambda () "test 4"))
    ("5" "Function #5" (lambda () "test 5"))
    ("6" "Function #6" (lambda () "test 6"))
    ("7" "Function #7" (lambda () "test 7"))
    ("8" "Function #8" (lambda () "test 8"))
    ("9" "Function #9" (lambda () "test 9")))
  "Templates for the creation of new entries.
keys         The keys that will select the template, as a string, characters
             only, for example \"a\" for a template to be selected with a
             single key, or \"bt\" for selection with two keys.  When using
             several keys, keys using the same prefix key must be together
             in the list and preceded by a 2-element entry explaining the
             prefix key, for example
                     (\"b\" \"Templates for marking stuff to buy\")
             The \"C\" key is used by default for quick access to the
             customization of the template variable.  But if you want to use
             that key for a template, you can.
description  A short string describing the template, will be shown during
             selection.
function     The function that will be called -- user either a symbol or a lambda form."
  :group 'choices
  :version "25.1"
  :type
  '(repeat
    (choice :value ("" "" "")
      (list :tag "Multikey description"
        (string :tag "Keys       ")
        (string :tag "Description"))
      (list :tag "Template entry"
        (string :tag "Keys           ")
        (string :tag "Description    ")
        (choice :tag "Function       "
          (const :format "" function)
          (sexp :tag "  Function"))))))

(defun choices (&optional verbose)
(interactive)
  (let* (
      (orig-buf (current-buffer))
      (wrap-it-up
        (lambda ()
          (when (get-buffer "*CHOICES*")
            (when (get-buffer-window "*CHOICES*")
              (delete-window (get-buffer-window "*CHOICES*")))
            (kill-buffer "*CHOICES*"))))
      (entry
        (let ((templates choices-template)
              (inhibit-quit t)
              tbl orig-table dkey ddesc des-keys allowed-keys
              current prefix rtn re pressed)
            (set-buffer (get-buffer-create "*CHOICES*"))
            (setq orig-table templates)
            (catch 'exit
              (while t
                (erase-buffer)
                (insert "Make a choice\n=========================\n\n")
                (setq tbl templates
                      des-keys nil
                      allowed-keys nil
                      cursor-type nil
                      prefix (if current (concat current " ") ""))
                (while tbl
                  (cond
                   ((and (= 2 (length (car tbl))) (= (length (caar tbl)) 1))
                    ;; This is a description on this level
                    (setq dkey (caar tbl)
                          ddesc (cadar tbl))
                    (pop tbl)
                    (push dkey des-keys)
                    (push dkey allowed-keys)
                    (insert
                      prefix
                      "["
                      (propertize dkey 'face '(:foreground "magenta"))
                      "] ... "
                      ddesc
                      " ...\n")
                    ;; Skip keys which are below this prefix
                    (setq re (concat "\\`" (regexp-quote dkey)))
                    (let (case-fold-search)
                      (while (and tbl (string-match re (caar tbl)))
                        (pop tbl))))
                   ((= 2 (length (car tbl)))
                    ;; Not yet a usable description, skip it
                    )
                   (t
                    ;; usable entry on this level
                    (insert
                      (propertize prefix 'face '(:foreground "orangered"))
                      "["
                      (propertize
                        (if (stringp (caar tbl))
                          (caar tbl)
                          (format "%s" (caar tbl)))
                        'face '(:foreground "red"))
                      "]  "
                      (propertize
                        (if (stringp (nth 1 (car tbl)))
                          (nth 1 (car tbl))
                          (format "%s" (nth 1 (car tbl))))
                        'face '(:foreground "green"))
                      "  "
                      (let ((len 15)
                            (s (if (symbolp (nth 2 (car tbl)))
                                 (symbol-name (nth 2 (car tbl)))
                                 (format "%s" (nth 2 (car tbl))))))
                        (if (> (length s) len)
                          (concat (substring s 0 len) " ...")
                          s))
                      "\n")
                    (push (caar tbl) allowed-keys)
                    (pop tbl))))
                (insert "------------------------------------\n")
                (let ((sp '(("C" "Customize `choices-template'")
                            ("q" "Abort"))))
                  (while sp
                    (insert
                        "["
                        (propertize (format "%s" (caar sp))
                          'face '(:foreground "orange"))
                        "]  "
                        (format "%s" (nth 1 (car sp)))
                        "\n")
                    (push (caar sp) allowed-keys)
                    (pop sp)))
                (push "\C-g" allowed-keys)
                (goto-char (point-min))
                (display-buffer (get-buffer "*CHOICES*") t)
                (setq pressed (char-to-string (read-char-exclusive "Choose ...")))
                (while (not (member pressed allowed-keys))
                  (message "Invalid key `%s'" pressed) (sit-for 1)
                  (setq pressed (char-to-string (read-char-exclusive "Select:  "))))
                (when (equal pressed "\C-g")
                  (let ((debug-on-quit nil))
                    (funcall wrap-it-up)
                    (signal 'quit '("You pressed `C-g' and chose to abort."))))
                (when (and (not (assoc pressed templates))
                           (not (member pressed des-keys))
                           (assoc pressed '(("C" "Customize `choices-template'")
                                            ("q" "Abort"))))
                  (throw 'exit (setq rtn pressed)))
                (unless (member pressed des-keys)
                  (throw 'exit (setq rtn (rassoc (cdr (assoc pressed templates))
                         orig-table))))
                (setq current (concat current pressed))
                (setq templates (mapcar
                       (lambda (x)
                   (if (and (> (length (car x)) 1)
                      (equal (substring (car x) 0 1) pressed))
                       (cons (substring (car x) 1) (cdr x))
                     nil))
                       templates))
                (setq templates (remove nil templates))))
            (funcall wrap-it-up)
            rtn)))
    (cond
      ((equal entry "C")
        (customize-variable 'choices-template))
      ((equal entry "q")
        (let ((debug-on-quit nil))
          (when (get-buffer orig-buf)
            (switch-to-buffer (get-buffer orig-buf)))
          (signal 'quit '("You pressed `q'!"))))
      (t
        (when (listp entry)
          (let ((choice (nth 0 entry))
                (description (nth 1 entry))
                (function (nth 2 entry)))
            (if (functionp function)
              (funcall function)
              (let ((debug-on-quit nil))
                (signal 'quit `("Something is wrong: %s" ,function))))
            (when verbose
              (message "choice: %s | description: %s | function: %s"
                choice description function))))))))

Answer 3

Here is a popup menu implementation that separates the menu definition from the data so multiple menu's could be defined, each with their own: (prompt, default, content).

Generic popup.

(defun custom-popup (menu-prompt menu-index menu-content) "
Pop up menu
Takes args: menu-prompt, default-index, menu-content).
Where the content is any number of (string, function) pairs, each representing a menu item.
User can hit just the first char of a menu item to choose it.
Or click it with `mouse-1' or `mouse-2' to select it.
Or hit RET immediately to select the default item.
"
  (interactive)
  (let*
    (
      (icicle-Completions-max-columns               1)
      (icicle-show-Completions-initially-flag       t)
      (icicle-incremental-completion-delay          0.01)
      (icicle-top-level-when-sole-completion-flag   t)
      (icicle-top-level-when-sole-completion-delay  0.01)
      (icicle-default-value                         t)
      (icicle-show-Completions-help-flag            nil)
      ;; Don't sort when 'completing-read' from 'ivy' is in use.
      (ivy-sort-functions-alist nil)
      (choice
        (completing-read
          ;; menu prompt & content
          menu-prompt menu-content nil t nil nil
          ;; default index
          (nth menu-index menu-content)))
      (action  (cdr (assoc choice menu-content))))
    (funcall action)))

Example use, assign some actions to the f12 key:

(defvar
  my-global-utility-menu-def
  ;; (content, prompt, default_index)
  '(("Emacs REPL" . ielm)
    ("Spell Check" . ispell-buffer)
    ("Delete Trailing Space In Buffer" . delete-trailing-whitespace)
    ("Emacs Edit Init" . (lambda () (find-file user-init-file))))

(defun my-global-utility-popup ()
  "Pop up my menu. Hit RET immediately to select the default item."
  (interactive)
  (custom-popup my-global-utility-menu-def "Select: ", 1))

(global-set-key (kbd "<f12>") 'my-global-utility-popup)