Download
(eval-when-compile (require 'cl))
(require 'dired)
(require 'hexrgb)
(defun one-key-add-elements-to-list (list-var newelts)
"Add elements in list NEWELTS to LIST-VAR if they are not already present and return the resulting list."
(let ((listval (symbol-value list-var)))
(append listval (loop for elt in newelts
unless (member elt listval)
collect elt))))
(defun one-key-add-to-alist (alist-var elt-cons &optional no-replace)
"Add to the value of ALIST-VAR an element ELT-CONS if it isn't there yet, and return the new list.
If an element with the same car as the car of ELT-CONS is already present,
replace it with ELT-CONS unless NO-REPLACE is non-nil
element is not already present, add ELT-CONS to the front of the alist.
The test for presence of the car of ELT-CONS is done with `equal'."
(let ((existing-element (assoc (car elt-cons) (symbol-value alist-var))))
(if existing-element
(or no-replace
(setcdr existing-element (cdr elt-cons)))
(set alist-var (cons elt-cons (symbol-value alist-var)))))
(symbol-value alist-var))
(defun one-key-add-elements-to-alist (alist-var newelts &optional no-replace)
"Use `one-key-add-to-alist' to add each element of NEWELTS to ALIST-VAR.
NO-REPLACE has the same meaning as in `one-key-add-to-alist'."
(loop for elt in newelts do
(one-key-add-to-alist alist-var elt no-replace))
(symbol-value alist-var))
(defun one-key-assq-list (symlist alist)
"Return a list of the cdr's of elements of ALIST whose car's match a symbol in SYMLIST.
The matching is performed with assq so that only the first element of alist matching a symbol in SYMLIST is returned.
The elements returned will be in the same order as the elements of SYMLIST."
(mapcar 'cdr (loop for symbol in symlist collect (assq symbol alist))))
(defun one-key-eval-if-symbol (sexp)
"If SEXP is a symbol return the result of eval'ing it, otherwise return SEXP."
(if (symbolp sexp) (eval sexp) sexp))
(defun one-key-get-special-key-contents (specialkeys)
"Given a symbol or list of symbols from `one-key-special-keybindings', return the corresponding contents for each symbol.
The first element of the contents of each item will be replaced by a key description string by following symbol references
in `one-key-special-keybindings'.
In other words if `one-key-special-keybindings' contains the items (symba symbb \"descriptiona\" commanda), and
(symbb \"a\" \"descriptionb\" commandb), then (one-key-get-special-key-contents '(symba symbb)) will return '((\"a\" \"descriptiona\" commanda) (\"b\" \"descriptionb\" commandb)). Notice that symbb is replaced by \"a\" in the returned list since
this is the key description for symbb. At most 5 symbolic links will be followed before setting the key to nil."
(let* ((symbs (if (listp specialkeys) specialkeys
(if (symbolp specialkeys) (list specialkeys)
(error "Invalid argument"))))
(items (one-key-assq-list symbs one-key-special-keybindings)))
(loop for (key . rest) in items
for x = 1
do (while (and key (symbolp key))
(setq key (cadr (assoc key one-key-special-keybindings)))
(if (> x 4) (setq key nil) (setq x (1+ x))))
collect (cons key (if key rest (list "undefined key!"))))))
(defun one-key-get-special-key-descriptions (specialkeys)
"Given a symbol or list of symbols from `one-key-special-keybindings', return the corresponding key descriptions.
This can be used to find out which special keys are used for a particular one-key menu type.
If `specialkeys' is a single symbol then a single string will be returned.
If `specialkeys' is a list then a list of strings will be returned."
(let* ((keys (mapcar 'car (one-key-get-special-key-contents specialkeys)))
(len (length keys)))
(if (> len 1) keys (car keys))))
(defgroup one-key nil
"One key - easy access, refactorable menus."
:group 'editing
:link '(url-link "http://www.emacswiki.org/OneKey"))
(defgroup one-key-menu-sets nil
"One key menu sets - sets of one-key menus."
:group 'one-key)
(defcustom one-key-default-menu-keys
(let (letters-and-numbers)
(dotimes (i 26)
(push (- ?Z i) letters-and-numbers))
(dotimes (i 26)
(push (- ?z i) letters-and-numbers))
(dotimes (i 10)
(push (- ?9 i) letters-and-numbers))
letters-and-numbers)
"A list of chars which may be used as the default keys in automatically generated `one-key' menus.
This list will be used for generating keys by the `one-key-generate-key' function."
:group 'one-key
:type '(repeat character))
(defcustom one-key-min-keymap-submenu-size 4
"The minimum number of elements allowed in a submenu when creating menus from keymaps.
When creating menus from keymaps with `one-key-create-menus-from-keymap', submenus will be created for any prefix keys in
the keymap. These submenus contain the commands whose keybindings start with the corresponding prefix key.
If the number of items in a submenu would be less than `one-key-min-keymap-submenu-size' then instead of creating a submenu,
those items will be merged with the parent menu instead."
:type 'integer
:group 'one-key)
(defcustom one-key-window-toggle-sequence '(0.3 1.0 close)
"List of numbers & symbols indicating the sequence of actions to perform on successive calls to `one-key-menu-window-toggle'.
Possible values in this list are:
A positive integer : indicates maximum size of one-key window in lines.
Floating point number between 0.0 & 1.0 : indicates maximum size of one-key window as fraction of the frame (or whole screen
if it has a frame to itself).
Symbol 'close : indicates to close the one-key window (but not kill the buffer).
Symbol 'deselect : indicates to keep the one-key window open but move focus to the associated window.
Symbol 'ownframe : indicates to place the one-key window in its own frame. Once one-key has it's own frame the window cannot be placed back in another frame without closing it first.
Symbol 'showhelp : show the *Help* buffer (see `one-key-window-help-buffer-own-frame').
Symbol 'hidehelp : hide the *Help* buffer.
A cons cell whose car is a symbol indicating the state to switch to, and whose cdr is an integer or float indicating the
size of the window after switching (interpreted in the same way as above).
At the moment the car is fixed to ownframe, but more states will be added soon."
:type '(repeat (choice (integer :tag "Max number of lines")
(float :tag "Max height as fraction of frame/screen")
(const :tag "Return focus to previous window/buffer" deselect)
(const :tag "Open window in own frame" ownframe)
(const :tag "Show the one-key help buffer" showhelp)
(const :tag "Hide the one-key help buffer" hidehelp)
(const :tag "Close window" close)
(cons :tag "Pair"
(choice (const :tag "Open window in own frame" ownframe))
(choice (integer :tag "Max number of lines")
(float :tag "Max height as fraction of frame/screen")))))
:group 'one-key)
(defvar one-key-window-toggle-pos 0
"The position in `one-key-window-toggle-sequence' indicating the current one-key window state.")
(defcustom one-key-buffer-name "*One-Key*"
"The buffer name of the one-key menu window."
:type 'string
:group 'one-key)
(defcustom one-key-help-buffer-name "*One-Key Help*"
"The name of the help buffer for one-key."
:type 'string
:group 'one-key)
(defcustom one-key-column-major-order t
"If true then menu items are displayed in column major order, otherwise row major order.
In column major order items will fill first column, then second, etc.
In row major order the rows are filled one at a time."
:type 'boolean
:group 'one-key)
(defcustom one-key-min-number-of-columns 2
"An integer greater than 0 indicating the minimum number of columns to create for one-key menus.
Items in one-key menus will have their descriptions shortened (in the `one-key-format' function) so that the indicated
number of columns can be created."
:type '(choice (const :tag "One column" 1)
(const :tag "Two columns" 2)
(const :tag "Three columns" 3)
(const :tag "Four columns" 4))
:group 'one-key)
(defcustom one-key-menu-window-max-height nil
"The max height of popup menu window."
:type 'int
:set (lambda (symbol value)
(set symbol value)
(unless value
(set symbol (/ (frame-height) 2))))
:group 'one-key)
(defcustom one-key-menus-save-file "~/.emacs.d/one-key-menus-save-file.el"
"The file where `one-key' menus are saved."
:type 'file
:group 'one-key)
(defcustom one-key-autosave-menus nil
"If non-nil then one-key menus will automatically be saved when created or changed."
:type 'boolean
:group 'one-key)
(defcustom one-key-exclude-from-save '("^prefix-key" "^major-mode")
"List of regular expressions matching names of menus which should not be autosaved."
:type '(repeat (regexp :tag "Regexp" :help-echo "Regular expression matching menu names to exclude from autosave." ))
:group 'one-key)
(defcustom one-key-include-menubar-items t
"Whether or not to include menu items with no keybinding when creating one-key menus from keymaps."
:type '(choice (const :tag "Yes" t)
(const :tag "No" nil)
(const :tag "Prompt each time" 'prompt))
:group 'one-key)
(defcustom one-key-item-foreground-colour "black"
"Foreground colour of highlighted items in `one-key' menus."
:type 'color
:group 'one-key)
(defcustom one-key-auto-brighten-used-keys t
"If non-nil then set brightness of menu items colours according to how often the keys are pressed."
:type 'boolean
:group 'one-key)
(defcustom one-key-submenus-replace-parents nil
"If non-nil then when a submenu of a `one-key' menu is opened it will replace the parent menu.
Otherwise a new menu is created to hold the submenu and added to the current menu set."
:type 'boolean
:group 'one-key)
(defcustom one-key-major-mode-remap-alist '((Custom-mode . "custom-mode")
(latex-mode ."LaTeX-mode"))
"A list of cons cells mapping major modes to one-key-menus.
The car of each cell is the symbol of a major mode function (e.g. 'emacs-lisp-mode), and the cdr is the name of
a `one-key' menu associated with the major mode.
When a menu of type \"major-mode\" is opened this alist is checked, and if the current major mode is listed then the
associated menu will be used, otherwise the menu alist with name one-key-menu-???-alist (where ??? is the name of the
current major mode) will be used (and created if necessary)."
:type '(alist :key-type (function :tag "Major mode" :help-echo "A major mode function") :value-type (string :tag "Name of associated menu" :help-echo "The name of the menu to be associated with the major mode"))
:group 'one-key)
(defcustom one-key-menu-toplevel-alist '((("M" . "Cursor motion commands") .
(lambda nil (interactive)
(one-key-open-submenu "Cursor motion commands"
one-key-menu-cursor-motion-commands-alist)))
(("B" . "Buffer and file commands") .
(lambda nil (interactive)
(one-key-open-submenu "Buffer and file commands"
one-key-menu-buffer-and-file-commands-alist)))
(("E" . "Editing commands") .
(lambda nil (interactive)
(one-key-open-submenu "Editing commands"
one-key-menu-editing-commands-alist)))
(("s" . "Search/replace/grep commands") .
(lambda nil (interactive)
(one-key-open-submenu "Search/replace/grep commands"
one-key-menu-searching-commands-alist)))
(("S" . "Sorting commands") .
(lambda nil (interactive)
(one-key-open-submenu "Sorting commands"
one-key-menu-sorting-commands-alist)))
(("W" . "Window commands") .
(lambda nil (interactive)
(one-key-open-submenu "Window commands"
one-key-menu-window-commands-alist)))
(("C-h" . "prefix-key:C-h (help commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-h" t)))
(("<C-escape>" . "prefix-key:ESC (all meta key keybindings)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "ESC" t)))
(("M-g" . "prefix-key:M-g (error commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "M-g" t)))
(("M-o" . "prefix-key:M-o (font-lock/centering commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "M-o" t)))
(("M-s" . "prefix-key:M-s (occur/highlight commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "M-s" t)))
(("C-x" . "prefix-key:C-x (all C-x keybindings)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x" t)))
(("r" . "prefix-key:C-x r (bookmark, rectangle and register commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x r" t)))
(("v" . "prefix-key:C-x v (version control commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x v" t)))
(("a" . "prefix-key:C-x a (abbrev commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x a" t)))
(("n" . "prefix-key:C-x n (narrow/widen commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x n" t)))
(("C-k" . "prefix-key:C-x C-k (keyboard macro commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x C-k" t)))
(("w" . "prefix-key:C-x w (highlight commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x w" t)))
(("RET" . "prefix-key:C-x RET (input/coding commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x RET" t)))
(("4" . "prefix-key:C-x 4 (other-window commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x 4" t)))
(("5" . "prefix-key:C-x 5 (other-frame commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x 5" t)))
(("6" . "prefix-key:C-x 6 (2 column mode commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x 6" t)))
(("C-c" . "prefix-key:C-c (mode specific bindings)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-c" t)))
(("@" . "prefix-key:C-c @ (outline commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-c @" t)))
(("," . "prefix-key:C-c , (senator/semantic commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-c ," t)))
(("." . "prefix-key:C-c . (Ede commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-c ." t)))
(("/" . "prefix-key:C-c / (Srecode commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-c /" t)))
)
"The `one-key' top-level alist.
Contains list of key items for toplevel one-key menu.
Each item contains a key, description and command, in that order.
The key should be entered in the same format as that returned by `describe-key'."
:type '(alist :key-type (cons string string) :value-type function)
:group 'one-key)
(if (featurep 'bookmark+)
(one-key-add-elements-to-alist 'one-key-menu-toplevel-alist
'((("p" . "prefix-key:C-x p (bookmark+ commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x p" t)))
(("j" . "prefix-key:C-x j (bookmark+ jump commands)") .
(lambda nil (interactive)
(funcall 'one-key-prefix-key-menu-command "C-x j" t))))
t))
(defcustom one-key-sets-of-menus-alist (list '("default" "major-mode" "top-level" "menu-sets"))
"Saved menu sets (sets of menus).
Each element in this list is a cons cell whose car is a name or description for the set, and whose cdr is a list of names
of menus which make up the set. Each menu name must correspond to a type in `one-key-types-of-menu' (which see),
and `one-key' must be able to reconstruct the menu from the name (which it will be able to if the corresponding entry
in `one-key-types-of-menu' is complete.
These menu sets may be opened from the \"menu-sets\" menu, and you may want to create different sets for different
projects."
:type '(alist :key-type (string :tag "Set description/name" :help-echo "A name or description for this collection of menus")
:value-type (repeat (string :tag "Menu" :help-echo "The name of the menu. Must correspond to a type in `one-key-types-of-menu'.")))
:group 'one-key-menu-sets)
(defcustom one-key-default-menu-set "default"
"The default menu set. It's value should be the car of one of the items in `one-key-sets-of-menus-alist'.
It may be changed by the user from the menu-sets `one-key' menu.
This is only meaningful if it is used with `one-key-open-menu-set' bound to a key so that the key can open a different
menu set if the user has altered its value."
:type 'string
:group 'one-key-menu-sets)
(defcustom one-key-associations-for-menu-sets nil
"An alist indicating which menu sets should be used with which buffers/major-modes.
Each element is a cons cell whose car is either the symbol for a major-mode or a regular expression, and whose cdr is the
name of a menu set (i.e. the car of an element of `one-key-sets-of-menus-alist').
The `one-key-open-associated-menu-set' command uses this alist to determine which menu set to open.
It will open the first menu set in the list whose car matches either the current major-mode or the name of the current
buffer."
:type '(alist :key-type (choice (symbol :tag "Major mode") (regexp :tag "Regular expression"))
:value-type (string :tag "Name of menu set"))
:group 'one-key-menu-sets)
(defcustom one-key-default-sort-method-alist
'(("key" . (lambda (a b) (string< (caar a) (caar b))))
("description" . (lambda (a b) (string< (cdar a) (cdar b))))
("command" . (lambda (a b) (string< (prin1-to-string (cdr a))
(prin1-to-string (cdr b)))))
("colour hue" . (lambda (a b)
(let* ((bg (cdr (assq 'background-color (frame-parameters))))
(cola (or (cadr (get-text-property 0 'face (cdar a))) bg))
(colb (or (cadr (get-text-property 0 'face (cdar b))) bg))
(hsva (destructuring-bind (r g b) (color-values cola)
(hexrgb-rgb-to-hsv r g b)))
(hsvb (destructuring-bind (r g b) (color-values colb)
(hexrgb-rgb-to-hsv r g b))))
(> (first hsva) (first hsvb)))))
("colour brightness" . (lambda (a b)
(let* ((bg (cdr (assq 'background-color (frame-parameters))))
(cola
(or (cadr (get-text-property 0 'face (cdar a))) bg))
(colb
(or (cadr (get-text-property 0 'face (cdar b))) bg))
(hsva (destructuring-bind (r g b)
(color-values cola)
(hexrgb-rgb-to-hsv r g b)))
(hsvb (destructuring-bind (r g b)
(color-values colb)
(hexrgb-rgb-to-hsv r g b))))
(> (third hsva) (third hsvb)))))
("length" . (lambda (a b) (> (length (cdar a)) (length (cdar b))))))
"An alist of default sorting methods to use on the `one-key' menu items.
Each element is a cons cell of the form (NAME . PREDICATE) where NAME is a symbol for the name of the sort method,
and PREDICATE is a function which takes two items from the `one-key' menu alist as arguments and returns non-nil if
the first item should come before the second in the menu."
:type '(alist :key-type (string :help-echo "Name of sort method")
:value-type (function :help-echo "Predicate that returns non-nil if 1st item comes before 2nd"))
:group 'one-key)
(defcustom one-key-sort-method-indices-alist nil
"An alist indicating the current sort method to use for each menu.
Each element is in the form (NAME . INDEX) pairs where NAME is the name of a menu and INDEX is the position of the current
sort method in the sort methods alist associated with the menu (see `one-key-default-sort-method-alist').
This variable will change whenever you change the sort method for a menu, but you can save this option to fix the default
sort methods for different menus."
:type '(alist :key-type (string :tag "Menu name" :help-echo "Name of menu")
:value-type (integer :tag "Index" :help-echo "Index of default sort method in associated sort methods alist"))
:group 'one-key)
(defcustom one-key-special-keybindings
`((quit-close "q" "Quit and close menu window" (lambda nil (setq one-key-buffer-temp-action 'close)))
(quit-open "C-q" "Quit, but keep menu window open"
(lambda nil (setq one-key-buffer-temp-action 'deselect)))
(toggle-persistence "<C-menu>" "Toggle menu persistence"
(lambda nil (if one-key-buffer-match-action
(setq one-key-buffer-match-action nil
one-key-buffer-miss-match-action nil)
(setq one-key-buffer-match-action 'close
one-key-buffer-miss-match-action 'close))))
(toggle-display "<menu>" "Toggle menu display" one-key-menu-window-toggle)
(next-menu "<left>" "Change to left menu"
(lambda nil (setq one-key-buffer-menu-number
(mod (1- one-key-buffer-menu-number)
(length one-key-buffer-menu-alists))
one-key-default-menu-number one-key-buffer-menu-number)
(one-key-update-buffer-contents)
(one-key-set-window-state
(nth one-key-window-toggle-pos one-key-window-toggle-sequence))))
(prev-menu "<right>" "Change to right menu"
(lambda nil (setq one-key-buffer-menu-number
(mod (1+ one-key-buffer-menu-number)
(length one-key-buffer-menu-alists))
one-key-default-menu-number one-key-buffer-menu-number)
(one-key-update-buffer-contents)
(one-key-set-window-state
(nth one-key-window-toggle-pos one-key-window-toggle-sequence))))
(skip-menus-left "<C-left>" "Skip menus to left"
(lambda nil (let* ((nummenus (length one-key-buffer-menu-alists))
(skipnum (max (round (* nummenus 0.333)) 2)))
(setq one-key-buffer-menu-number
(mod (- one-key-buffer-menu-number skipnum) nummenus)
one-key-default-menu-number one-key-buffer-menu-number)
(one-key-update-buffer-contents)
(one-key-set-window-state
(nth one-key-window-toggle-pos one-key-window-toggle-sequence)))))
(skip-menus-right "<C-right>" "Skip menus to right"
(lambda nil (let* ((nummenus (length one-key-buffer-menu-alists))
(skipnum (max (round (* nummenus 0.333)) 2)))
(setq one-key-buffer-menu-number
(mod (+ one-key-buffer-menu-number skipnum) nummenus)
one-key-default-menu-number one-key-buffer-menu-number)
(one-key-update-buffer-contents)
(one-key-set-window-state
(nth one-key-window-toggle-pos one-key-window-toggle-sequence)))))
(up "<up>" "Scroll/move up one line" one-key-menu-window-scroll-up-line)
(down "<down>" "Scroll/move down one line" ,(apply-partially 'one-key-menu-window-scroll-up-line t))
(scroll-down "<prior>" "Scroll menu down one page" ,(apply-partially 'one-key-menu-window-scroll-up t))
(scroll-up "<next>" "Scroll menu up one page" one-key-menu-window-scroll-up)
(documentation "<S-f1>" "Show one-key documentation"
(lambda nil (finder-commentary (locate-library "one-key"))))
(save-menu "C-s" "Save state of current menu"
(lambda nil (one-key-save-menu one-key-buffer-this-name
one-key-buffer-full-list)))
(toggle-help "<f1>" "Toggle this help buffer"
(lambda nil (if (get-buffer-window one-key-help-buffer-name)
(one-key-set-window-state 'hidehelp)
(one-key-set-window-state 'showhelp)
(one-key-show-help one-key-buffer-special-keybindings))))
(toggle-row/column-order "<f2>" "Toggle column/row ordering of items"
(lambda nil (setq one-key-column-major-order (not one-key-column-major-order))
(one-key-update-buffer-contents)))
(sort-next "<f3>" "Sort items by next method"
,(apply-partially 'one-key-sort-items-by-next-method t))
(sort-prev "<C-f3>" "Sort items by previous method"
,(apply-partially 'one-key-sort-items-by-next-method t t))
(reverse-order "<f4>" "Reverse order of items" one-key-reverse-item-order)
(limit-items "/" "Limit items to those matching regexp"
(lambda nil (setq one-key-buffer-filter-regex
(read-regexp "Regular expression matching items to be filtered"))
(one-key-update-buffer-contents)))
(highlight-items "C-/" "Highlight items matching regexp"
(lambda nil (let ((regex (read-regexp "Regular expression matching items to be coloured"))
(bgcolour (read-color "Colour: ")))
(one-key-highlight-matching-items
bgcolour
(lambda (item) (string-match regex (cdar item)))))))
(edit-item "<f5>" "Edit a menu item" one-key-edit-menu-item)
(delete-item "<f6>" "Delete a menu item" one-key-delete-menu-item)
(kill-items "<f7>" "Copy/kill coloured items" one-key-copy/kill-items)
(yank-items "<C-f7>" "Yank copied items" one-key-yank-items)
(swap-keys "<f8>" "Swap menu item keys" one-key-swap-menu-items)
(add-item "<f9>" "Add a menu item" one-key-prompt-to-add-menu-item)
(add-menu "<C-f9>" "Add a menu" one-key-add-menus)
(remove-menu "<C-S-f9>" "Remove this menu" one-key-delete-menus)
(move-item "<f10>" "Reposition item (with arrow keys)"
(lambda nil (let ((key (one-key-key-description (read-event "Enter key of item to be moved"))))
(setq one-key-current-item-being-moved key))))
(donate "<f11>" "Donate to support further development"
(lambda nil (browse-url "http://onekeydonate.dynalias.net")))
(report-bug "<C-f11>" "Report a bug" one-key-submit-bug-report)
(show-menusets "C-h" "Show menus in menu set"
(lambda nil
(let* ((key (read-event "Enter the key for the menu set"))
(item (one-key-get-menu-item
key one-key-buffer-full-list))
(menuset (assoc (cdar item) one-key-sets-of-menus-alist))
(desc (car menuset))
(names (cdr menuset)))
(message "%S" names))))
(customize-menusets "C-c" "Customize menu sets"
(lambda nil
(one-key-set-window-state 'close)
(with-selected-window (previous-window)
(customize-group 'one-key-menu-sets))))
(change-default-menuset "<f5>" "Change default menu set"
(lambda nil
(let* ((key (read-event "Press the key of item to set as default"))
(item (one-key-get-menu-item
key one-key-buffer-full-list))
(name (cdar item))
(pos (position "menu-sets" one-key-buffer-menu-names :test 'equal)))
(if name (eval `(customize-save-variable 'one-key-default-menu-set
,(substring-no-properties name))))
(if pos (setf (nth pos one-key-buffer-menu-alists)
(one-key-build-menu-sets-menu-alist))))
(one-key-update-buffer-contents)))
(save-menuset save-menu "Save current menu set"
(lambda nil
(let* ((names (mapcar 'car one-key-sets-of-menus-alist))
(newname (read-string "Name for menu set: "))
(validnames
(remq nil
(mapcar
(lambda (name) (if (one-key-get-menu-type name) name))
one-key-buffer-menu-names)))
newset oldsets)
(unless (and (member newname names)
(not (y-or-n-p
"A menu set with that name already exists, overwrite it?")))
(setq newset (if (y-or-n-p "Include \"menu-sets\" menu?")
(append (list newname) validnames)
(remove "menu-sets" (append (list newname) validnames))))
(setq oldsets (remove-if (lambda (item) (string= (car item) newname))
one-key-sets-of-menus-alist))
(if (y-or-n-p "Associate menu set with major-mode?")
(let ((mode (with-selected-window (or one-key-buffer-associated-window
(selected-window))
major-mode)))
(eval `(customize-save-variable 'one-key-associations-for-menu-sets
',(one-key-add-to-alist
'one-key-associations-for-menu-sets
(cons mode newname)))))
(if (y-or-n-p "Associate menu set with current buffer?")
(let ((regex (with-selected-window (or one-key-buffer-associated-window
(selected-window))
(concat "^" (regexp-quote (buffer-name)) "$"))))
(eval `(customize-save-variable 'one-key-associations-for-menu-sets
',(one-key-add-to-alist
'one-key-associations-for-menu-sets
(cons regex newname)))))))
(eval `(customize-save-variable 'one-key-sets-of-menus-alist
',(append oldsets (list newset))))))
(one-key-update-buffer-contents)))
(rebuild-menu "<M-f11>" "Rebuild the menu" one-key-rebuild-menu)
(read-tree-up "RET" "Complete current list"
(lambda nil (setq selected-item 'goup)))
(read-tree-up2 ")" "Complete current list"
(lambda nil (setq selected-item 'goup)))
(read-tree-down "SPC" "Start new list recursively"
(lambda nil (setq selected-item 'godown)))
(read-tree-down2 "(" "Start new list recursively"
(lambda nil (setq selected-item 'godown)))
(read-tree-delete "<backspace>" "Remove last item from list"
(lambda nil (setq selected-item 'del)))
(read-logical-negate "!" "Negate next item" (lambda nil (setq selected-item 'not))))
"An list of special keys
Each item in the list contains (in this order):
1) A symbol to reference the keybinding in the special keybinding sets for different menu types.
2) A string representation of the key (as returned by `one-key-key-description'), or a symbol referencing
another item whose key description should be used instead (this allows you to keep you special keybindings
in sync when you use different items for different menu types).
Warning: make sure you don't end up with a circular set of key references or one-key will get stuck in a loop.
3) A short description of the associated action. This description will be displayed in the one-key help buffer.
4) A function for performing the action. The function takes no arguments but may use the buffer local variables
whose names begin with one-key-buffer- (which see).
These keybindings may be referred to by other variables that contain the special keybindings for different one-key menu
types. See `one-key-default-special-keybindings' for example."
:group 'one-key
:type '(repeat (list (symbol :tag "Name" :help-echo "A reference name for this keybinding (no spaces).")
(string :tag "Keybinding" :help-echo "String representation of the keybinding for this action")
(string :tag "Description" :help-echo "Description to display in help buffer")
(function :tag "Function" :help-echo "Function for performing action. See description below for further details."))))
(defvar one-key-general-special-keybindings
'(quit-close quit-open toggle-persistence toggle-display next-menu prev-menu skip-menus-left skip-menus-right up down
scroll-down scroll-up toggle-help toggle-row/column-order sort-next sort-prev reverse-order)
"Special keybindings that should be used for all menu types.")
(defcustom one-key-default-special-keybindings
(one-key-add-elements-to-list
'one-key-general-special-keybindings
'(help documentation save-menu limit-items highlight-items edit-item delete-item kill-items yank-items swap-keys
add-item add-menu remove-menu move-item donate report-bug rebuild-menu))
"List of special keys to be used if no other set of special keys is defined for a given one-key menu type.
These keys are for performing general tasks on the menu such as sorting items, deleting items, etc.
Each element of this list is a reference to one of the keybindings defined in `one-key-special-keybindings'.
The keys will be displayed in the one-key help buffer in the order shown when the `one-key-show-help' function is executed."
:group 'one-key
:type '(repeat (symbol :tag "Name" :help-echo "The name/symbol corresponding to the keybinding.")))
(defcustom one-key-menu-sets-special-keybindings
(one-key-add-elements-to-list
'one-key-general-special-keybindings
'(show-menusets save-menuset customize-menusets limit-items highlight-items change-default-menuset add-menu
remove-menu donate report-bug))
"List of special keys to be used for menu-sets menus (see `one-key-default-special-keybindings' for more info)."
:group 'one-key
:type '(repeat (symbol :tag "Name" :help-echo "The name/symbol corresponding to the keybinding.")))
(defcustom one-key-major-mode-special-keybindings
(one-key-add-elements-to-list
'one-key-general-special-keybindings
'(help documentation save-menu limit-items highlight-items edit-item delete-item kill-items yank-items swap-keys
add-item add-menu remove-menu move-item donate report-bug rebuild-menu))
"List of special keys to be used for major-mode menus (see `one-key-default-special-keybindings' for more info)."
:group 'one-key
:type '(repeat (symbol :tag "Name" :help-echo "The name/symbol corresponding to the keybinding.")))
(defcustom one-key-disallowed-keymap-menu-keys '("M-TAB")
"List of keys that should be excluded from one-key menus created from keymaps.
Each item in this list is a key description as returned by `one-key-key-description'."
:group 'one-key
:type '(repeat string))
(defcustom one-key-types-of-menu nil
"A list of names of different types of `one-key' menu, and associated functions.
Each item in the list contains (in this order):
1) The name for this menu type.
2) A function which takes a string as its only argument and returns non-nil if that string corresponds to the name of
a menu of this type, otherwise it returns nil. Note: this function should only return non-nil if a menu can be
reconstructed from the name using the next item in this list.
3) A function which takes the menu name as its only argument and returns a cons cell whose car is the new name or list
of names for the menus, and whose cdr is a menu alist, a symbol whose value is a menu alist, or a list of symbols
and/or menu alists. The number of names returned in the car should be equal to the number of menu alists/symbols
returned in the cdr. Alternatively this can be a cons cell whose car is the name/names and whose cdr is the menu
alist/alists.
4) An function that takes no arguments and returns a title string for the `one-key' menu.
The function will be evaluated in the context of the `one-key-highlight-menu' function, and will be processed by
`one-key-highlight' before display. You should look at the `one-key-highlight-menu' function to see which variables
may be used in this format string.
Alternatively if this item is nil then `one-key-default-title-func' will be used.
5) Either a list of special keybindings in the same form as `one-key-default-special-keybindings', or a symbol
whose value is such a list, or nil. If nil then `one-key-default-special-keybindings' will be used.
6) An alist of sort methods to use for this menu type. If nil then `one-key-default-sort-method-alist' will be used.
See the documentation for `one-key-default-sort-method-alist' to see the required format of this variable."
:type '(repeat (list (string :tag "Name"
:help-echo "A name for this menu type.")
(function :tag "Condition"
:help-echo "A function which returns the new menu name(s) when passed a name corresponding to this type, and returns nil otherwise.")
(choice (symbol :tag "Menu alist symbol(s)"
:help-echo "A symbol whose value is a menu alist of keys for menus of this type, or a list of such menus.")
(function :tag "Menu alist function"
:help-echo "A function which takes the menu name as its only argument and returns either a `one-key' menu alist of keys, or a symbol whose value is such a list, or a list of menus and/or symbols."))
(function :tag "Title string function"
:help-echo "A function which returns a title string for `one-key' menus of this type.")
(choice (symbol :tag "Special keybindings symbol"
:help-echo "A symbol whose value is a list of special keybindings for menus of this type")
(repeat :tag "Special keybindings"
(list (string :tag "Keybinding"
:help-echo "String representation of the keybinding for this action")
(string :tag "Description"
:help-echo "Description to display in help buffer")
(function :tag "Function"
:help-echo "Function for performing action. See description below for further details."))))
(alist :tag "Sort methods"
:key-type (string :tag "Name" :help-echo "Name for sort method")
:value-type (function :tag "Function" :help-echo "Predicate that returns non-nil if 1st item comes before 2nd"))))
:group 'one-key)
(defcustom one-key-persistent-menu-number t
"If non-nil then when the default menu set is opened it will start with the same menu as when previously opened."
:group 'one-key
:type 'boolean)
(defface one-key-name
'((t (:foreground "Gold")))
"Face for highlighting name."
:group 'one-key)
(defface one-key-keystroke
'((t (:foreground "DarkRed")))
"Face for highlighting keystroke."
:group 'one-key)
(defface one-key-prompt
'((t (:foreground "khaki3")))
"Face for highlighting prompt."
:group 'one-key)
(defstruct one-key-menu-struct
"Information for constructing a one-key menu."
name items specialkeys filter filtereditems title sortmethods)
(defstruct one-key-menus
"Set of one-key-menu objects, and name of menu set, along with other relevant information."
(name :read-only t) menus)
(defun one-key-get-slots (struct)
"Return list of symbols for the slots in the cl-structure STRUCT."
(mapcar 'car (cdr (get (intern-soft (substring (symbol-name (elt struct 0)) 10))
'cl-struct-slots))))
(defvar one-key-current-menus nil
"The list of one-key menus used in the current one-key buffer.")
(defvar one-key-displayed-sort-method nil
"The sort method displayed in the mode line.")
(defvar one-key-mode-line-message '(format "Press %s for help, %s to quit. Sorted by %s (%s first)."
(cadr (assoc 'toggle-help one-key-special-keybindings))
(cadr (assoc 'quit-close one-key-special-keybindings))
one-key-displayed-sort-method (if one-key-column-major-order "columns" "rows"))
"Form that when evaluated should produce a string for the mode-line in the *One-Key* buffer.
This should probably be left alone unless you remove `toggle-help' or `quit-close' from `one-key-special-keybindings'")
(defvar one-key-copied-items nil
"List of menu items that have been killed using the `one-key-copy/kill-items' function.")
(defvar one-key-null-keys (regexp-opt '("<remap>" "mouse" "<follow-link>"))
"Regular expression matching key descriptions of keymap items that should be excluded from `one-key' menus.")
(defvar one-key-menu-show-key-help nil
"If true show help for function associated with next keystroke, when it is pressed in the one-key-menu.")
(defvar one-key-current-item-being-moved nil
"The key corresponding to the item currently being moved in the `one-key' menu, or nil if none is being moved.")
(defvar one-key-altered-menus nil
"List of menu alist variables that should be saved on exit if `one-key-autosave-menus' is true.")
(defvar one-key-default-menu-number nil
"The default menu number to use when opening the default menu set if `one-key-persistent-menu-number' is non-nil.")
(defvar one-key-mode-line-format
'("%e" "%e"
#("-" 0 1
(help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))
mode-line-mule-info mode-line-client mode-line-modified mode-line-remote mode-line-frame-identification mode-line-buffer-identification
#(" " 0 1
(help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))
mode-line-position
#(" " 0 1
(help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))
(:eval (eval one-key-mode-line-message))
(global-mode-string
("" global-mode-string
#(" " 0 1
(help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))))
(:eval
(unless
(display-graphic-p)
#("-%-" 0 3
(help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display")))))
"The `mode-line-format' for the *One-Key* buffer.")
(defvar one-key-default-title-func (lambda nil
(let* ((keystr (one-key-get-special-key-descriptions 'donate))
(msg (concat "To support the author press "
keystr " or donate bitcoins to 1HnSqGHrVenb1t2V2aijyocWyZcd7qt1k\n"))
(len (length msg))
(dif (- (window-width) len)))
(if (<= dif 0)
msg
(concat (make-string (/ dif 2) ? ) msg))))
"Function to return default message for one-key menus, prompting for donations.")
(defvar one-key-maintainer-email "vapniks@yahoo.com"
"Email address of current maintainer.")
(defvar one-key-version "1.0"
"Version number of this version of one-key")
(defvar one-key-key-description-remap
'(("<return>" . "RET")
("<tab>" . "TAB")
("<space>" . "SPC")
("<begin>" . "<home>")
("<escape>" . "ESC")
("<C-escape>" . "C-ESC")
("<delete>" . "DEL"))
"Alist of key descriptions and their preferred versions.
This is required in order that keys such as RET (which can also be described as <return> are always described and
recognized the same way.")
(defvar one-key-menu-sorting-commands-alist
'((("l" . "Sort lines alphabetically (M-x sort-lines)") . sort-lines)
(("p" . "Sort paragraphs alphabetically (M-x sort-paragraphs)") . sort-paragraphs)
(("P" . "Sort pages alphabetically (M-x sort-pages)") . sort-pages)
(("f" . "Sort lines alphabetically by whitespace seperated fields (M-x sort-fields)") . sort-fields)
(("n" . "Sort lines numerically by whitespace seperated fields (M-x sort-numeric-fields)") . sort-numeric-fields)
(("c" . "Sort lines alphabetically by columns defined by point and mark (M-x sort-columns)") . sort-columns)
(("r" . "Sort lines matching 1st regexp by field matching 2nd regexp, alphabetically (M-x sort-regexp-fields)") . sort-regexp-fields)
(("R" . "Reverse order of lines in region (M-x reverse-region)") . reverse-region))
"The `one-key' menu alist for sorting commands.")
(defvar one-key-menu-searching-commands-alist
`((("C-s" . "Search forward (C-s)") . (lambda nil (interactive) (isearch-mode t nil nil t)))
(("C-r" . "Search backward (C-r)") . (lambda nil (interactive) (isearch-mode nil nil nil t)))
(("M-%" . "Search-replace string (M-%)") . query-replace)
(("C-M-s" . "Search forward for regexp (C-M-s)") . isearch-forward-regexp)
(("C-M-r" . "Search backward for regexp (C-M-r)") . isearch-backward-regexp)
(("C-M-%" . "Search-replace regexp (C-M-%)") . query-replace-regexp)
(("b" . "Regular expression builder (M-x re-builder)") . re-builder)
(("l" . "Grep files in dir (M-x lgrep)") . lgrep)
(("r" . "Grep files in dir and subdirs (M-x rgrep)") . rgrep)
(("g" . "Run grep via find (M-x grep-find)") . grep-find)
,(if (featurep 'mgrep) '(("m" . "mgrep - grep dirs stored in `mgrep-list' (M-x mgrep)") . mgrep))
,(if (featurep 'ack-and-a-half) '(("a" . "ack - grep source code files (M-x ack-and-a-half)") . ack-and-a-half))
,(if (featurep 'ack-and-a-half) '(("o" . "open source code file (M-x ack-and-a-half-find-file)") . ack-and-a-half-find-file))
(("f" . "Find files and put them in dired buffer (M-x find-dired)") . find-dired)
(("n" . "Find files matching by name (M-x find-name-dired)") . find-name-dired)
(("c" . "Find files matching by contents (M-x find-grep-dired)") . find-grep-dired)
)
"The `one-key' menu alist for search/replace commands.")
(defvar one-key-menu-editing-commands-alist
'((("C-SPC" . "Set mark (C-SPC)") . set-mark-command)
(("h" . "Mark entire buffer (C-x h)") . mark-whole-buffer)
(("C-p" . "Mark page (C-x C-p)") . mark-page)
(("h" . "Mark paragraph (M-h)") . mark-paragraph)
(("C-x" . "Exchange point and mark (C-x C-x)") . exchange-point-and-mark)
(("M-w" . "Copy selected region (M-w OR C-Insert)") . kill-ring-save)
(("C-w" . "Cut selected region (C-w OR S-DEL)") . kill-region)
(("C-y" . "Paste/yank last copied/cut text (C-y)") . yank)
(("M-y" . "Paste/yank ealier copied/cut text (M-y)") . yank-pop)
(("C-d" . "Delete character forward (C-d)") . delete-char)
(("M-DEL" . "Delete word backward (M-DEL)") . backward-kill-word)
(("M-D" . "Delete word forward (M-D OR C-S-DEL)") . kill-word)
(("C-k" . "Delete to end of line (C-k)") . kill-line)
(("M-k" . "Delete to end of sentence (M-k)") . kill-sentence)
(("M-u" . "Make word uppercase (M-u)") . upcase-word)
(("M-l" . "Make word lowercase (M-l)") . downcase-word)
(("M-c" . "Capitalize word (M-c)") . capitalize-word)
(("C-t" . "Transpose/swap adjacent characters (C-t)") . transpose-chars)
(("M-t" . "Transpose/swap adjacent words (M-t)") . transpose-words)
(("t" . "Transpose/swap lines (C-x C-t)") . transpose-lines)
(("M-^" . "Join previous line (M-^)") . delete-indentation)
(("TAB" . "Indent all lines in region (C-x TAB)") . indent-rigidly)
(("M-q" . "Fill or justify paragraph (M-q)") . fill-paragraph)
(("C-o" . "Open a new line before this one (C-o)") . open-line)
(("1" . "Remove all but 1 empty line (C-x C-o)") . delete-blank-lines))
"The `one-key' menu alist for editing commands.")
(defvar one-key-menu-cursor-motion-commands-alist
'((("C-f" . "Forward a character (C-f)") . forward-char)
(("C-b" . "Backward a charcter (C-b)") . backward-char)
(("C-n" . "Forward a line (C-n)") . next-line)
(("C-p" . "Backward a line (C-p)") . previous-line)
(("C-a" . "Goto the beginning of line (C-a)") . move-beginning-of-line)
(("C-e" . "Goto the end of line (C-e)") . move-end-of-line)
(("M-f" . "Forward a word (M-f)") . forward-word)
(("M-b" . "Backward a word (M-b)") . backward-word)
(("M-e" . "Forward a sentence (M-e)") . forward-sentence)
(("M-a" . "Backward a sentence (M-a)") . backward-sentence)
(("M-<" . "Goto the beginning of buffer (M-<)") . beginning-of-buffer)
(("M->" . "Goto the end of buffer (M->)") . end-of-buffer)
(("{" . "Move backwards paragraph (M-{") . backward-paragraph)
(("}" . "Move forwards paragraph (M-})") . forward-paragraph)
(("[" . "Move backwards page (C-x [)") . backward-page)
(("]" . "Move forwards page (C-x ])") . forward-page))
"The `one-key' menu alist for cursor motion commands.")
(defvar one-key-menu-buffer-and-file-commands-alist
'((("C-f" . "Open file (C-x C-f)") . find-file)
(("d" . "Open directory (C-x d)") . (lambda nil (interactive)
(if (featurep 'ido) (call-interactively 'ido-dired)
(call-interactively 'dired))))
(("C-s" . "Save current file (C-x C-s)") . save-buffer)
(("C-w" . "Save file as (C-x C-w)") . write-file)
(("s" . "Prompt user for files to save (C-x s)") . save-some-buffers)
(("i" . "Insert file contents into buffer (C-x i)") . insert-file)
(("b" . "Switch to another buffer (C-x b)") . switch-to-buffer)
(("4" . "Switch to another buffer in another window (C-x 4 b)") . switch-to-buffer-other-window)
(("5" . "Switch to another buffer in another frame (C-x 5 b)") . switch-to-buffer-other-frame)
(("<C-left>" . "Select previous buffer (C-x <left>)") . previous-buffer)
(("<C-right>" . "Select next buffer (C-x <right>)") . next-buffer)
(("k" . "Kill buffer (C-x k)") . kill-buffer)
(("K" . "Prompt to kill buffers (M-x kill-some-buffers)") . kill-some-buffers)
(("C-v" . "Kill current buffer then open another file (C-x C-v)") . find-alternate-file)
(("m" . "Menu for switching/killing buffers (M-x bs-show)") . bs-show)
(("l" . "List existing buffers (C-x C-b)") . list-buffers)
(("C-q" . "Toggle read-only status of buffer (C-x C-q)") . toggle-read-only)
(("R" . "Rename buffer (M-x rename-buffer)") . rename-buffer)
)
"The `one-key' menu alist for buffer and file commands.")
(defvar one-key-menu-window-commands-alist
'((("1" . "Make this window fill it's frame (C-x 1)") . delete-other-windows)
(("2" . "Split this window vertically (C-x 2)") . split-window-vertically)
(("3" . "Split this window horizontally (C-x 3)") . split-window-horizontally)
(("o" . "Select next window (C-x o)") . other-window)
(("0" . "Kill this buffer and window (C-x 4 0)") . kill-buffer-and-window)
(("^" . "Make this window taller (C-x ^)") . enlarge-window)
(("-" . "Make this window shorter (C-x -)") . shrink-window-if-larger-than-buffer)
(("}" . "Make this window wider (C-x })") . enlarge-window-horizontally)
(("{" . "Make this window narrower (C-x {)") . shrink-window-horizontally)
(("+" . "Make all windows the same height (C-x +)") . balance-windows)
(("C-M-v" . "Scroll the next window (C-M-v)") . scroll-other-window)
(("b" . "Select buffer in another window (C-x 4 b)") . switch-to-buffer-other-window)
(("C-o". "Display buffer in another window (C-x 4 C-o)") . display-buffer)
(("f" . "Open a file in another window (C-x 4 f)") . find-file-other-window)
(("d" . "Open a directory in another window (C-x 4 d)") . dired-other-window)
(("m" . "Compose email in another window (C-x 4 m)") . mail-other-window)
(("." . "Find tag of current tags table in another window (C-x 4 .)") . find-tag-other-window)
(("r" . "Open a file as read-only in another window (C-x 4 r)") . find-file-read-only-other-window))
"The `one-key' menu alist for window commands.")
(defvar one-key-buffer-menu-number nil
"The index of the current menu in `one-key-buffer-menu-alists'.
This variable is local to the one-key buffer.")
(defvar one-key-buffer-menu-names nil
"The current list of menu names.
This variable is local to the one-key buffer.")
(defvar one-key-buffer-menu-alists nil
"The current list of menu lists.
This variable is local to the one-key buffer.")
(defvar one-key-buffer-special-keybindings nil
"The special keybindings for the current menu.
This variable is local to the one-key buffer.")
(defvar one-key-buffer-associated-window nil
"The window associated with the one-key buffer.
This is set to the window that was selected when the one-key menu was opened.
This variable is local to the one-key buffer.")
(defvar one-key-buffer-temp-action nil
"Indicates what to do after the last key was pressed in the one-key buffer.
This variable may be set by special key or menu commands in the context of the one-key buffer.
It's value is treated in the same way as `one-key-buffer-match-action' except that it is overridden by
`one-key-buffer-match-action' after a menu command if `one-key-buffer-temp-action' is nil.
The default value is nil and it is reset to nil after performing the associated action.
This variable is local to the one-key buffer.")
(defvar one-key-buffer-match-action 'close
"Indicates what to do after a matching (menu item) key is pressed, and the associated command is executed.
The value should be either nil which means do nothing and leave the window open, a function to be called with
no arguments, or a symbol which is interpreted in the same way as the possible values for `one-key-window-toggle-sequence'.
The default value is 'close (i.e. close the one-key window).
This variable may be temporarily overridden by the value of `one-key-buffer-temp-action' by individual commands.
This variable is local to the one-key buffer.")
(defvar one-key-buffer-miss-match-action 'close
"Indicates what to do after a miss-match (non menu item) key is pressed.
The possible values are the same as for `one-key-buffer-match-action' or the symbols 'execute 'executeclose
which will execute the key (in the associated window) and leave the one-key window open/closed respectively.
The default value is 'close (i.e. close the one-key window).
This variable is local to the one-key buffer.")
(defvar one-key-buffer-dedicated-frame nil
"If non-nil then this var holds the frame dedicated to the one-key menu.
This variable is local to the one-key buffer.")
(defvar one-key-buffer-filter-regex nil
"A regular expression matching menu items to be diplayed in one-key menu.
Any menu items in the current menu alist that don't match this regexp won't be displayed
when `one-key-update-buffer-contents' is executed.
If nil then all items are displayed.
This variable is local to the one-key buffer.")
(defvar one-key-buffer-filtered-list nil
"The list of menu items that match `one-key-buffer-filter-regex'.
These are the items that are displayed in the one-key buffer.
This variable is local to the one-key buffer.")
(defun one-key-header-line-format (names menu-number)
"Return the preferred value of `header-line-format' for the *One-Key* buffer.
NAMES should be the current list of menu names displayed, or just a single name if there is only one menu.
MENU-NUMBER should be nil if NAMES is a single name, otherwise it should index the current menu in NAMES."
(let* ((prenames (if (and menu-number (> menu-number 0))
(concat (mapconcat 'identity (subseq names 0 menu-number) " ") " ")))
(nameslen (length names))
(postnames (if (and menu-number (< menu-number (1- nameslen)))
(concat " " (mapconcat 'identity (subseq names (1+ menu-number) nameslen) " "))))
(name (if menu-number (nth menu-number names) names))
(name1 (propertize name 'face 'one-key-name))
(namelen (length name))
(prelen (length prenames))
(postlen (length postnames))
(winwidth (window-width))
(namepos (/ (- winwidth namelen) 2))
(startpos (- namepos prelen))
(postnames2 (if postnames (substring postnames 0 (min namepos postlen)))))
(if (>= startpos 0)
(concat (make-string startpos ? ) prenames name1 postnames2)
(concat (substring prenames (- startpos) prelen) name1 postnames2))))
(define-derived-mode one-key-mode fundamental-mode "One-Key"
"The major-mode for the one-key menu buffer."
:group 'one-key
:syntax-table (let ((table (make-syntax-table)))
(dolist (char '(40 41 60 62 91 93 123 125))
(modify-syntax-entry char "w" table))
table)
(dolist (var '(one-key-buffer-menu-number
one-key-buffer-menu-names
one-key-buffer-menu-alists
one-key-buffer-special-keybindings
one-key-buffer-filter-regex
one-key-buffer-filtered-list
one-key-buffer-temp-action
one-key-buffer-miss-match-action
one-key-buffer-match-action
one-key-buffer-associated-window
one-key-buffer-dedicated-frame
one-key-buffer-this-name
one-key-buffer-full-list
one-key-buffer-this-list))
(set (make-local-variable var) nil))
(setq mode-line-format one-key-mode-line-format
header-line-format (one-key-header-line-format
(or one-key-buffer-menu-names "one-key")
one-key-buffer-menu-number)
cursor-type nil
one-key-mode-map (make-keymap)
buffer-read-only nil)
(set-char-table-range (second one-key-mode-map) t 'one-key-command)
(define-key one-key-mode-map [t] 'one-key-command)
(use-local-map one-key-mode-map)
(local-unset-key (kbd "ESC")))
(define-derived-mode one-key-help-mode fundamental-mode "One-Key Help"
"The major-mode for the one-key help buffer."
:group 'one-key
:syntax-table (let ((table (make-syntax-table)))
(dolist (char '(40 41 60 62 91 93 123 125))
(modify-syntax-entry char "w" table))
table)
(dolist (var '(one-key-buffer-special-keybindings
one-key-buffer-associated-window
one-key-buffer-dedicated-frame))
(set (make-local-variable var) nil))
(setq
cursor-type nil
one-key-help-mode-map (make-keymap)
buffer-read-only nil)
(set-char-table-range (second one-key-help-mode-map) t 'one-key-command)
(define-key one-key-help-mode-map [t] 'one-key-command)
(use-local-map one-key-help-mode-map))
(defun one-key-show-help (special-keybindings)
"Show information about `one-key-menu' special keybindings in the alist SPECIAL-KEYBINDINGS."
(interactive)
(let* ((maxkey (loop for elt in special-keybindings
maximize (1+ (length (car elt)))))
(maxstr (loop for elt in special-keybindings
maximize (+ 3 maxkey (length (cadr elt)))))
(width (/ (window-width) 2))
(keystr (if (> maxstr width)
(mapconcat (lambda (elt) (format "%s\t: %s"
(one-key-remap-key-description (car elt))
(cadr elt)))
special-keybindings "\n")
(loop with colsize = (+ (/ (length special-keybindings) 2)
(% (length special-keybindings) 2))
with finalstr
for n from 0 to (1- colsize)
for (key1 desc1) = (nth n special-keybindings)
for (key2 desc2) = (nth (+ n colsize) special-keybindings)
for key1a = (one-key-remap-key-description key1)
for key2a = (one-key-remap-key-description key2)
for keyspc1 = (make-string (- maxkey (length key1a)) ? )
for keyspc2 = (make-string (- maxkey (length key2a)) ? )
for str1 = (format "%s%s: %s" key1a keyspc1 desc1)
for str2 = (format "%s%s: %s" key2a keyspc2 desc2)
for spc = (make-string (- width (length str1)) ? ) do
(push (concat str1 spc (if key2a str2) "\n") finalstr)
finally return (mapconcat 'identity (nreverse finalstr) ""))))
(onekeybuf (get-buffer one-key-buffer-name)))
(with-help-window one-key-help-buffer-name
(princ (concat "Press the highlighted key in the menu to perform the corresponding action written next to it.
The following special keys may also be used:\n"
keystr)))
(with-current-buffer one-key-help-buffer-name (one-key-help-mode)
(setq one-key-buffer-special-keybindings special-keybindings
one-key-buffer-dedicated-frame
(if onekeybuf (with-current-buffer onekeybuf
one-key-buffer-dedicated-frame))
one-key-buffer-associated-window
(if onekeybuf (with-current-buffer onekeybuf
one-key-buffer-associated-window))))))
(defun one-key-show-item-help (key)
"Show help for the item in the current menu that is associated with the key KEY."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list))
(item (one-key-get-menu-item key full-list))
(tail (cdr item)))
(if (listp tail)
(if (commandp tail)
(with-help-window one-key-help-buffer-name (princ tail))
(let ((cmd (car tail)))
(if (symbolp cmd)
(if (commandp cmd)
(describe-function cmd)
(message "Unknown item!"))
(with-help-window one-key-help-buffer-name (princ cmd)))))
(if (commandp tail)
(describe-function tail)
(message "Unknown item!")))))
(defun one-key-prompt-to-add-menu-item nil
"Prompt the user for item details and add it to the current one-key menu."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list))
(newkey (let ((key (read-event "Enter the key for the new item")))
(while (and (one-key-get-menu-item key full-list)
(not (y-or-n-p "That key is already used! Overwrite old item?")))
(setq key (read-event "Enter new key for the item")))
key))
(desc (read-string "Item description: "))
(contents (read-from-minibuffer "Command: " nil nil t)))
(if isref
(progn (add-to-list 'one-key-altered-menus (symbol-name this-list))
(set this-list (one-key-add-menu-item newkey desc contents full-list)))
(setq this-list (one-key-add-menu-item newkey desc contents full-list))))
(one-key-update-buffer-contents))
(defun one-key-swap-menu-items nil
"Prompt user for a pair of items in the current one-key menu and swap the corresponding keys."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list))
(keya (read-event "Press key for first item"))
(keyastr (one-key-key-description keya))
(itema (one-key-get-menu-item keyastr full-list))
(keyb (read-event "Press key for second item"))
(keybstr (one-key-key-description keyb))
(itemb (one-key-get-menu-item keybstr full-list)))
(if (not (and itema itemb)) (message "Invalid key!")
(setf (caar itema) keybstr (caar itemb) keyastr))
(if isref (add-to-list 'one-key-altered-menus (symbol-name this-list))))
(one-key-update-buffer-contents))
(defun one-key-delete-menu-item nil
"Prompt the user for an item in the current menu to delete from the `one-key' menu."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list))
(key (read-event "Press the key of the item you want to delete"))
(item (one-key-get-menu-item key full-list)))
(if (and item (y-or-n-p (format "Delete item \"%s\"?" (cdar item))))
(if isref (set this-list (delete item full-list))
(setq this-list (delete item full-list))))
(if isref (add-to-list 'one-key-altered-menus (symbol-name this-list))))
(one-key-update-buffer-contents))
(defun one-key-get-item-colour (item &optional fg rettype)
"Return the background colour of menu item ITEM. If FG is non-nil return the foreground colour instead.
If RETTYPE is one of the following symbols: 'hex, 'hsv or 'rgb, then the colour will be returned in the associated format
(a hex string, list of hsv values or list of rgb values).
By default the colour will be returned in hex string format."
(let* ((descface (get-text-property 0 'face (cdar item)))
(type (if fg :foreground :background))
(colour (or (and (facep descface)
(not (equal (face-attribute descface type) 'unspecified))
(face-attribute descface type))
(plist-get descface type)))
(colour2 (or colour (if fg one-key-item-foreground-colour
(cdr (assq 'background-color (frame-parameters)))))))
(case rettype
(hex (hexrgb-color-name-to-hex colour2))
(hsv (hexrgb-hex-to-hsv colour2))
(rgb (hexrgb-hex-to-rgb colour2))
(t (hexrgb-color-name-to-hex colour2)))))
(defun one-key-copy/kill-items nil
"Prompt for a colour, copy all items with that colour from the current menu, and put them in `one-key-copied-items'."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list))
(filtered-list one-key-buffer-filtered-list)
(key (read-event "Press the key of an item in the colour group to copy: "))
(item (one-key-get-menu-item key filtered-list))
(kill (y-or-n-p "Delete items from current menu?")))
(if item
(destructuring-bind (h1 s1 v1) (one-key-get-item-colour item nil 'hsv)
(setq one-key-copied-items
(loop for item2 in filtered-list
for (h2 s2 v2) = (one-key-get-item-colour item2 nil 'hsv)
for huediff = (abs (- h1 h2))
for satdiff = (abs (- s1 s2))
if (and (< huediff 0.001) (< satdiff 0.001)) do
(if kill
(if isref (set this-list (delete item2 full-list))
(setq this-list (delete item2 full-list))))
and collect item2))
(if isref (add-to-list 'one-key-altered-menus (symbol-name this-list))))))
(one-key-update-buffer-contents))
(defun one-key-yank-items nil
"Yank menu items in `one-key-copied-items' into current menu."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list))
(usedkeys (mapcar 'caar full-list))
(pair (loop for ((key . desc) . rest) in one-key-copied-items
for newkey = (one-key-generate-key desc usedkeys nil key)
for newitem = (cons (cons newkey desc) rest)
do (add-to-list 'usedkeys newkey)
collect newitem into newitems
collect desc into descs
finally return (cons newitems descs)))
(newitems (car pair))
(descs (cdr pair)))
(if (not isref) (setq this-list (append full-list newitems))
(set this-list (append full-list newitems))
(add-to-list 'one-key-altered-menus (symbol-name this-list)))
(if one-key-buffer-filter-regex
(setq one-key-buffer-filter-regex (concat (regexp-opt descs) "\\|" one-key-buffer-filter-regex))))
(one-key-update-buffer-contents))
(defun one-key-edit-menu-item nil
"Prompt user for the key of an item in the current menu to edit."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list))
(oldkey (read-event "Press the key of the item you want to edit"))
(item (one-key-get-menu-item oldkey full-list))
(newkey (let ((key (read-event "Enter new key for the item")))
(while (and (one-key-get-menu-item key full-list)
(not (eq key oldkey))
(not (y-or-n-p "That key is already used! Use it anyway?")))
(setq key (read-event "Enter new key for the item")))
key))
(desc (read-string "Item description: " (cdar item) nil nil))
(oldcontents (cdr item))
(contents (read-from-minibuffer "Item contents: " (format "%S" oldcontents) nil t)))
(setf (caar item) (one-key-key-description newkey))
(setf (cdar item) desc)
(setf (cdr item) contents)
(if isref (add-to-list 'one-key-altered-menus (symbol-name this-list))))
(one-key-update-buffer-contents))
(defun one-key-colourize-string (colour string)
"Change background colour of STRING to COLOUR, and foreground colour to `one-key-item-foreground-colour'."
(propertize string 'face (list :background colour :foreground one-key-item-foreground-colour)))
(defun one-key-highlight-matching-items (colour pred)
"Highlight the items in the current menu that satisfy the predicate function PRED with colour COLOUR.
The predicate function should take a single item from the menu list as it's only argument.
If COLOUR is \"\" then all highlighting (and more generally any text properties) are removed from the item."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list)))
(loop for item in-ref full-list
for str = (cdar item)
if (funcall pred item) do
(if (equal colour "")
(setf (cdar item) (substring-no-properties str))
(setf (cdar item) (one-key-colourize-string colour str))))
(if isref (add-to-list 'one-key-altered-menus (symbol-name this-list))))
(one-key-update-buffer-contents))
(defun one-key-save-menu (name menu-list)
"Save a one-key menu to the file `one-key-menus-save-file'.
NAME is the name of the menu, and MENU-LIST is either a one-key menu list, or a symbol whose value is such a menu."
(let* ((isref (symbolp menu-list))
(varname (if isref (symbol-name menu-list)
(concat "one-key-menu-" name "-alist")))
(full-list (if isref (eval menu-list) menu-list))
(file one-key-menus-save-file)
(buf (get-file-buffer file)))
(if file
(if (file-writable-p file)
(with-current-buffer (find-file-noselect file)
(goto-char (point-min))
(if (not (search-forward (concat "(setq " varname) nil t))
(goto-char (point-max))
(beginning-of-line)
(mark-sexp)
(kill-region (point) (marker-position (mark-marker)))
(deactivate-mark))
(insert (concat "(setq " varname "\n '"
(replace-regexp-in-string
") ((" ")\n ((" (eval `(prin1-to-string full-list))) ")"))
(save-buffer)
(if (not buf) (kill-buffer (get-file-buffer file))))
(message "Can't write to file %s" file))
(message "`one-key-menus-save-file' not set" file))))
(defun* one-key-sort-items-by-next-method (&optional prev (multisort t))
"Sort the items in the current one-key menu, and it's associated menus by the next sort method associated with that menu.
If PREV is non-nil then the previous method in SORT-METHODS will be used instead.
If MULTISORT is nil (default is t) then the associated menus will not be sorted, only the current menu.
The list of sort methods for the current menu are stored in the 5th element of the element of `one-key-types-of-menu' associated
with this menu. The current sort index is stored for this menu is stored in `one-key-sort-method-indices-alist', or 0 otherwise."
(let* ((name (nth one-key-buffer-menu-number one-key-buffer-menu-names))
(indices (if multisort (one-key-get-associated-menu-indices
one-key-buffer-menu-number one-key-buffer-menu-names)
(list one-key-buffer-menu-number)))
(onemenu (= (length indices) 1))
(items (mapcan 'one-key-eval-if-symbol
(one-key-list-subset indices one-key-buffer-menu-alists)))
(sortmethods (or (one-key-eval-if-symbol
(nth 5 (one-key-get-menu-type name)))
one-key-default-sort-method-alist))
(numsortmethods (length sortmethods))
(sortindex (let* ((pair (assoc name one-key-sort-method-indices-alist))
(oldindex (or (cdr pair) 0))
(newindex (mod (if prev (1- oldindex) (1+ oldindex)) numsortmethods)))
(if pair (setf (cdr pair) newindex)
(one-key-add-to-alist 'one-key-sort-method-indices-alist (cons name newindex)))
newindex))
(sortmethod (nth sortindex sortmethods))
(sorteditems (sort items (cdr sortmethod)))
(keys (if (not onemenu) (mapcar (lambda (x) (caar x)) sorteditems)))
(descs (if (not onemenu) (mapcar (lambda (x) (cdar x)) sorteditems)))
(commands (if (not onemenu) (mapcar 'cdr sorteditems)))
(sortedlists (if onemenu sorteditems (one-key-create-menu-lists commands descs keys nil :invalidkeys nil)))
(basename (replace-regexp-in-string " ([0-9]+)$" "" name))
(newnames (if onemenu name (one-key-append-numbers-to-menu-name basename (length sortedlists)))))
(if onemenu (setf (nth one-key-buffer-menu-number one-key-buffer-menu-alists) sortedlists)
(one-key-delete-menus indices)
(one-key-add-menus newnames sortedlists))
(setq one-key-displayed-sort-method (car sortmethod)))
(one-key-update-buffer-contents))
(defun one-key-reverse-item-order nil
"Reverse the order of items in the current one-key menu.
This function must be called within the context of the one-key buffer to work."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list))
(reversed-list (reverse full-list)))
(if (not isref)
(setf (nth one-key-buffer-menu-number one-key-buffer-menu-alists) reversed-list)
(set this-list reversed-list)
(add-to-list 'one-key-altered-menus (symbol-name this-list))))
(one-key-update-buffer-contents))
(defun one-key-get-menu-type (name)
"Return the element of `one-key-types-of-menu' corresponding to menu with name NAME, or nil if none exists."
(if name (find-if (lambda (x)
(let ((one (first x))
(two (second x)))
(or (equal one name)
(and (functionp two)
(funcall two name)))))
one-key-types-of-menu)))
(defun* one-key-get-menus-for-type (name &optional (remapkeys t))
"Given the name NAME of an existing menu or menu type in `one-key-types-of-menu', return associated names and menu alists.
If no such menu or menu type exists, return nil.
The optional argument REMAPKEYS is t by default and indicates whether or not to remap the keys in the menu using
the `one-key-remap-invalid-keys' function."
(let* ((pair (if name (let* ((listname (concat "one-key-menu-" name "-alist"))
(type (one-key-get-menu-type name))
(func (or (third type)
(and (not type)
(loop for sym being the symbols
for symname = (symbol-name sym)
when (equal listname symname)
return (cons name sym))))))
(if (functionp func) (funcall func name) func))))
(onep (stringp (car pair)))
(names (car pair))
(menus (if remapkeys
(if onep (one-key-remap-invalid-keys (cdr pair))
(mapcar 'one-key-remap-invalid-keys (cdr pair)))
(cdr pair))))
(cons names menus)))
(defun one-key-prompt-for-menu nil
"Prompt the user for a `one-key' menu type, and return menu name(s) and menu alist(s)."
(let* ((alltypes (remq nil (mapcar 'car one-key-types-of-menu)))
(type (if (featurep 'ido)
(ido-completing-read "Menu type: " alltypes)
(completing-read "Menu type: " alltypes))))
(one-key-get-menus-for-type type)))
(defun one-key-add-menus (&optional newnames newlists)
"Add a menu/menus to the current list of menus in the `one-key' menu function call.
If optional args NEWNAMES and NEWLISTS are supplied they should be a list of menu names and corresponding menu alists
to add. Otherwise the user will be prompted for a menu type, and the menus will be created using the functions associated
with that type.
This function only works when called within the context of the one-key buffer since it depends on buffer local variables."
(let* ((both (if (and newnames newlists)
(cons newnames newlists)
(one-key-prompt-for-menu)))
(newnames (car both))
(newlists (cdr both))
(multi (listp newnames)))
(with-current-buffer one-key-buffer-name
(let* ((listlen (length one-key-buffer-menu-alists)))
(unless (= listlen (length one-key-buffer-menu-names))
(error "Number of menu names doesn't match number of menus"))
(setq one-key-buffer-menu-names
(concatenate 'list
(subseq one-key-buffer-menu-names 0 (1+ one-key-buffer-menu-number))
(if (and multi newnames) newnames (list newnames))
(subseq one-key-buffer-menu-names (1+ one-key-buffer-menu-number) listlen))
one-key-buffer-menu-alists
(concatenate 'list
(subseq one-key-buffer-menu-alists 0 (1+ one-key-buffer-menu-number))
(if (and multi newlists) newlists (list newlists))
(subseq one-key-buffer-menu-alists (1+ one-key-buffer-menu-number) listlen))
one-key-buffer-menu-number (1+ one-key-buffer-menu-number)))))
(one-key-update-buffer-contents))
(defun one-key-get-indices-of-matches (regexp names)
"Return list of indices of elements of NAMES (a list of strings) that match REGEXP (a regular expression)."
(loop for i from 0 to (1- (length names))
for name = (nth i names)
if (string-match regexp name)
collect i))
(defun one-key-get-associated-menu-indices (menunumber menunames)
"Return indices of the names in MENUNAMES that are associated with the menu with index MENUNUMBER.
Associated menus are adjacent menus with the same base-name but different numbers appended to the end of the name (in brackets)."
(let* ((name (nth menunumber menunames))
(nummenus (length menunames))
(basename (replace-regexp-in-string " ([0-9]+)$" "" name))
(num (if (string-match " (\\([0-9]+\\))$" name)
(string-to-number (match-string 1 name)))))
(if (not num) (list menunumber)
(loop for i from 1 to nummenus
for index = (mod (+ i (- menunumber num)) nummenus)
for nextname = (nth index menunames)
if (string= (concat basename " (" (number-to-string i) ")") nextname)
collect index))))
(defmacro one-key-list-subset (indices list)
"Return elements of LIST corresponding to INDICES."
`(mapcar (lambda (i) (nth i ,list)) ,indices))
(defun one-key-get-menus (&optional menus)
"Return menu names and menu alists from the currently loaded one-key menus.
A cons cell whose car is a list of menu names, and whose cdr is a list of corresponding menu alists is returned.
By default menus associated with the current menu are returned.
Associated menus are adjacent menus with the same base-name but different numbers appended to the end of the name (in brackets).
If the optional argument MENUS is supplied it should either be a number (the index of the menu to be returned),
a list of numbers (indices of menus), or a string (regular expression matching menu names).
This function only works when called within the context of the one-key buffer since it depends on buffer local variables."
(let* ((indices (cond ((not menus) (one-key-get-associated-menu-indices
one-key-buffer-menu-number one-key-buffer-menu-names))
((stringp menus) (one-key-get-indices-of-matches
menus one-key-buffer-menu-names))
((listp menus) menus)
((numberp menus) (list menus)))))
(cons (one-key-list-subset indices one-key-buffer-menu-names)
(one-key-list-subset indices one-key-buffer-menu-alists))))
(defun* one-key-delete-menus (&optional (menus one-key-buffer-menu-number))
"Remove a menu(s) from the currently loaded one-key menus. By default the current menu is deleted.
If the optional argument MENUS is supplied it should either be a number (the index of the menu to be deleted),
a list of numbers (the indices of the menus to be deleted), or a string (a regular expression matching the names
of the menus to be deleted).
If there is currently only one loaded menu, the one-key window will be closed.
The function returns the number of menus deleted.
This function only works when called within the context of the one-key buffer since it depends on buffer local variables."
(with-current-buffer one-key-buffer-name
(let* ((listlen (length one-key-buffer-menu-alists))
(indices (if (stringp menus)
(one-key-get-indices-of-matches menus one-key-buffer-menu-names)
(if (listp menus) menus (list menus)))))
(unless (= listlen (length one-key-buffer-menu-names))
(error "Number of menu names doesn't match number of menus"))
(if (= listlen 1)
(progn (one-key-set-window-state 'close) 1)
(dolist (index indices)
(setq one-key-buffer-menu-names
(concatenate 'list
(subseq one-key-buffer-menu-names 0 index)
(subseq one-key-buffer-menu-names (1+ index) listlen))
one-key-buffer-menu-alists
(concatenate 'list
(subseq one-key-buffer-menu-alists 0 index)
(subseq one-key-buffer-menu-alists (1+ index) listlen))
one-key-buffer-menu-number (min index (- listlen 2)))))
(one-key-update-buffer-contents)
(length indices))))
(defun one-key-delete-associated-menus (&optional (menunum one-key-buffer-menu-number))
"Remove all menus (from the currently loaded menus) that are associated with the current menu.
Associated menus are those with the same base-name but different numbers appended to the end of the name (in brackets).
If MENUNUM is supplied it should be the index into `one-key-buffer-menu-alists' of a menu to be deleted.
Returns the number of menus deleted.
This function only works when called within the context of the one-key buffer since it depends on buffer local variables."
(one-key-delete-menus (one-key-get-associated-menu-indices menunum one-key-buffer-menu-names)))
(defun one-key-open-menus (names &optional menu-number)
"Invoke `one-key-menu' with names and corresponding menu-alists.
NAMES should be the name of a single `one-key' menu or menu type, or a list of such names.
If called interactively a single name will be prompted for."
(let* ((names (if (stringp names) (list names) names))
(pairs (remq nil (mapcar 'one-key-get-menus-for-type names)))
(names (mapcan (lambda (x) (let ((y (car x))) (if (stringp y) (list y) y))) pairs))
(alists (mapcan (lambda (x) (let ((a (car x)) (b (cdr x)))
(if (stringp a) (list b) b))) pairs)))
(if (and names alists)
(one-key-menu names alists menu-number)
(message "Invalid menu names!"))))
(defun one-key-open-menu-set (menuset &optional menu-number)
"Open `one-key' menus defined by `one-key' menu set MENUSET.
MENUSET should be the car of an element of `one-key-sets-of-menus-alist'.
If called interactively, MENUSET will be prompted for."
(interactive (list (if (featurep 'ido)
(ido-completing-read "Menu set: " (mapcar 'car one-key-sets-of-menus-alist))
(completing-read "Menu set: " (mapcar 'car one-key-sets-of-menus-alist)))))
(let* ((names (assoc-default menuset one-key-sets-of-menus-alist)))
(if names (one-key-open-menus names menu-number)
(message "Invalid menu set name!"))))
(defun one-key-rebuild-menu nil
"Rebuild the currently displayed one-key menu according to it's name.
This should only be used with menus that can be rebuilt using `one-key-get-menus-for-type'."
(let* ((this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(this-name (nth one-key-buffer-menu-number one-key-buffer-menu-names))
(isref (symbolp this-list))
(full-list (if isref (eval this-list) this-list)))
(if isref
(let ((newlist (cdr (one-key-get-menus-for-type this-name))))
(if newlist (unintern this-list)
(if (get-buffer-window (help-buffer)) (kill-buffer (help-buffer)))
(set this-list newlist)
(one-key-update-buffer-contents))))))
(defun one-key-open-default-menu-set nil
"Open the menu set defined by `one-key-default-menu-set'."
(interactive)
(one-key-open-menu-set one-key-default-menu-set
(if one-key-persistent-menu-number
one-key-default-menu-number nil)))
(defun one-key-open-associated-menu-set nil
"Open the menu set associated with the current buffer according to `one-key-associations-for-menu-sets'.
If no menu set matches then open `one-key-default-menu-set'."
(interactive)
(let* ((allmenusets (mapcar 'car one-key-sets-of-menus-alist))
(assocmenu (cdr (assoc-if (lambda (item) (or (eql item major-mode)
(and (stringp item)
(string-match item (buffer-name)))))
one-key-associations-for-menu-sets)))
(menuset (if (member assocmenu allmenusets) assocmenu one-key-default-menu-set)))
(one-key-open-menu-set menuset
(if one-key-persistent-menu-number
one-key-default-menu-number nil))))
(defun one-key-highlight (msg msg-regexp msg-face)
"Highlight text in string `MSG' that matches regular expression `MSG-REGEXP' with face `MSG-FACE'."
(with-temp-buffer
(insert msg)
(goto-char (point-min))
(while (re-search-forward msg-regexp nil t)
(add-text-properties (match-beginning 0)
(match-end 0)
msg-face))
(buffer-string)))
(defun one-key-highlight-menu (keystroke names menu-number &optional title-string)
"Highlight items in KEYSTROKE (an alist of menu items), and return contents for insertion in *One-Key* buffer.
Also create header-line from NAMES (a list of menu names), highlighting the MENU-NUMBER'th name in that list.
MENU-NUMBER should be the number of the currently selected menu in the NAMES list, or nil if NAMES contains
a single menu name.
The optional arg TITLE-STRING is a title to place above the menu items. By default this title is obtained automatically
from the associated menu type in `one-key-types-of-menu' or using `one-key-default-title-func' if that doesn't exist."
(let* ((name (if menu-number (nth menu-number names) names))
(title-func (or (fourth (one-key-get-menu-type name)) one-key-default-title-func))
(title-string2 (or title-string (and title-func (funcall title-func))))
(infoline (if (> (length title-string2) 0)
(one-key-highlight (if (equal (substring title-string2 -1) "\n") title-string2
(concat title-string2 "\n"))
"\\(<[^<>]*>\\|'[^']*'\\)" '(face one-key-name))))
(keystrokelist (one-key-highlight keystroke "\\[\\([^\\[\\]\\)*?\\]" '(face one-key-keystroke))))
(setq header-line-format (one-key-header-line-format names menu-number)
mode-line-format one-key-mode-line-format)
(concat infoline keystrokelist)))
(defun one-key-command nil
"Invoke command associated with last keypress in one-key buffer."
(interactive)
(let ((helpbufp (string= (buffer-name) one-key-help-buffer-name))
(key (one-key-key-description (this-command-keys)))
matchitem postaction)
(with-current-buffer (or (get-buffer one-key-buffer-name)
(get-buffer one-key-help-buffer-name))
(cond
((and (string-match "mouse" key)) t)
((and (string= "<switch-frame>" key)) (select-frame (previous-frame)))
((string= (buffer-name) one-key-help-buffer-name)
(setq postaction 'close))
((setq matchitem (assoc* key one-key-buffer-special-keybindings
:test (lambda (x y) (equal x (one-key-remap-key-description y)))))
(funcall (caddr matchitem))
(setq postaction one-key-buffer-temp-action))
((and (not helpbufp)
(setq matchitem (assoc* key one-key-buffer-filtered-list
:test (lambda (x y) (equal x (one-key-remap-key-description (car y)))))))
(let* ((desc (cdar matchitem))
(rest (cdr matchitem))
(command (if (commandp rest) rest
(if (one-key-list-longer-than-1-p rest)
(car rest)
(lambda nil (interactive) (message "Invalid command %S" rest))))))
(unless (not one-key-auto-brighten-used-keys)
(one-key-menu-increment-key-usage matchitem)
(let* ((thislist (nth one-key-buffer-menu-number one-key-buffer-menu-alists))
(issymbol (symbolp thislist)))
(if issymbol (add-to-list 'one-key-altered-menus (symbol-name thislist)))))
(with-selected-window one-key-buffer-associated-window (call-interactively command))
(setq postaction (or one-key-buffer-temp-action
one-key-buffer-match-action))))
((not helpbufp)
(setq postaction one-key-buffer-miss-match-action)))
(cond ((functionp postaction)
(funcall postaction))
((eq postaction 'execute)
(one-key-execute-binding-command key))
((eq postaction 'executeclose)
(one-key-execute-binding-command key)
(one-key-set-window-state 'close))
(t (one-key-set-window-state postaction)))
(with-current-buffer one-key-buffer-name (setq one-key-buffer-temp-action nil)))))
(defun* one-key-update-buffer-contents (&optional title-string (buf one-key-buffer-name))
"Update the contents of the one-key menu buffer.
The optional argument TITLE-STRING is a title to insert above the menu items. By default this string will be obtained
automatically from the associated menu type in `one-key-types-of-menu' or using `one-key-default-title-func' if that
doesn't exist."
(with-current-buffer buf
(cond ((not one-key-buffer-menu-number)
(error "Buffer local variable one-key-buffer-menu-number is nil"))
((not one-key-buffer-menu-names)
(error "Buffer local variable one-key-buffer-menu-names is nil"))
((not one-key-buffer-menu-alists)
(error "Buffer local variable one-key-buffer-menu-alists is nil")))
(setq one-key-buffer-this-list (nth one-key-buffer-menu-number one-key-buffer-menu-alists)
one-key-buffer-full-list (one-key-eval-if-symbol one-key-buffer-this-list)
one-key-buffer-this-name (nth one-key-buffer-menu-number one-key-buffer-menu-names)
one-key-buffer-filtered-list
(if (stringp one-key-buffer-filter-regex)
(remove-if-not
(lambda (elt) (string-match one-key-buffer-filter-regex (cdar elt)))
(remove nil one-key-buffer-full-list))
(remove nil one-key-buffer-full-list))
one-key-buffer-special-keybindings
(or (one-key-get-special-key-contents
(one-key-eval-if-symbol
(or (fifth (one-key-get-menu-type one-key-buffer-this-name))
one-key-default-special-keybindings)))))
(erase-buffer)
(goto-char (point-min))
(insert (one-key-highlight-menu
(one-key-menu-format one-key-buffer-filtered-list)
one-key-buffer-menu-names one-key-buffer-menu-number title-string)))
(one-key-reposition-window-contents))
(defun* one-key-menu (&optional menu-names menu-alists menu-number
&key special-keybinding-symbols title-string
(associated-window (selected-window))
(miss-match-action 'close) (match-action 'close))
"Function to open `one-key' menu of commands. The commands are executed by pressing the associated keys.
MENU-NAMES is the name of the menu as displayed in the menu window, or a list of names corresponding to different menu
lists in MENU-ALISTS.
MENU-ALISTS is either a list of menu items, a list of such lists or a symbol whose value is a list or list of lists.
Each item in a menu list is of the form: ((key . description) . command).
MENU-NUMBER should be an index (starting at 0) indicating which list to display initially (default is 0).
If either of MENU-NAMES or MENU-ALISTS is nil then the values that are already stored in the one-key buffer (as buffer local
variables) will be used, or an error will be flagged if no such values exist.
The user can switch between the menu lists by pressing the appropriate keys in `one-key-default-special-keybindings'.
If SPECIAL-KEYBINDING-SYMBOLS is non-nil then it should be a list of symbols corresponding to items in `one-key-special-keybindings',
and defines the special keys to use for this menu. Otherwise the special keys will be determined from the menu type,
or `one-key-default-special-keybindings' will be used.
TITLE-STRING is a string to display above the menu items. If TITLE-STRING is nil then the title string will be obtained
from the fourth element of the associated menu type in `one-key-types-of-menu' or using `one-key-default-title-func' if that
doesn't exist.
By default the one-key buffer will be associated with the currently selected window, and all menu commands will be executed
in that window. You can change the associated window by setting the ASSOCIATED-WINDOW arg to any other window.
If ASSOCIATED-WINDOW is explicitly set to nil then the window that was last used with one-key will be used (if it exists).
The MATCH-ACTION and MISS-MATCH-ACTION arguments indicate what to do after a matching (menu item)/non-matching key is pressed
respectively. See `one-key-buffer-match-action' and `one-key-buffer-miss-match-action' for the different values these args
can take."
(let* ((buf (or (get-buffer one-key-buffer-name)
(generate-new-buffer one-key-buffer-name)))
(menu-number (or menu-number 0)))
(set-buffer buf)
(if (not (equal major-mode 'one-key-mode)) (one-key-mode))
(let* ((onemenup (and (listp menu-alists)
(listp (car menu-alists))
(listp (caar menu-alists))
(stringp (caaar menu-alists))))
(menu-alists2 (or (if onemenup (list menu-alists) menu-alists)
one-key-buffer-menu-alists
(error "Both menu-alists and one-key-buffer-menu-alists are nil")))
(menu-names2 (or (if (stringp menu-names) (list menu-names) menu-names)
one-key-buffer-menu-names
(error "Both menu-names and one-key-buffer-menu-names are nil")))
(menu-number2 (or menu-number one-key-buffer-menu-number
(error "Both menu-number and one-key-buffer-menu-number are nil")))
(menu-number3 (if onemenup 0
(max (min menu-number2 (1- (length menu-alists2))) 0)))
(this-name (nth menu-number3 menu-names2))
(special-keybindings (or (if special-keybinding-symbols
(one-key-get-special-key-contents special-keybinding-symbols))
(if menu-alists
(one-key-get-special-key-contents
(one-key-eval-if-symbol
(or (fifth (one-key-get-menu-type this-name))
one-key-default-special-keybindings))))
one-key-buffer-special-keybindings))
(associated-window2 (or associated-window
one-key-buffer-associated-window
(error "Both associated-window and one-key-buffer-associated-window are nil")))
(miss-match-action2 (if menu-alists miss-match-action
one-key-buffer-miss-match-action))
(match-action2 (if menu-alists match-action
one-key-buffer-match-action)))
(setq one-key-buffer-menu-number menu-number3
one-key-buffer-menu-names menu-names2
one-key-buffer-menu-alists menu-alists2
one-key-buffer-special-keybindings special-keybindings
one-key-buffer-associated-window associated-window2
one-key-buffer-miss-match-action miss-match-action2
one-key-buffer-match-action match-action2
one-key-window-toggle-pos 0)
(one-key-update-buffer-contents title-string))
(one-key-set-window-state (car one-key-window-toggle-sequence))))
(defun one-key-execute-binding-command (key)
"Execute the command bound to KEY (a string description of a key), unless this command is `keyboard-quit'.
If KEY contains shift, and there is no command bound to that key, then the same key binding with shift removed
will be tried (in accordance with normal emacs behaviour)."
(let* ((rawkey (elt (eval (read-kbd-macro key)) 0))
(mods (event-modifiers rawkey))
(basic (event-basic-type rawkey))
(func (key-binding (vector rawkey)))
(keynoshift (append (remq 'shift mods) (list basic)))
(func2 (or func
(key-binding (vector (event-convert-list keynoshift))))))
(when (and (not (eq func2 'keyboard-quit))
(functionp func2))
(setq last-command-event last-input-event)
(call-interactively func2))))
(defun one-key-menu-window-exist-p nil
"Return non-nil if one-key menu window exists, otherwise return nil."
(let ((onekeybuf (get-buffer one-key-buffer-name)))
(and onekeybuf (window-live-p (get-buffer-window onekeybuf)))))
(defun one-key-reposition-window-contents nil
"Scroll the one-key buffer contents so that the top of the buffer is shown at the top of the window."
(let ((onekeywin (get-buffer-window one-key-buffer-name t)))
(if onekeywin (with-selected-window onekeywin
(goto-char (point-min)) (recenter 0)))))
(defun one-key-set-window-state (state &optional noselect)
"Set the one-key window into state STATE (a number or symbol).
For the possible values of state see `one-key-window-toggle-sequence'.
The one-key window will be selected after calling this function unless optional argument NOSELECT is non-nil."
(let* ((onekeybuf (get-buffer one-key-buffer-name))
(onekeywin (get-buffer-window one-key-buffer-name t))
(onekeyframe (if onekeywin (window-frame onekeywin)))
(helpbuf (get-buffer one-key-help-buffer-name))
(helpwin (if helpbuf (get-buffer-window helpbuf t)))
(helpframe (if helpwin (window-frame helpwin)))
(buflines (with-current-buffer (or onekeybuf (current-buffer))
(count-lines (point-min) (point-max))))
(winlines (if onekeywin (window-total-height onekeywin)))
(maxlines (if one-key-buffer-dedicated-frame
(if (display-graphic-p)
(- (/ (display-pixel-height) (frame-char-height))
(frame-parameter nil 'menu-bar-lines)
(* 2 (frame-parameter nil 'tool-bar-lines))
1)
(display-pixel-height))
(frame-parameter nil 'height)))
(cols (frame-parameter nil 'width))
(dedicatedframe (if onekeybuf
(with-current-buffer onekeybuf
(if (not onekeyframe) (setq one-key-buffer-dedicated-frame nil)
(if (and (= (length (window-list onekeyframe)) 1)
(> (length (frame-list)) 1))
(setq one-key-buffer-dedicated-frame onekeyframe)))
one-key-buffer-dedicated-frame)))
(resizeframe '(progn (set-frame-height dedicatedframe newlines)
(unless noselect
(select-frame-set-input-focus dedicatedframe)
(raise-frame dedicatedframe))
(one-key-update-buffer-contents)))
(resizewindow '(let* ((win (or onekeywin (display-buffer onekeybuf)))
(frame (window-frame win)))
(fit-window-to-buffer win newlines)
(unless noselect (select-frame-set-input-focus frame)
(select-window win))
(one-key-update-buffer-contents))))
(cond ((not (or onekeybuf helpbuf)) (error "No one-key buffer found"))
((and (not onekeybuf) (equal (current-buffer) helpbuf))
(kill-buffer helpbuf))
((integerp state)
(let ((newlines (max (min state (if dedicatedframe maxlines (1- maxlines))
(if dedicatedframe
(+ buflines 3) (+ buflines 2)))
5))
(helpp (windowp helpwin)))
(if helpp (one-key-set-window-state 'hidehelp))
(if onekeybuf
(if dedicatedframe (eval resizeframe) (eval resizewindow)))
(if helpp (one-key-set-window-state 'showhelp))))
((floatp state)
(let ((newlines (max (min (round (* (max (min state 1.0) 0.0)
(if dedicatedframe maxlines (1- maxlines))))
(if dedicatedframe
(+ buflines 3) (+ buflines 2))) 5))
(helpp (windowp helpwin)))
(if helpp (one-key-set-window-state 'hidehelp))
(if onekeybuf
(if dedicatedframe (eval resizeframe) (eval resizewindow)))
(if helpp (one-key-set-window-state 'showhelp))))
((eq state 'ownframe)
(let ((newlines (max (min maxlines (+ buflines 3) maxlines) 5))
(helpp (windowp helpwin)))
(if helpp (one-key-set-window-state 'hidehelp))
(if dedicatedframe (eval resizeframe)
(if onekeywin (delete-window onekeywin))
(switch-to-buffer-other-frame onekeybuf t)
(with-current-buffer onekeybuf (setq one-key-buffer-dedicated-frame (selected-frame)
dedicatedframe one-key-buffer-dedicated-frame))
(set-frame-size dedicatedframe cols newlines)
(if noselect (select-frame-set-input-focus (previous-frame dedicatedframe)))
(one-key-update-buffer-contents))
(if helpp (one-key-set-window-state 'showhelp))))
((eq state 'deselect)
(if dedicatedframe
(select-frame-set-input-focus (previous-frame dedicatedframe))
(select-window (if onekeywin (previous-window onekeywin)
one-key-buffer-associated-window))))
((eq state 'showhelp)
(with-selected-window (or onekeywin (selected-window))
(if (and helpframe (> (length (window-list helpframe)) 1))
(delete-window helpwin))
(let ((helpbuf (get-buffer-create one-key-help-buffer-name))
(helpbuflines (if helpbuf (with-current-buffer helpbuf
(count-lines (point-min) (point-max))))))
(if (not dedicatedframe)
(display-buffer helpbuf)
(set-frame-height dedicatedframe
(min maxlines
(+ (frame-height dedicatedframe)
helpbuflines 2)))
(set-window-buffer (split-window-below winlines) helpbuf)))))
((eq state 'hidehelp) (if helpwin
(if (or (not dedicatedframe)
(= (length (window-list helpframe)) 1))
(switch-to-prev-buffer helpwin)
(delete-window helpwin)
(set-frame-height dedicatedframe (+ winlines 1)))))
((eq state 'close)
(if dedicatedframe
(progn (unless (= (length (visible-frame-list)) 1)
(delete-frame dedicatedframe))
(setq dedicatedframe nil))
(if onekeywin
(if (> (length (visible-frame-list)) 1)
(delete-window onekeywin)
(if (> (length (window-list onekeyframe)) 1)
(delete-window onekeywin)
(switch-to-prev-buffer onekeywin))))
(if helpwin
(if (> (length (visible-frame-list)) 1)
(delete-window helpwin)
(if (> (length (window-list onekeyframe)) 1)
(delete-window helpwin)
(switch-to-prev-buffer helpwin))))))))
(one-key-reposition-window-contents))
(defun one-key-menu-window-toggle nil
"Toggle the one-key menu window to the next state in `one-key-window-toggle-sequence'."
(interactive)
(setq one-key-window-toggle-pos (mod (1+ one-key-window-toggle-pos)
(length one-key-window-toggle-sequence)))
(let* ((nextstate (nth one-key-window-toggle-pos
one-key-window-toggle-sequence))
(pair (consp nextstate)))
(if pair
(progn (one-key-set-window-state (car nextstate))
(one-key-set-window-state (cdr nextstate)))
(one-key-set-window-state nextstate))))
(defun one-key-menu-window-scroll-up (&optional down)
"Scroll up one screen of the `one-key' menu window.
If DOWN is non-nil scroll down instead of up."
(if (one-key-menu-window-exist-p)
(ignore-errors
(with-current-buffer one-key-buffer-name
(if down (scroll-down) (scroll-up))))))
(defun one-key-menu-window-scroll-up-line (&optional down)
"Scroll up one line of the `one-key' menu window."
(if (one-key-menu-window-exist-p)
(ignore-errors
(with-current-buffer one-key-buffer-name
(if down (scroll-up 1) (scroll-down 1))))))
(defun one-key-menu-increment-key-usage (item)
"Increment the key usage statistic for ITEM."
(destructuring-bind ((key . desc) . rest) item
(if (commandp rest)
(setf (cdr item) (list rest 1))
(if (and (one-key-list-longer-than-1-p rest)
(numberp (second rest)))
(progn (incf (second rest))
(setf (cdr item) rest))))))
(defsubst one-key-list-longer-than-1-p (x)
"Return t if x is a list of length > 1, and is not a command."
(and (not (commandp x))
(listp x)
(listp (cdr x))
(> (length x) 1)))
(defun one-key-menu-brighten-most-used (this-list)
"Set values of menu item colours proportionally according to how often they have been used.
Argument THIS-LIST is the alist of keys and associated decriptions and functions, or a symbol referencing the list."
(if this-list
(let ((menu-list (one-key-eval-if-symbol this-list)))
(if menu-list
(let* ((minmaxvals (loop for ((key . desc) . rest) in menu-list
for val = (if (one-key-list-longer-than-1-p rest)
(second rest) 0)
maximize val into max
minimize val into min
finally return (list min max)))
(minval (first minmaxvals))
(maxval (second minmaxvals))
(range (- maxval minval)))
(loop for item in menu-list
for ((key . desc) . rest) = item
for val = (if (one-key-list-longer-than-1-p rest)
(second rest) 0)
for vval = (if (= range 0)
0.5
(+ (/ (- val minval) (* 2.0 range)) 0.5))
for (h s v) = (one-key-get-item-colour item nil 'hsv)
for newbgcol = (hexrgb-hsv-to-hex h s vval) do
(setf (cdar item) (one-key-colourize-string newbgcol desc))))))))
(defun one-key-optimize-col-widths (lengths maxlength)
"Given a list of the lengths of the menu items, work out the maximum possible number of columns and return their widths.
Actually the function returns a list of cons cells in the form (numrows . width) each of which corresponds to a column in
the optimal assignment and indicates the number of rows and width of that column.
LENGTHS is the list of menu item lengths, and MAXLENGTH is the maximum width over which the columns may span."
(let ((nitems (length lengths))
(ncols 1)
bestcols)
(if (< (apply '+ lengths) maxlength)
(mapcar (lambda (len) (cons 1 len)) lengths)
(while (progn
(setq ncols (1+ ncols))
(let ((itemspercol (make-list ncols (/ nitems ncols)))
colspecs)
(loop for n to (1- (% nitems ncols)) do (incf (nth n itemspercol) 1))
(setq colspecs (loop for colnum to (1- ncols) with sofar = 0
for nrows = (nth colnum itemspercol)
for colwidth = (loop for rownum to (1- nrows)
for itemnum = (if one-key-column-major-order
(+ sofar rownum)
(+ colnum (* rownum ncols)))
maximize (nth itemnum lengths))
summing colwidth into width
collecting (cons nrows colwidth) into specs
do (setq sofar (+ sofar nrows))
finally (return (list width specs))))
(if (< (car colspecs) maxlength) (setq bestcols (cadr colspecs)) nil))))
(or bestcols (list (cons nitems (1- maxlength)))))))
(defun one-key-menu-format (this-list)
"Format `one-key' menu window key description text (as displayed by the `one-key-menu' function).
Argument THIS-LIST is an alist of keys and corresponding descriptions and functions, or a symbol referencing that list.
Each element of this list is in the form: ((key . describe) . command)."
(let* ((menu-list (one-key-eval-if-symbol this-list))
(winwidth (- (window-width) 1))
(maxlen (/ winwidth one-key-min-number-of-columns)))
(if (> (length menu-list) 0)
(let* (menu-list2
(item-lengths (mapcar (lambda (item)
(let* ((desc (cdar item))
(desclen (length desc))
(keydesc (one-key-remap-key-description (caar item)))
(keydesclen (length keydesc))
(rest (cdr item))
(newdesclen (min (- maxlen keydesclen 4) desclen))
(newdesc (substring desc 0 newdesclen))
(newitem (cons (cons keydesc newdesc) rest)))
(push newitem menu-list2)
(+ newdesclen keydesclen 4)))
menu-list))
(colspecs (one-key-optimize-col-widths item-lengths winwidth))
(numitems (length menu-list2))
(maxcols (length colspecs))
(maxrow (caar (last colspecs)))
(extras (% numitems maxcols))
keystroke-msg)
(setq menu-list (nreverse menu-list2))
(loop for row from 0 to maxrow
for ncols = (if (= row maxrow) extras maxcols) do
(loop for col from 0 to (1- ncols) with sofar = 0
for (colsize . width) = (nth col colspecs)
for itemnum = (if one-key-column-major-order
(+ sofar row)
(+ (* row maxcols) col))
for item = (nth itemnum menu-list)
for (key . desc) = (car item)
for keytext = (format "[%s] %s " (one-key-remap-key-description key) desc)
if item do
(push keytext keystroke-msg)
(push (make-string (- width (length keytext)) ? ) keystroke-msg)
(setq sofar (+ sofar colsize)))
(push "\n" keystroke-msg))
(mapconcat 'identity (nreverse keystroke-msg) ""))
"No menu items!")))
(defun one-key-get-menu-item (key this-list)
"Return the member of MENU-ALIST corresponding to key KEY, or nil if no such item exists.
KEY may be a char or the string representation of a char.
MENU-ALIST is a list of `one-key' menu items."
(let* ((menu-list (one-key-eval-if-symbol this-list))
(thekey (one-key-key-description key)))
(find-if (lambda (x) (equal (one-key-remap-key-description (caar x)) thekey))
menu-list)))
(defun one-key-add-menu-item (key desc contents menu-alist)
"Add a new item to MENU-ALIST in the form ((KEY . DESC) . CONTENTS), overwriting any item with the same key.
Return the new value of MENU-ALIST after adding the item.
KEY may be a char or the string representation of a char.
DESC must be a string (the description to display in the menu).
CONTENTS may be a command or a list whose first element is a command (it will be executed when KEY is pressed in the menu)."
(let* ((thekey (one-key-key-description key))
(item (one-key-get-menu-item thekey menu-alist)))
(if item (progn (setf (cdar item) desc (cdr item) contents) menu-alist)
(add-to-list 'menu-alist (cons (cons thekey desc) contents)))))
(defun one-key-open-submenu (names vars)
"Open menu/menus named NAMES with menu alist variables VARS as a submenu of the current menu, replacing it if necessary.
NAMES can be either a single string or a list of strings. VARS can be a single menu alist or a list of menu alists.
If `one-key-submenus-replace-parents' is non-nil then the current menu will be replaced with the submenu, otherwise
a new menu will be added to the current menu set.
This function only works when called within the context of the one-key buffer since it depends on buffer local variables."
(one-key-add-menus names vars)
(with-current-buffer one-key-buffer-name
(if one-key-submenus-replace-parents
(one-key-delete-menus (1- one-key-buffer-menu-number)))
(setq one-key-buffer-temp-action
(nth one-key-window-toggle-pos one-key-window-toggle-sequence))))
(defun one-key-merge-menu-lists (lista listb)
"Given two one-key menu lists, merge them and return the result.
Any items in LISTB that have the same command as an item in LISTA will be disgarded, and any keys in LISTB that
also occur in LISTA will be exchanged for a new key that doesn't occur in either list."
(loop for ((key . desc) . cmd) in (nconc lista listb) with usedkeys with usedcmds
unless (memq cmd usedcmds)
collect (cons (cons (let ((newkey (one-key-generate-key desc usedkeys nil key)))
(push newkey usedkeys)
newkey)
desc)
(progn (push cmd usedcmds) cmd))))
(defun* one-key-create-menus-from-menubar-keymap (keymap &optional (name (number-to-string (random)))
&key (invalidkeys
(append one-key-disallowed-keymap-menu-keys
(one-key-get-special-key-descriptions
one-key-default-special-keybindings))))
"Create menu alists for a menu-bar keymap KEYMAP and all sub menus.
Submenus will always be assigned to variables whose names are formed by concatenating NAME with the name of the menu-bar
submenu. If NAME is not supplied then a random number will be used instead.
Keys will be assigned to the items using the `one-key-generate-key' function. To exclude certain keys from being used
set INVALIDKEYS to a list of keys (as key-description strings or chars) to be excluded.
These keys will only be excluded from the toplevel menu, not the submenus."
(let* (
(keymap2 (if (= (length keymap) 2)
(let* ((item (cadr keymap))
(pos (position 'keymap item)))
(if pos (nthcdr pos item)
(find-if 'keymapp item)
keymap))
keymap))
(usedkeys invalidkeys)
(mainvarname (concat "one-key-menu-" name "-alist"))
(mainvar (intern mainvarname))
menu-alist)
(loop for key being the key-codes of keymap2 using (key-bindings bind)
for itemislist = (listp bind)
for itemiscons = (and itemislist (not (listp (cdr bind))))
for itemkeymap = (if (and itemislist (not itemiscons))
(let ((pos (position 'keymap bind)))
(if pos (nthcdr pos bind)
(find-if 'keymapp bind))))
for itemcmd = (if itemiscons (cdr bind)
(if itemislist
(and (position 'menu-item bind)
(find-if (lambda (x) (and (not (stringp x)) (commandp x))) bind))))
for desc = (if itemiscons (let ((bind0 (car bind))
(bind1 (cdr bind)))
(if (stringp bind0) bind0
(replace-regexp-in-string "-" " " (symbol-name bind1))))
(if itemislist
(let* ((bind0 (car bind))
(str (or (find-if 'stringp bind)
(and bind0 (symbolp bind0) (symbol-name bind0))
(if itemcmd
(capitalize
(replace-regexp-in-string "-" " " (symbol-name itemcmd)))
"unknown"))))
(cond (itemkeymap (one-key-colourize-string "cyan" str))
(t str)))))
for keystr = (if itemislist (one-key-generate-key desc usedkeys))
for cmd = (cond (itemcmd itemcmd)
(itemkeymap
(let* ((desc1 (substring-no-properties desc))
(desc2 (replace-regexp-in-string " " "_" desc1))
(submenuname (concat name "_" desc2))
(varname (concat "one-key-menu-" submenuname "-alist"))
(submenuvar (one-key-create-menus-from-menubar-keymap
itemkeymap submenuname))
(submenuitems (eval submenuvar)))
(if (> (length submenuitems) 1)
`(lambda nil (interactive)
(one-key-open-submenu ,submenuname ,submenuvar))
(push (car submenuitems) menu-alist)
(unintern varname)
nil))))
for skip = (if desc (string-match "^--" desc))
unless (or skip (not cmd)) do
(push (cons (cons keystr desc) cmd) menu-alist)
(push keystr usedkeys))
(set mainvar menu-alist)
(add-to-list 'one-key-altered-menus mainvarname)
mainvar))
(defun* one-key-create-menus-from-keymap (keymap &optional
(name (if (symbolp keymap)
(replace-regexp-in-string
"-map$" "" (symbol-name keymap))
"unknown"))
prefix
&key
(invalidkeys
(append one-key-disallowed-keymap-menu-keys
(one-key-get-special-key-descriptions
one-key-default-special-keybindings))))
"Create menu alists for a keymap and all sub keymaps.
KEYMAP is the keymap or keymap symbol to use, NAME is a name for the keymap (e.g. \"emacs-lisp-mode\") and will
be used to remove common prefix words from the item descriptions.
If a symbol is supplied for keymap then by default NAME will be set to the symbols name but with \"-map\" removed from
the end (if present).
Variables will be created for storing the menus, and the variable for the main menu will be returned.
The main variable will be named one-key-menu-NAME-alist, and the submenus variables will be named
one-key-menu-NAME-???-alist (where ??? is the name of the submenu).
If the PREFIX arg is present then key descriptions in the menu will be prefixed by this arg (this is used when the
function is called recursively).
Any submenus that have fewer than `one-key-min-keymap-submenu-size' items will be merged with their parent menu,
unless this would create a menu of more than (length one-key-default-menu-keys) items.
Also any items whose commands have keybindings that are in INVALIDKEYS will have new keys created for them.
By default this is set to the keys in `one-key-disallowed-keymap-menu-keys' and the keys used by the special keys
in `one-key-default-special-keybindings'."
(let* ((name (or name
(if (symbolp keymap)
(replace-regexp-in-string
"-map$" "" (symbol-name keymap))
"unknown")))
(keymap1 (if (functionp keymap) (symbol-function keymap)
(one-key-eval-if-symbol keymap)))
(menubar (lookup-key keymap1 [menu-bar]))
(mainvar (intern (concat "one-key-menu-" name "-alist")))
usedkeys usedcmds menu-alist)
(loop for key being the key-codes of keymap1 using (key-bindings cmd)
for keystr = (if (consp key)
(one-key-key-description (car key))
(one-key-key-description key))
for keydesc = (if prefix
(if (equal prefix "ESC")
(concat "M-" keystr)
(concat prefix " " keystr))
keystr)
unless (or (string-match one-key-null-keys keystr)
(eq key 'menu-bar)
(memq cmd usedcmds)
(member keystr usedkeys))
do (cond ((commandp cmd)
(let* (
(keymapname (replace-regexp-in-string "mode$\\|mode-map$\\|map$" "" name))
(keymapnameregex (regexp-opt (list keymapname (capitalize keymapname))))
(desc1 (if (symbolp cmd) (symbol-name cmd) (format "%S" cmd)))
(desc1a (replace-regexp-in-string keymapnameregex "" desc1))
(desc1b (capitalize (replace-regexp-in-string "-" " " desc1a)))
(desc2 (concat desc1b " (" keydesc ")"))
(keystr2 (if (member keystr invalidkeys)
(one-key-generate-key desc2 usedkeys)
keystr)))
(push cmd usedcmds)
(push keystr2 usedkeys)
(push (cons (cons keystr2 desc2) cmd) menu-alist)))
((keymapp cmd)
(let* (
(submenuname (concat name "_" keystr))
(desc2 (concat "Prefix key (" keydesc ")"))
(desc3 (one-key-colourize-string "cyan" desc2))
(keystr2 (if (member keystr invalidkeys)
(one-key-generate-key desc2 usedkeys)
keystr))
(existingvar (intern-soft (concat "one-key-menu-" submenuname "-alist"))))
(if (and existingvar (member keystr usedkeys))
(let ((menuvar (one-key-create-menus-from-keymap
cmd (concat submenuname "temp") keydesc)))
(set existingvar (one-key-merge-menu-lists (eval existingvar) (eval menuvar)))
(unintern (symbol-name menuvar)))
(let* ((menuvar (one-key-create-menus-from-keymap cmd submenuname keydesc))
(numnewitems (length (eval menuvar))))
(if (and (< numnewitems one-key-min-keymap-submenu-size)
(< (+ (length menu-alist) numnewitems) (length one-key-default-menu-keys)))
(progn (setq menu-alist (one-key-merge-menu-lists menu-alist (eval menuvar)))
(unintern (symbol-name menuvar)))
(let ((cmd2 `(lambda nil (interactive) (one-key-open-submenu ,submenuname ,menuvar))))
(push keystr usedkeys)
(push keystr2 usedkeys)
(push (cons (cons keystr2 desc3) cmd2) menu-alist)))))))))
(if (and menubar
(or (eq one-key-include-menubar-items t)
(and (eq one-key-include-menubar-items 'prompt)
(y-or-n-p "Include menu-bar items?"))))
(let ((menuvar (one-key-create-menus-from-menubar-keymap menubar (concat name "-menubar")
:invalidkeys (append usedkeys invalidkeys))))
(setq menu-alist (one-key-merge-menu-lists menu-alist (eval menuvar)))
(unintern (symbol-name menuvar))))
(set mainvar menu-alist)
(add-to-list 'one-key-altered-menus (symbol-name mainvar))
mainvar))
(defun one-key-generate-key (desc &optional usedkeys elements trykey)
"Return a key for the menu item whose description string is DESC.
The generated key can be used in a `one-key' menu, and this function can be used to help automatic creation
of `one-key' menus.
The function will try to choose a key corresponding to a char appearing in DESC, first choosing lowercase letters,
then uppercase, then key presses with control then with the meta key.
USEDKEYS should be a list of keys (as string descriptions, e.g. as returned by `kbd') which cannot be used.
If the ELEMENTS arg (a list of keys) is provided the normal key selection method will not be used and instead a key
from ELEMENTS that is not in USEDKEYS will be chosen instead.
If TRYKEY is provided it should be a key and will be returned if it is not in USEDKEYS (otherwise another key will be
found)."
(let ((trykey2 (one-key-key-description trykey)))
(flet ((findmatch (transformer keys)
(dolist (key keys)
(let ((key2 (funcall transformer key)))
(if (not (member key2 usedkeys))
(return key2)))))
(uptransformer (prefix) `(lambda (char) (concat ,prefix (upcase (char-to-string char)))))
(downtransformer (prefix) `(lambda (char) (concat ,prefix (downcase (char-to-string char)))))
(findall (keys) (or (findmatch (downtransformer "") keys)
(findmatch (uptransformer "") keys)
(findmatch (downtransformer "C-") keys)
(findmatch (uptransformer "C-") keys)
(findmatch (downtransformer "M-") keys)
(findmatch (uptransformer "M-") keys))))
(or (and trykey2 (not (member trykey2 usedkeys))
trykey2)
(if elements (loop for element in elements
for keystr = (one-key-key-description element)
if (not (member keystr usedkeys))
return keystr))
(findall (reverse (intersection one-key-default-menu-keys (mapcar 'identity desc))))
(findall one-key-default-menu-keys)
(error "Can not generate a unique key for item : %s" desc)))))
(defun one-key-remap-key-description (keydesc)
"Remap key description string KEYDESC according to it's entry in `one-key-key-description-remap' if it has one."
(or (assoc-default keydesc one-key-key-description-remap) keydesc))
(defun* one-key-remap-invalid-keys (menu-alist &key
(invalidkeys
(append one-key-disallowed-keymap-menu-keys
(one-key-get-special-key-descriptions
one-key-default-special-keybindings)))
(keyfunc 'one-key-generate-key))
"Remap any keys in the one-key menu MENULIST that are in INVALIDKEYS to new unused keys.
INVALIDKEYS should be a list of string descriptions of keys (e.g. as returned by the `kbd' macro).
New keys are selected using KEYFUNC which should be a function taking two arguments - a description of the command and a list of
used keys (in that order), and return a new unused key. The default value for KEYFUNC is `one-key-generate-key'.
By default INVALIDKEYS is set to the keys in `one-key-disallowed-keymap-menu-keys' and `one-key-default-special-keybindings'"
(let ((usedkeys invalidkeys)
newkey)
(loop for ((key . desc) . cmd) in (one-key-eval-if-symbol menu-alist)
if (member key usedkeys)
do (setq newkey (funcall keyfunc desc usedkeys))
and collect (cons (cons newkey desc) cmd)
and do (push newkey usedkeys)
else collect (cons (cons key desc) cmd)
and do (push key usedkeys))))
(defun one-key-key-description (keyseq)
"Return the key description for the key sequence or single key KEYSEQ.
KEYSEQ may be a vector, integer, symbol or string representing a key sequence, or nil.
If KEYSEQ is nil then nil is returned, if it is non-nil and not a string, vector, symbol or number then an error is flagged."
(one-key-remap-key-description
(cond ((not keyseq) nil)
((vectorp keyseq) (key-description keyseq))
((numberp keyseq) (single-key-description keyseq))
((symbolp keyseq) (single-key-description keyseq))
((stringp keyseq) (if (string-match "^C-\\|^M-\\|^RET\\|^SPC\\|^TAB\\|^<[a-z0-9-]+>\\|^[a-zA-Z0-9]" keyseq)
keyseq
(key-description keyseq)))
((listp keyseq) (single-key-description (car keyseq)))
(t (error "Invalid key sequence: %S" keyseq)))))
(defun one-key-append-keys-to-descriptions (descriptions keys)
"Append key descriptions for keys in KEYS to corresponding descriptions in DESCRIPTIONS, and return result.
DESCRIPTIONS should be a list of menu item descriptions and KEYS should be a list of keys as numbers, vectors or strings.
KEYS should be the same length as DESCRIPTIONS.
If any elements of key are nil then the corresponding description will be left alone.
If any element of descriptions is nil it will be left as nil."
(flet ((addkeys (desc key)
(let ((keystr (one-key-key-description key)))
(if desc
(if keystr (concat desc " (" keystr ")")
desc)
nil))))
(mapcar* 'addkeys descriptions keys)))
(defun one-key-append-numbers-to-menu-name (menuname nummenus)
"Return list of menu names formed by appending numbers to MENUNAME.
The new names will be in the form \"MENUNAME (N)\" where N runs over the integers from 1 to NUMMENUS.
This is useful for creating menu types that return multiple menus."
(loop for num from 1 to nummenus
collect (concat menuname " (" (number-to-string num) ")")))
(defun one-key-get-menu-splits (nitems maxsize)
"Return pairs of indices indicating how NITEMS menu items should be divided among menus of size MAXSIZE.
The return value is a list of cons cells each containing start and end indices indicating which items should go
in the associated menu."
(let* ((nitemslast (% nitems maxsize)))
(loop with start = 0
with end = 0
while (< end nitems)
do (setq start end end (min (+ end maxsize) nitems))
collect (cons start end))))
(defun* one-key-create-menu-lists (commands &optional descriptions keys (addkeydescs t)
&key (maxsize (length one-key-default-menu-keys))
(keyfunc 'one-key-generate-key)
(invalidkeys
(append one-key-disallowed-keymap-menu-keys
(one-key-get-special-key-descriptions
one-key-default-special-keybindings))))
"Create list/lists of menu items for use in `one-key' menu.
COMMANDS should be a list of commands for the menu items, and KEYS an optional corresponding list of keys.
If any element in KEYS is nil, or is a repeat of a previously used key in the current menu, or if KEYS is nil,
then KEYFUNC will be used to generate a key for the item.
KEYFUNC should be a function of two arguments: the item description and a list of used keys (in that order).
DESCRIPTIONS is an optional argument which should contain a list of descriptions for the menu items.
If any of the items in DESCRIPTIONS is nil or if DESCRIPTIONS is not supplied then the item will have its description
set from the corresponding command name.
If the number of menu items is larger than MAXSIZE then several menus will be created, each of
which contains at most MAXSIZE items. By default MAXSIZE is equal to the length of `one-key-default-menu-keys',
and KEYFUNC is set to `one-key-generate-key' (which selects keys from `one-key-default-menu-keys').
If ADDKEYDESCS is non-nil (default) then key descriptions will be added to the end of the command descriptions
in the menu.
INVALIDKEYS is an optional list of keys to exclude from the menu. If any key in KEYS is also in INVALIDKEYS then
a new key will be created to replace it. By default it is set to the keys in `one-key-disallowed-keymap-menu-keys'
and `one-key-get-special-key-descriptions'.
MAXSIZE, KEYFUNC and INVALIDKEYS are keyword arguments and need to be set using, e.g. :maxsize arg1, :keyfunc arg2,
and :invalidkeys arg3."
(let* ((nitems (length commands))
(indices (one-key-get-menu-splits nitems maxsize))
(nummenus (length indices))
(menu-alists
(loop for (start . end) in indices
for cmds = (subseq commands start end)
for descs = (subseq descriptions start end)
for keys2 = (subseq keys start end)
for usedkeys = invalidkeys
for descs2 = (loop for desc in descs
for cmd in cmds
for key in keys2
for desc2 = (or desc
(capitalize
(replace-regexp-in-string
"-" " " (symbol-name cmd))))
collect (if (and key addkeydescs)
(concat desc2 " ("
(one-key-key-description key)
")")
desc2))
for keystrs = (loop for key in keys2
for desc in descs2
for keydesc = (one-key-key-description key)
if (member* keydesc usedkeys
:test (lambda (a b) (equal a (one-key-key-description b))))
collect (let ((newkey (funcall keyfunc desc usedkeys)))
(push newkey usedkeys)
newkey)
else
collect (or (and key (push keydesc usedkeys) keydesc)
(let ((newkey (funcall keyfunc desc usedkeys)))
(push newkey usedkeys)
newkey)))
collect (loop for cmd in cmds
for desc in descs2
for key in keystrs
collect (cons (cons key desc) cmd)))))
menu-alists))
(defun one-key-build-menu-sets-menu-alist nil
"Build menu-alist for opening menu sets defined in `one-key-sets-of-menus-alist'."
(let* ((descriptions (mapcar (lambda (item)
(let ((str (car item)))
(if (equal str one-key-default-menu-set)
(one-key-colourize-string "red" str)
str))) one-key-sets-of-menus-alist))
(commands (mapcar (lambda (item)
`(lambda nil (interactive)
(one-key-open-menu-set ,(car item))))
one-key-sets-of-menus-alist)))
(car (one-key-create-menu-lists commands descriptions))))
(defun one-key-save-altered-menus nil
"Save the menus listed in `one-key-altered-menus' into the file `one-key-menus-save-file'.
Any menu names that match the regular expressions in `one-key-exclude-from-save' will not be saved."
(loop for x in one-key-altered-menus
for varname = (if (stringp x) x (if (symbolp x) (symbol-name x)))
for name = (if (string-match "one-key-menu-.*-alist" varname)
(substring varname 13 -6))
for var = (intern-soft varname)
for menulist = (eval var)
for exclude = (loop for regex in one-key-exclude-from-save
if (string-match regex varname) return t)
if (and name var (not exclude)) do (one-key-save-menu name var)))
(defun one-key-get-major-mode-menu (name)
"Return a menu name and menu alist for the current major mode.
This function is used by `one-key-types-of-menu' and the NAME argument is redundant.
A cons cell in the form (menu-name . menu-alist) will be returned.
If there is an element of `one-key-major-mode-remap-alist' associated with the current major mode then that will be used,
otherwise the name of the current major mode will be used.
In both cases if the variable `one-key-menu-<menu-name>-alist' (where <menu-name> is the menu name associated with this
major mode) exists then it will be used, otherwise it will be created."
(let* ((modename (or (assoc-default major-mode one-key-major-mode-remap-alist)
(with-selected-window
(previous-window)
(symbol-name major-mode))))
(menuname (concat "major-mode:" (replace-regexp-in-string "-mode$" "" modename)))
(symname (concat "one-key-menu-" modename "-alist"))
(menusym (intern-soft symname)))
(if (or (not menusym) (not (boundp menusym)))
(let* ((mapname (concat modename "-map"))
(mapsym (intern-soft mapname)))
(if (and mapsym (boundp mapsym))
(progn (one-key-create-menus-from-keymap mapsym modename)
(setq menusym (intern-soft symname)))
(message "Can't create menu for %S" major-mode)
(setq menusym nil))))
(cons menuname menusym)))
(defun one-key-create-blank-menu (name)
"Prompt user for a name, create a blank one-key menu and return a cons cell containing the name and the menu."
(let* ((name (read-string "Menu name: "))
(symname (concat "one-key-menu-" name "-alist"))
(menusym (intern-soft symname)))
(while menusym
(if (not (y-or-n-p "Menu with that name already exists, overwrite?"))
(progn (setq name (read-string "Menu name: "))
(setq symname (concat "one-key-menu-" name "-alist"))
(setq menusym (intern-soft symname)))
(setq menusym nil)))
(setq menusym (intern symname))
(set menusym nil)
(add-to-list 'one-key-altered-menus (symbol-name menusym))
(cons name menusym)))
(defun one-key-retrieve-existing-menu (x)
"Prompt for an existing one-key menu and return it in a cons cell along with its name."
(let* ((names (loop for sym being the symbols
for name = (symbol-name sym)
when (string-match "one-key-menu-\\(.+\\)-alist" name)
collect (match-string 1 name)))
(name (if (featurep 'ido)
(ido-completing-read "Menu: " names)
(completing-read "Menu: " names))))
(cons name (intern-soft (concat "one-key-menu-" name "-alist")))))
(defun one-key-create-menu-from-existing-keymap (name)
"Prompt the user for a keymap and return a one-key menu for it along with it's name, in a cons cell."
(let (partname)
(if (string-match "^keymap:" name)
(setq partname (replace-regexp-in-string "^keymap:" "" name)
name (concat partname "-map"))
(let* ((names (loop for sym being the symbols
when (or (keymapp sym)
(and (boundp sym)
(keymapp (symbol-value sym))))
collect (symbol-name sym))))
(setq name (if (featurep 'ido)
(ido-completing-read "Keymap: " names)
(completing-read "Keymap: " names))
partname (replace-regexp-in-string "-map$" "" name))))
(let ((kmap (intern-soft name)))
(one-key-create-menus-from-keymap kmap partname)
(cons (concat "keymap:" partname)
(intern-soft (concat "one-key-menu-" partname "-alist"))))))
(defun one-key-create-menu-from-prefix-key-keymap (keystr)
"Prompt the user for a prefix key and return a one-key menu for it along with it's name, in a cons cell."
(interactive (let ((keystr (read-string "Enter the emacs string representation of the required prefix keys: ")))
(while (not (ignore-errors (read-kbd-macro keystr)))
(setq keystr (read-string "Invalid key sequence! Try again: ")))
(list keystr)))
(let (keysequence kmap)
(setq keysequence (read-kbd-macro keystr))
(setq kmap (key-binding keysequence))
(if (keymapp kmap)
(let* ((kmap2 (if (functionp kmap) (symbol-function kmap)
(one-key-eval-if-symbol kmap)))
(desc1 (replace-regexp-in-string " " "_" keystr))
(desc2 (replace-regexp-in-string "#" "\\\\#" desc1))
(desc3 (concat "prefix-key:" desc2)))
(cons desc3 (one-key-create-menus-from-keymap kmap2 desc3 desc2)))
(error "No keymap is currently associated with that prefix key!"))))
(defun one-key-prefix-key-menu-command (keystr &optional submenup)
"Given prefix key description KEYSTR open a one-key menu containing the commands associated with that prefix key.
If SUBMENUP is non-nil then the `one-key-open-submenu' command is used to add/replace a menu in the current menu set."
(interactive (let ((keystr (read-string "Enter the emacs string representation of the required prefix keys: ")))
(while (not (ignore-errors (read-kbd-macro keystr)))
(setq keystr (read-string "Invalid key sequence! Try again: ")))
(list keystr)))
(let* ((pair (one-key-create-menu-from-prefix-key-keymap keystr))
(name (car pair))
(menu (cdr pair)))
(if submenup
(one-key-open-submenu name menu)
(one-key-menu name menu))))
(defun one-key-create-menu-sets-title-format-string nil
"Return a title format string for menu sets one-key menus."
(let* ((col1 (if one-key-auto-brighten-used-keys "#7FFF00000000" "red"))
(col2 (cdr (assq 'background-color (frame-parameters))))
(hsv2 (hexrgb-hex-to-hsv col2))
(col2a (hexrgb-hsv-to-hex (first hsv2) (second hsv2) 0.5))
(col2b (if one-key-auto-brighten-used-keys col2a col2))
(keystr1 (one-key-colourize-string col1 "default menu set"))
(keystr2 (one-key-colourize-string col2b "normal menu set"))
(menuname (nth one-key-buffer-menu-number one-key-buffer-menu-names))
(sortindex (or (assoc-default menuname one-key-sort-method-indices-alist) 0))
(sortmethods (or (nth 5 (one-key-get-menu-type menuname))
one-key-default-sort-method-alist)))
(concat keystr1 keystr2 "\n"
(format "Sorted by %s (%s first). Press <f1> for help.\n"
(car (nth sortindex sortmethods))
(if one-key-column-major-order "columns" "rows")))))
(defun one-key-submit-bug-report nil
"Submit a bug report for one-key via mail."
(interactive)
(require 'reporter)
(one-key-set-window-state 'close)
(let ((reporter-prompt-for-summary-p "Bug report subject: "))
(reporter-submit-bug-report
one-key-maintainer-email
(concat "one-key version " one-key-version)
(list 'one-key-altered-menus
'one-key-auto-brighten-used-keys
'one-key-autosave-menus
'one-key-buffer-name
'one-key-column-major-order
'one-key-copied-items
'one-key-current-item-being-moved
'one-key-default-menu-keys
'one-key-default-menu-number
'one-key-default-menu-set
'one-key-default-sort-method-alist
'one-key-default-special-keybindings
'one-key-default-title-func
'one-key-disallowed-keymap-menu-keys
'one-key-exclude-from-save
'one-key-include-menubar-items
'one-key-item-foreground-colour
'one-key-major-mode-remap-alist
'one-key-menu-sets-special-keybindings
'one-key-menu-show-key-help
'one-key-menu-window-max-height
'one-key-menus-save-file
'one-key-min-keymap-submenu-size
'one-key-mode-line-format
'one-key-mode-line-message
'one-key-null-keys
'one-key-persistent-menu-number
'one-key-popup-window
'one-key-sets-of-menus-alist
'one-key-special-keybindings
'one-key-submenus-replace-parents
'one-key-menu-toplevel-alist
'one-key-types-of-menu)
nil nil
"Remember to cover the basics, that is, what you expected to happen and
what in fact did happen.
Please mention which major mode was active and what keys were pressed at the time of the fault.
To read how to make a good bug report see:
http://www.gnu.org/software/emacs/manual/html_node/emacs/Understanding-Bug-Reporting.html
------------------------------------------------------------------------")))
(defun* one-key-center-string (string &optional (width (window-width)) shorten)
"Center STRING in space padded string of length WIDTH, and return padded string.
If length of STRING is greater than WIDTH, and shorten is non-nil then return middle section of STRING of length WIDTH.
By default WIDTH is set to the current window width (as returned by the `window-width' function)."
(let* ((strlen (length string))
(lpadlen (/ (- width strlen) 2))
(rpadlen (- width strlen lpadlen)))
(if (> width strlen)
(concat (make-string lpadlen ? ) string (make-string rpadlen ? ))
(if shorten (substring string (- lpadlen) rpadlen) string))))
(defun* one-key-read (prompt collection
&optional predicate require-match def title-string
(special-keys '(quit-close quit-open toggle-display next-menu prev-menu up down
scroll-down scroll-up toggle-help documentation
toggle-row/column-order sort-next sort-prev
reverse-order limit-items donate report-bug)))
"one-key replacement for the built-in `completing-read' function.
PROMPT is the title string for the *One-Key* buffer.
COLLECTION can be a list of strings, an alist, an obarray or a hash table.
If non-nil PREDICATE is a predicate function used to filter the items in COLLECTION before placing them in the menu
(see `try-completion' for more details).
If REQUIRE-MATCH is non-nil then the *One-Key* window will not disappear until an item key is pressed or the menu is quit
using the appropriate special key.
If REQUIRE-MATCH is nil then the *One-Key* window will close if a key is pressed which doesn't correspond to a menu item
or a special key, and the value of DEF will be returned.
The optional argument SPECIAL-KEYS is a list of symbols refering to the special keys to use for this menu,
and they must be defined in `one-key-special-keybindings'. You can usually leave the SPECIAL-KEYS argument alone as it uses
sensible defaults."
(flet ((tostring (x) (cond ((stringp x) x)
((symbolp x) (symbol-name x))
((numberp x) (number-to-string x))
((listp x) (tostring (car x))))))
(let* (selected-item
(collection2 (if (hash-table-p collection)
(loop for key being the hash-keys of collection using (hash-values val)
if (or (not predicate)
(funcall predicate key val))
collect key)
(if predicate (remove-if-not predicate collection) collection)))
(collection3 (remq nil (mapcar 'tostring collection2)))
(commands (mapcar (lambda (choice)
`(lambda nil
(interactive)
(setq selected-item ,choice)))
collection3))
(menu-alists (one-key-create-menu-lists commands collection3))
(nummenus (length menu-alists))
(names (if (> nummenus 1)
(one-key-append-numbers-to-menu-name prompt nummenus)
(list prompt))))
(one-key-menu names menu-alists
:miss-match-action (if require-match nil 'close)
:title-string (or title-string "")
:special-keybinding-symbols special-keys)
(or selected-item def))))
(defun* one-key-read-tree-1 (prompt collection
&optional maxdepth (depth 0)
(displayfunc 'one-key-read-tree-display-func)
(special-keys '(quit-close quit-open toggle-display next-menu prev-menu up down scroll-down
scroll-up toggle-help documentation toggle-row/column-order
sort-next sort-prev reverse-order limit-items donate
report-bug read-tree-down read-tree-down2 read-tree-up read-tree-up2
read-tree-delete)))
"Recursive function for reading trees/recursive lists from the user.
NOTE: This function is called by `one-key-read-tree', `one-key-read-multiple', and `one-key-read-dnf'.
It assumes dynamic binding of okr-title-string which is used by displayfunc to set the title string for the one-key menu.
The PROMPT and COLLECTION arguments are as in `one-key-read'.
MAXDEPTH is the maximum depth allowed for the tree (toplevel has depth 0), and DEPTH is the current depth of the tree.
DISPLAYFUNC should be a function that takes four arguments, choice, depth, maxdepth and tree, where choice is the last item chosen,
depth and maxdepth are the previously mentioned arguments of the same name, and tree is the current subtree. It is called every
time a choice is selected from the one-key menu and should return a value to be added to the tree (the return value of
`one-key-read-tree-1'). It may also make alterations to the dynamically bound variable okr-title-string, a string which is
displayed at the top of the one-key menu.
If the user presses a special key to complete a sublist, start a new sublist, or delete the previous item in the list then the
DISPLAYFUNC function will be called with the choice arg set to the symbol 'goup, 'godown or 'del respectively, and the return
value will not be used. The DISPLAYFUNC function will also be called when a sublist is completed, with the choice arg set to
that list. In this case you may want to make alterations to the sublist before returning it, but not necessarily update the title
string. See `one-key-read-tree-display-func' and `one-key-read-dnf-display-func' for examples."
(let* ((choice t) tree)
(while choice
(setq choice (one-key-read prompt collection nil nil nil okr-title-string special-keys))
(setq newchoice (funcall displayfunc choice depth maxdepth tree))
(case choice
('godown (if (and maxdepth (>= depth maxdepth))
(message "Can't go down any further!")
(setq tree (append tree (list (funcall displayfunc
(one-key-read-tree-1 prompt collection maxdepth
(1+ depth) displayfunc special-keys)
depth maxdepth tree))))))
('goup (setq choice nil))
('del (setq tree (butlast tree)))
(t (if choice (setq tree (append tree (list newchoice)))
(setq choice t)
(message "Invalid choice")))))
tree))
(defun* one-key-read-tree (prompt collection &optional maxdepth actionfunc returntitle)
"Function for reading recursive lists from the user with a one-key menu.
PROMPT and COLLECTION are as in `one-key-read'.
The optional argument MAXDEPTH is the maximum depth allowed for the tree (toplevel has depth 0).
By default no bound is placed on the maximum depth.
If ACTIONFUNC is supplied it should be a function that takes three arguments: the currently selected item (a string or a symbol,
see below), the current tree depth, and maxdepth (in that order). The function may perform some actions and should return an item
to be added to the tree. The function is called each time an item is selected/deleted, or when the user goes up/down a level.
For its first argument the function is passed the name of an item when an item is selected, the symbol 'del when an item is deleted,
'goup when the user goes up a level and 'godown when the user goes down a level.
If RETURNTITLE is non-nil then return a cons cell whose car is the final title string used in the one-key menu, and whose cdr is
the tree. Otherwise just return the tree."
(let* ((okr-title-string (concat (one-key-center-string
(concat
"Press "
(caar (one-key-get-special-key-contents 'read-tree-up))
" to complete a list, "
(caar (one-key-get-special-key-contents 'read-tree-down))
" to start a new list, and "
(caar (one-key-get-special-key-contents 'read-tree-delete))
" to remove the last element.")) "\n"
(one-key-center-string "Current depth=0, Current selection:") "\n"))
(tree (one-key-read-tree-1 prompt collection maxdepth 0
(apply-partially 'one-key-read-tree-display-func actionfunc))))
(string-match ".*\n.*\n *\\(.*[^ ]\\) *) *$" okr-title-string)
(if returntitle (cons (match-string 1 okr-title-string) tree) tree)))
(defun* one-key-read-list (prompt collection &optional actionfunc returntitle)
"one-key replacement for the built-in `completing-read-multiple' function.
See `one-key-read-tree' for a description of the arguments."
(let* ((okr-title-string (concat (one-key-center-string
(concat
"Press "
(caar (one-key-get-special-key-contents 'read-tree-up))
" to finish selecting, and "
(caar (one-key-get-special-key-contents 'read-tree-delete))
" to remove the last element.")) "\n"
(one-key-center-string "Current selection:") "\n"))
(list1 (one-key-read-tree-1 prompt collection 0 0
(apply-partially 'one-key-read-tree-display-func actionfunc))))
(string-match ".*\n.*\n *\\(.*[^ ]\\) *) *$" okr-title-string)
(if returntitle (cons (match-string 1 okr-title-string) list1) list1)))
(defun* one-key-read-logical-formula (prompt collection &optional actionfunc returntitle)
"Function for reading logical formula from the user with a one-key menu.
The result is returned as a recursive list, with 'and' or 'or' symbols as the first element of each list depending on the depth.
See `one-key-read-tree' for a description of the arguments."
(let* ((okr-title-string (concat (one-key-center-string
(concat
"Press "
(caar (one-key-get-special-key-contents 'read-tree-up))
" to close bracket, "
(caar (one-key-get-special-key-contents 'read-tree-down))
" to open bracket, "
(caar (one-key-get-special-key-contents 'read-tree-delete))
" to remove last element, and "
(caar (one-key-get-special-key-contents 'read-logical-negate))
" to negate next element.")) "\n"
(one-key-center-string "Current selection:") "\n"))
(form1 (one-key-read-tree-1 prompt collection nil 0
(apply-partially 'one-key-read-logical-formula-display-func actionfunc)
'(quit-close quit-open toggle-display next-menu prev-menu up down scroll-down
scroll-up toggle-help documentation toggle-row/column-order
sort-next sort-prev reverse-order limit-items donate
report-bug read-tree-down read-tree-down2 read-tree-up read-tree-up2
read-logical-negate read-tree-delete)))
(form2 (if form1 (cons 'or form1))))
(string-match ".*\n.*\n *\\(.*[^ ]\\) *) *$" okr-title-string)
(if returntitle
(cons (substring-no-properties (match-string 1 okr-title-string)) form2)
form2)))
(defun one-key-read-tree-display-func (actionfunc choice depth maxdepth tree)
"Default function used for displaying information in calls to `one-key-read-tree' (which see).
This function assumes dynamic binding of okr-title-string to the current title string of the one-key menu."
(let* ((newstring (replace-regexp-in-string
"Current depth=\\([0-9]+\\)" (number-to-string depth)
(case choice
('goup (concat okr-title-string " )"))
('godown (if (or (not maxdepth) (< depth maxdepth)) (concat okr-title-string " (") okr-title-string))
('del (replace-regexp-in-string ".*\n.*\n.*\\(([^()]*) *$\\|[^ ()]+ *$\\)" "" okr-title-string nil nil 1))
(t (if (and choice (not (listp choice)))
(concat okr-title-string " " choice) okr-title-string)))
nil nil 1)))
(string-match "\\(.*\n.*\n\\) *\\(.*[^ ]+\\)" newstring)
(setq okr-title-string (concat (match-string 1 newstring)
(replace-regexp-in-string " *$" ""
(one-key-center-string (match-string 2 newstring))))))
(if actionfunc (funcall actionfunc choice depth maxdepth) choice))
(defun one-key-read-logical-formula-display-func (actionfunc choice depth maxdepth tree)
"Default function used for displaying information in calls to `one-key-read-logical-formula'.
This function assumes dynamic binding of okr-title-string to the current title string of the one-key menu."
(let* ((isor (= (% depth 2) 0))
(negated (eq (car (last tree)) 'not))
(seperator (unless (string-match ".*\n.*\n\\(.*(\\|.*!\\)? *$" okr-title-string)
(if isor " | " " & ")))
(newstring (case choice
('goup (concat okr-title-string ")"))
('godown (concat okr-title-string seperator "("))
('del (with-temp-buffer
(insert okr-title-string)
(if (= (char-before) 41)
(backward-sexp))
(if (string-match "^.*\n.*\n *$" (buffer-substring-no-properties 1 (point)))
okr-title-string
(re-search-backward "\n *\\| *|\\| *&\\|(")
(if (or (= (char-after) 40)
(= (char-after) 10))
(forward-char) (backward-char))
(buffer-substring 1 (point)))))
('not (concat okr-title-string seperator "!"))
(t (if (and choice (not (listp choice)))
(concat okr-title-string seperator choice) okr-title-string))))
(retchoice (if (not choice) (if isor nil t)
(if (listp choice)
(cons (if isor 'and 'or) choice)
(if actionfunc (funcall actionfunc choice depth maxdepth) choice)))))
(string-match "\\(.*\n.*\n\\) *\\(.*[^ ]+\\)" newstring)
(setq okr-title-string (if (match-string 2 newstring)
(concat (match-string 1 newstring)
(replace-regexp-in-string
" *$" "" (one-key-center-string (match-string 2 newstring))))
newstring))
(if (not negated) retchoice
(unless (eq choice 'godown)
(if (equal (length tree) 1) (setcar tree (if isor nil t))
(setf (nthcdr (1- (length tree)) tree) nil)))
(list 'not retchoice))))
(one-key-add-to-alist 'one-key-types-of-menu
(list "top-level"
(lambda (name) (equal name "top-level"))
(cons "top-level" 'one-key-menu-toplevel-alist)
nil nil) t)
(one-key-add-to-alist 'one-key-types-of-menu
(list "blank menu"
(lambda (name) (equal name "blank menu"))
'one-key-create-blank-menu
nil nil) t)
(one-key-add-to-alist 'one-key-types-of-menu
(list "major-mode"
(lambda (name) (string-match "^major-mode" name))
'one-key-get-major-mode-menu
nil 'one-key-major-mode-special-keybindings) t)
(one-key-add-to-alist 'one-key-types-of-menu
(list "existing menu"
(lambda (name) (equal name "existing menu"))
'one-key-retrieve-existing-menu
nil nil) t)
(one-key-add-to-alist 'one-key-types-of-menu
(list "keymap"
(lambda (name) (string-match "^keymap" name))
'one-key-create-menu-from-existing-keymap
nil nil) t)
(one-key-add-to-alist 'one-key-types-of-menu
(list "prefix-key"
(lambda (name) (string-match "^prefix-key" name))
(lambda (name)
(let* ((keystr1 (if (> (length name) 11) (substring name 11) nil))
(keystr2 (if keystr1 (replace-regexp-in-string "_" "" keystr1))))
(if keystr2
(one-key-create-menu-from-prefix-key-keymap keystr2)
(call-interactively 'one-key-create-menu-from-prefix-key-keymap))))
nil nil) t)
(one-key-add-to-alist 'one-key-types-of-menu
(list "menu-sets"
(lambda (name) (equal name "menu-sets"))
(lambda (name)
(cons name (one-key-build-menu-sets-menu-alist)))
'one-key-create-menu-sets-title-format-string
'one-key-menu-sets-special-keybindings) t)
(add-hook 'kill-emacs-hook (lambda nil (if one-key-autosave-menus (one-key-save-altered-menus))))
(if one-key-menus-save-file
(if (file-readable-p one-key-menus-save-file)
(load-file one-key-menus-save-file)
(message "Can't read file %s" one-key-menus-save-file))
(message "`one-key-menus-save-file' is not set, no menus loaded"))
(provide 'one-key)