;;; makey.el --- interactive commandline mode ;; Copyright (C) 2010-2013 The Magit Project Developers. ;; Copyright (C) 2013 Mickey Petersen ;; Author: Mickey Petersen ;; Keywords: ;; Version: 0.3 ;; Package-Requires: ((cl-lib "0.2")) ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; ;;; Code: (eval-when-compile (require 'cl-lib)) (defvar makey-key-mode-keymaps) (defvar makey-key-mode-last-buffer) (defvar makey-pre-key-mode-window-conf) ;;; Options (defcustom makey-key-mode-show-usage t "Whether to show usage information when entering a popup." :group 'makey :type 'boolean) ;;; Faces (defface makey-key-mode-header-face '((t :inherit font-lock-keyword-face)) "Face for key mode header lines." :group 'makey-faces) (defface makey-key-mode-button-face '((t :inherit font-lock-builtin-face)) "Face for key mode buttons." :group 'makey-faces) (defface makey-key-mode-switch-face '((t :inherit font-lock-warning-face)) "Face for key mode switches." :group 'makey-faces) (defface makey-key-mode-args-face '((t :inherit widget-field)) "Face for key mode switch arguments." :group 'makey-faces) (defun makey-key-mode-delete-group (group master-group) "Delete a group from MASTER-GROUP" (let ((items (assoc group master-group))) (when items ;; reset the cache (setq makey-key-mode-keymaps nil) ;; delete the whole group (setq master-group (delq items master-group)) ;; unbind the defun (makey-key-mode-de-generate group)) master-group)) (defun makey-key-mode-add-group (group master-group) "Add a new group to MASTER-GROUP If there already is a group of that name then this will completely remove it and put in its place an empty one of the same name." (when (assoc group master-group) (makey-key-mode-delete-group group master-group)) (setq master-group (cons (list group (list 'actions) (list 'switches)) master-group))) (defun makey-key-mode-key-defined-p (for-group key) "Return t if KEY is defined as any option within FOR-GROUP The option may be a switch, argument or action." (catch 'result (let ((options (makey-key-mode-options-for-group for-group))) (dolist (type '(actions switches arguments)) (when (assoc key (if (eq type 'actions) (makey-get-actions options) (assoc type options))) (throw 'result t)))))) (defun makey-key-mode-update-group (for-group thing &rest args) "Abstraction for setting values in `makey-key-mode-keymaps'." (let* ((options (makey-key-mode-options-for-group for-group)) (things (assoc thing options)) (key (car args))) (if (cdr things) (if (makey-key-mode-key-defined-p for-group key) (error "%s is already defined in the %s group." key for-group) (setcdr (cdr things) (cons args (cddr things)))) (setcdr things (list args))) (setq makey-key-mode-keymaps nil) things)) (defun makey-key-mode-insert-argument (for-group key desc arg read-func) "Add a new binding KEY in FOR-GROUP which will use READ-FUNC to receive input to apply to argument ARG is run. DESC should be a brief description of the binding." (makey-key-mode-update-group for-group 'arguments key desc arg read-func)) (defun makey-key-mode-insert-switch (for-group key desc switch) "Add a new binding KEY in FOR-GROUP which will add SWITCH to the command line when it runs. DESC should be a brief description of the binding." (makey-key-mode-update-group for-group 'switches key desc switch)) (defun makey-key-mode-insert-action (for-group key desc func) "Add a new binding KEY in FOR-GROUP which will run command FUNC. DESC should be a brief description of the binding." (makey-key-mode-update-group for-group 'actions key desc func)) (defun makey-key-mode-options-for-group (for-group) "Retrieve the options for the group FOR-GROUP. This includes switches, commands and arguments." (funcall (intern (concat "makey-key-mode-options-for-" (symbol-name for-group))))) (defun makey-key-mode-help (for-group) "Provide help for a key within FOR-GROUP The user is prompted for the key." (let* ((opts (makey-key-mode-options-for-group for-group)) (man-page (cadr (assoc 'man-page opts))) (seq (read-key-sequence (format "Enter command prefix%s: " (if man-page (format ", `?' for man `%s'" man-page) "")))) (actions (makey-get-actions (makey-key-mode-options-for-group for-group)))) (cond ;; if it is an action popup the help for the to-be-run function ((assoc seq actions) (describe-function (nth 2 (assoc seq actions)))) ;; if there is "?" show a man page if there is one ((equal seq "?") (if man-page (man man-page) (error "No man page associated with `%s'" for-group))) (t (error "No help associated with `%s'" seq))))) (defun makey-key-mode-exec-at-point () "Run action/args/option at point." (interactive) (let ((key (or (get-text-property (point) 'key-group-executor) (error "Nothing at point to do.")))) (call-interactively (lookup-key (current-local-map) key)))) (defun makey-key-mode-jump-to-next-exec () "Jump to the next action/args/option point." (interactive) (let* ((oldp (point)) (old (get-text-property oldp 'key-group-executor)) (p (if (= oldp (point-max)) (point-min) (1+ oldp)))) (while (let ((new (get-text-property p 'key-group-executor))) (and (not (= p oldp)) (or (not new) (eq new old)))) (setq p (if (= p (point-max)) (point-min) (1+ p)))) (goto-char p) (skip-chars-forward " "))) ;;; Keymaps (defvar makey-key-mode-keymaps nil "This will be filled lazily with proper keymaps. These keymaps are created using `define-key' as they're requested.") (defun makey-key-mode-build-keymap (for-group) "Construct a normal looking keymap for the key mode to use. Put it in `makey-key-mode-keymaps' for fast lookup." (let* ((options (makey-key-mode-options-for-group for-group)) (actions (makey-get-actions options)) (switches (cdr (assoc 'switches options))) (lisp-switches (cdr (assoc 'lisp-switches options))) (arguments (cdr (assoc 'arguments options))) (lisp-arguments (cdr (assoc 'lisp-arguments options))) (map (make-sparse-keymap))) (suppress-keymap map 'nodigits) ;; ret dwim ;; (define-key map (kbd "RET") 'makey-key-mode-exec-at-point) ;; tab jumps to the next "button" ;; (define-key map (kbd "TAB") 'makey-key-mode-jump-to-next-exec) ;; all maps should `quit' with `C-g' or `q' (define-key map (kbd "C-g") `(lambda () (interactive) (makey-key-mode-command nil))) (define-key map (kbd "q") `(lambda () (interactive) (makey-key-mode-command nil))) ;; run help (define-key map (kbd "?") `(lambda () (interactive) (makey-key-mode-help ',for-group))) (let ((defkey (lambda (k action) ;; (when (and (lookup-key map (car k)) ;; (not (numberp (lookup-key map (car k))))) ;; (message "Warning: overriding binding for `%s' in %S" ;; (car k) for-group) ;; (ding) ;; (sit-for 2)) (define-key map (kbd (car k)) `(lambda () (interactive) ,action))))) (dolist (k lisp-switches) (funcall defkey k `(makey-key-mode-toggle-lisp-option ',for-group ;; name on-value off-value ',(nth 2 k) ',(nth 3 k) ',(nth 4 k)))) (dolist (k actions) (funcall defkey k `(makey-key-mode-command ',(nth 2 k)))) (dolist (k switches) (funcall defkey k `(makey-key-mode-toggle-option ',for-group ,(nth 2 k)))) (dolist (k lisp-arguments) (funcall defkey k `(makey-key-mode-add-lisp-variable ',for-group ,(nth 2 k) ',(nth 3 k)))) (dolist (k arguments) (funcall defkey k `(makey-key-mode-add-argument ',for-group ,(nth 2 k) ',(nth 3 k))))) (push (cons for-group map) makey-key-mode-keymaps) map)) ;;; Toggling and Running (defvar makey-key-mode-prefix nil "Prefix argument to the command that brought up the key-mode window. For internal use. Used by the command that's eventually invoked.") (defvar makey-key-mode-current-args nil "A hash-table of current argument set.") (defvar makey-key-mode-current-lisp-arguments nil "A hash-table of current lisp variables set. These will get let-bound when an action is called") (defvar makey-key-mode-current-lisp-options nil "Current lisp option set.") (defvar makey-key-mode-current-options nil "Current option set.") (defvar makey-custom-options nil "List of custom options to pass to the command line. Do not customize this (used in the `makey-key-mode' implementation).") (defun makey-key-mode-command (func) (let ((current-prefix-arg (or current-prefix-arg makey-key-mode-prefix)) (makey-custom-options makey-key-mode-current-options)) (maphash (lambda (k v) (push (concat k v) makey-custom-options)) makey-key-mode-current-args) (let ((local-let-cells '()) (current-variables (copy-hash-table makey-key-mode-current-lisp-arguments)) (current-lisp-switches (copy-alist makey-key-mode-current-lisp-options))) (set-window-configuration makey-pre-key-mode-window-conf) (kill-buffer makey-key-mode-last-buffer) (maphash (lambda (k v) (add-to-list 'local-let-cells (list (intern k) v))) current-variables) (dolist (lisp-option current-lisp-switches) (add-to-list 'local-let-cells (list (car lisp-option) (cdr lisp-option)))) (eval `(let* ,local-let-cells (when func (if (stringp func) ;; this adds keymap-style support for ;; self-inserted strings. (call-interactively 'self-insert-command nil [func]) (call-interactively func)))))))) (defun makey-key-mode-add-lisp-variable (for-group lisp-variable-name input-func) (let ((input (funcall input-func (concat lisp-variable-name ": ")))) (puthash lisp-variable-name input makey-key-mode-current-lisp-arguments) (makey-key-mode-redraw for-group))) (defun makey-key-mode-add-argument (for-group arg-name input-func) (let ((input (funcall input-func (concat arg-name ": ")))) (puthash arg-name input makey-key-mode-current-args) (makey-key-mode-redraw for-group))) (defun makey-key-mode-toggle-option (for-group option-name) "Toggles the appearance of OPTION-NAME in `makey-key-mode-current-options'." (if (member option-name makey-key-mode-current-options) (setq makey-key-mode-current-options (delete option-name makey-key-mode-current-options)) (add-to-list 'makey-key-mode-current-options option-name)) (makey-key-mode-redraw for-group)) (defun makey-key-mode-toggle-lisp-option (for-group option-name option-value-on option-value-off) "Toggles the appearance of OPTION-NAME in `makey-key-mode-current-lisp-options'. Toggles between OPTION-VALUE-ON and OPTION-VALUE-OFF" (if (cdr (assoc option-name makey-key-mode-current-lisp-options)) (progn (setq makey-key-mode-current-lisp-options (assq-delete-all option-name makey-key-mode-current-lisp-options)) (add-to-list 'makey-key-mode-current-lisp-options (cons option-name option-value-off))) (add-to-list 'makey-key-mode-current-lisp-options (cons option-name option-value-on))) (makey-key-mode-redraw for-group)) ;;; Mode (defvar makey-key-mode-buf-name "*makey-key: %s*" "Format string to create the name of the makey-key buffer.") (defvar makey-key-mode-last-buffer nil "Store the last makey-key buffer used.") (defvar makey-pre-key-mode-window-conf nil "Will hold the pre-menu configuration of makey.") (defun makey-key-mode (for-group &optional original-opts) "Mode for makey key selection. All commands, switches and options can be toggled/actioned with the key combination highlighted before the description." (interactive) ;; save the window config to restore it as was (no need to make this ;; buffer local) (setq makey-pre-key-mode-window-conf (current-window-configuration)) ;; setup the mode, draw the buffer (let ((buf (get-buffer-create (format makey-key-mode-buf-name (symbol-name for-group))))) (setq makey-key-mode-last-buffer buf) (split-window-vertically) (other-window 1) (switch-to-buffer buf) (kill-all-local-variables) (set (make-local-variable 'scroll-margin) 0) (set (make-local-variable 'makey-key-mode-current-options) original-opts) (set (make-local-variable 'makey-key-mode-current-lisp-options) original-opts) (set (make-local-variable 'makey-key-mode-current-args) (make-hash-table)) (set (make-local-variable 'makey-key-mode-current-lisp-arguments) (make-hash-table)) (set (make-local-variable 'makey-key-mode-prefix) current-prefix-arg) (makey-key-mode-redraw for-group)) (when makey-key-mode-show-usage (message (concat "Type a prefix key to toggle it. " "Run 'actions' with their prefixes. " "'?' for more help.")))) (defun makey-key-mode-get-key-map (for-group) "Get or build the keymap for FOR-GROUP." (or (cdr (assoc for-group makey-key-mode-keymaps)) (makey-key-mode-build-keymap for-group))) (defun makey-key-mode-redraw (for-group) "(re)draw the makey key buffer." (let ((buffer-read-only nil) (current-exec (get-text-property (point) 'key-group-executor)) (new-exec-pos) (old-point (point)) (is-first (zerop (buffer-size))) (actions-p nil)) (erase-buffer) (make-local-variable 'font-lock-defaults) (use-local-map (makey-key-mode-get-key-map for-group)) (setq actions-p (makey-key-mode-draw for-group)) (delete-trailing-whitespace) (setq mode-name "makey-key-mode" major-mode 'makey-key-mode) (when current-exec (setq new-exec-pos (cdr (assoc current-exec (makey-key-mode-build-exec-point-alist))))) (cond ((and is-first actions-p) (goto-char actions-p) (makey-key-mode-jump-to-next-exec)) (new-exec-pos (goto-char new-exec-pos) (skip-chars-forward " ")) (t (goto-char old-point)))) (setq buffer-read-only t) (fit-window-to-buffer)) (defun makey-key-mode-build-exec-point-alist () (save-excursion (goto-char (point-min)) (let* ((exec (get-text-property (point) 'key-group-executor)) (exec-alist (and exec `((,exec . ,(point)))))) (cl-do nil ((eobp) (nreverse exec-alist)) (when (not (eq exec (get-text-property (point) 'key-group-executor))) (setq exec (get-text-property (point) 'key-group-executor)) (when exec (push (cons exec (point)) exec-alist))) (forward-char))))) ;;; Draw Buffer (defun makey-key-mode-draw-header (header) "Draw a header with the correct face." (insert (propertize header 'face 'makey-key-mode-header-face) "\n")) (defvar makey-key-mode-args-in-cols nil "When true, draw arguments in columns as with switches and options.") (defun makey-key-mode-draw-args (args hash-table) "Draw the args part of the menu." (makey-key-mode-draw-buttons "Args" args (lambda (x) (let* ((arg (nth 2 x)) (value (gethash arg hash-table ""))) (format "(%s) %s" arg (propertize (if (numberp value) (int-to-string value) value) 'face 'makey-key-mode-args-face)))) (not makey-key-mode-args-in-cols))) (defun makey-key-mode-draw-switches (switches switch-variable) "Draw the switches part of the menu." (makey-key-mode-draw-buttons "Switches" switches (lambda (x) (format "(%s)" (let* ((sym (nth 2 x)) (s (if (symbolp sym) (symbol-name sym) sym))) (if (cdr (assoc sym switch-variable)) (propertize s 'face 'makey-key-mode-switch-face) s)))))) (defun makey-key-mode-draw-actions (header actions) "Draw the actions part of the menu." (makey-key-mode-draw-buttons (format "%s Actions" header) actions nil)) (defun makey-key-mode-draw-buttons (section xs maker &optional one-col-each) (when xs (makey-key-mode-draw-header section) (makey-key-mode-draw-in-cols (mapcar (lambda (x) (let* ((head (propertize (car x) 'face 'makey-key-mode-button-face)) (desc (nth 1 x)) (more (and maker (funcall maker x))) (text (format " %s: %s%s%s" head desc (if more " " "") (or more "")))) (propertize text 'key-group-executor (car x)))) xs) one-col-each))) (defun makey-key-mode-draw-in-cols (strings one-col-each) "Given a list of strings, print in columns (using `insert'). If ONE-COL-EACH is true then don't columify, but rather, draw each item on one line." (let ((longest-act (apply 'max (mapcar 'length strings)))) (while strings (let ((str (car strings))) (let ((padding (make-string (- (+ longest-act 3) (length str)) ? ))) (insert str) (if (or one-col-each (and (> (+ (length padding) ; (current-column) longest-act) (window-width)) (cdr strings))) (insert "\n") (insert padding)))) (setq strings (cdr strings)))) (insert "\n")) (defun makey-get-actions (for-group) "Returns a list of actions in FOR-GROUP" (cl-loop for sub-group in (cdr (assoc 'actions for-group)) append (cdr sub-group) into action-items finally return action-items)) (defun makey-key-mode-draw (for-group) "Draw actions, switches and parameters. Return the point before the actions part, if any, nil otherwise." (let* ((options (makey-key-mode-options-for-group for-group)) (switches (cdr (assoc 'switches options))) (lisp-switches (cdr (assoc 'lisp-switches options))) (arguments (cdr (assoc 'arguments options))) (lisp-arguments (cdr (assoc 'lisp-arguments options))) (description (cdr (assoc 'description options))) (actions (cdr (assoc 'actions options))) (p nil)) (makey-key-mode-draw-switches switches makey-key-mode-current-options) (makey-key-mode-draw-switches lisp-switches makey-key-mode-current-lisp-options) (makey-key-mode-draw-args arguments makey-key-mode-current-args) (makey-key-mode-draw-args lisp-arguments makey-key-mode-current-lisp-arguments) (when actions (setq p (point-marker))) (dolist (action actions) (makey-key-mode-draw-actions (car action) (cdr action))) (setq header-line-format description) (insert "\n") p)) ;;; Generate Groups (defun makey-key-mode-de-generate (group) "Unbind the function for GROUP." (fmakunbound (intern (concat "makey-key-mode-popup-" (symbol-name group))))) (defun makey-key-mode-generate (group-name group-details) "Generate the key-group-name menu for GROUP." (let* ((opts group-details) (lisp-variable-alist)) (list (dolist (switch (cdr (assoc 'lisp-switches group-details))) (add-to-list 'lisp-variable-alist (cons (nth 2 switch) (symbol-value (nth 2 switch)))))) (eval `(defun ,(intern (concat "makey-key-mode-options-for-" (symbol-name group-name))) nil ,(concat "Options menu helper function for " (symbol-name group-name)) ',group-details)) (eval `(defun ,(intern (concat "makey-key-mode-popup-" (symbol-name group-name))) nil ,(concat "Key menu for " (symbol-name group-name)) (interactive) (makey-key-mode (quote ,group-name) ',lisp-variable-alist))))) ;;;###autoload (defun makey-initialize-key-groups (key-group) "Initializes KEY-GROUP and creates all the relevant interactive commands." (setq makey-key-mode-keymaps nil) (mapc (lambda (g) (makey-key-mode-generate (car g) (cdr g))) key-group)) ;;;;###autoload (mapc (lambda (g) (eval `(autoload ',(intern (concat "makey-key-mode-popup-" (symbol-name (car g)))) "makey-key-mode" ,(concat "Key menu for " (symbol-name (car g))) t))) makey-key-mode-groups) (provide 'makey) ;; Local Variables: ;; indent-tabs-mode: nil ;; End: ;;; makey.el ends here