X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/843bc709a31691e8049ccb1e75d87514f42c9c99..2eddb832a0a737e78b33525bdf18629ec62933ff:/hydra.el diff --git a/hydra.el b/hydra.el index 1049bfb26..5ea464096 100644 --- a/hydra.el +++ b/hydra.el @@ -5,7 +5,7 @@ ;; Author: Oleh Krehel ;; Maintainer: Oleh Krehel ;; URL: https://github.com/abo-abo/hydra -;; Version: 0.7.0 +;; Version: 0.10.0 ;; Keywords: bindings ;; Package-Requires: ((cl-lib "0.5")) @@ -37,37 +37,65 @@ ;; command. This makes the Hydra very seamless, it's like a minor ;; mode that disables itself automagically. ;; -;; Here's how to use the examples bundled with Hydra: +;; Here's an example Hydra, bound in the global map (you can use any +;; keymap in place of `global-map'): ;; -;; (require 'hydra-examples) -;; (hydra-create "C-M-y" hydra-example-move-window-splitter) -;; (hydra-create "M-g" hydra-example-goto-error) +;; (defhydra hydra-zoom (global-map "") +;; "zoom" +;; ("g" text-scale-increase "in") +;; ("l" text-scale-decrease "out")) ;; -;; You can expand the examples in-place, it still looks elegant: +;; It allows to start a command chain either like this: +;; " gg4ll5g", or " lgllg". ;; -;; (hydra-create "" -;; '(("g" text-scale-increase "zoom in") -;; ("l" text-scale-decrease "zoom out"))) +;; Here's another approach, when you just want a "callable keymap": ;; -;; The third element of each list is the optional doc string that will -;; be displayed in the echo area when `hydra-is-helpful' is t. +;; (defhydra hydra-toggle (:color blue) +;; "toggle" +;; ("a" abbrev-mode "abbrev") +;; ("d" toggle-debug-on-error "debug") +;; ("f" auto-fill-mode "fill") +;; ("t" toggle-truncate-lines "truncate") +;; ("w" whitespace-mode "whitespace") +;; ("q" nil "cancel")) ;; -;; It's better to take the examples simply as templates and use -;; `defhydra' instead of `hydra-create', since it's more flexible. +;; This binds nothing so far, but if you follow up with: ;; -;; (defhydra hydra-zoom (global-map "") -;; "zoom" -;; ("g" text-scale-increase "in") -;; ("l" text-scale-decrease "out")) +;; (global-set-key (kbd "C-c C-v") 'hydra-toggle/body) +;; +;; you will have bound "C-c C-v a", "C-c C-v d" etc. +;; +;; Knowing that `defhydra' defines e.g. `hydra-toggle/body' command, +;; you can nest Hydras if you wish, with `hydra-toggle/body' possibly +;; becoming a blue head of another Hydra. +;; +;; Initially, Hydra shipped with a simplified `hydra-create' macro, to +;; which you could hook up the examples from hydra-examples.el. It's +;; better to take the examples simply as templates and use `defhydra' +;; instead of `hydra-create', since it's more flexible. ;;; Code: ;;* Requires (require 'cl-lib) +(require 'lv) (defalias 'hydra-set-transient-map - (if (fboundp 'set-transient-map) - 'set-transient-map - 'set-temporary-overlay-map)) + (if (fboundp 'set-transient-map) + 'set-transient-map + (lambda (map keep-pred &optional on-exit) + (set-temporary-overlay-map map (hydra--pred on-exit))))) + +(defun hydra--pred (on-exit) + "Generate a predicate on whether to continue the Hydra state. +Call ON-EXIT for clean-up. +This is a compatibility code for Emacs older than 24.4." + `(lambda () + (if (lookup-key hydra-curr-map (this-command-keys-vector)) + t + (hydra-cleanup) + ,(when on-exit + `(funcall ,(hydra--make-callable on-exit))) + nil))) ;;* Customize (defgroup hydra nil @@ -80,18 +108,50 @@ :type 'boolean :group 'hydra) +(defcustom hydra-keyboard-quit "" + "This binding will quit an amaranth Hydra. +It's the only other way to quit it besides though a blue head. +It's possible to set this to nil.") + +(defcustom hydra-lv t + "When non-nil, `lv-message' (not `message') will be used to display hints." + :type 'boolean) + (defface hydra-face-red - '((t (:foreground "#7F0055" :bold t))) + '((t (:foreground "#FF0000" :bold t))) "Red Hydra heads will persist indefinitely." :group 'hydra) (defface hydra-face-blue - '((t (:foreground "#758BC6" :bold t))) + '((t (:foreground "#0000FF" :bold t))) "Blue Hydra heads will vanquish the Hydra.") (defface hydra-face-amaranth '((t (:foreground "#E52B50" :bold t))) - "Amaranth Hydra can exit only through a blue head.") + "Amaranth body has red heads and warns on intercepting non-heads. +Vanquishable only through a blue head.") + +(defface hydra-face-pink + '((t (:foreground "#FF6EB4" :bold t))) + "Pink body has red heads and on intercepting non-heads calls them without quitting. +Vanquishable only through a blue head.") + +(defface hydra-face-teal + '((t (:foreground "#367588" :bold t))) + "Teal body has blue heads an warns on intercepting non-heads. +Vanquishable only through a blue head.") + +;;* Fontification +(defun hydra-add-font-lock () + "Fontify `defhydra' statements." + (font-lock-add-keywords + 'emacs-lisp-mode + '(("(\\(defhydra\\)\\_> +\\(.*?\\)\\_>" + (1 font-lock-keyword-face) + (2 font-lock-type-face)) + ("(\\(defhydradio\\)\\_> +\\(.*?\\)\\_>" + (1 font-lock-keyword-face) + (2 font-lock-type-face))))) ;;* Universal Argument (defvar hydra-base-map @@ -158,38 +218,77 @@ (and (consp x) (memq (car x) '(function quote))))) -(defun hydra--color (h body-color) - "Return the color of a Hydra head H with BODY-COLOR." - (if (null (cadr h)) - 'blue - (let ((plist (if (stringp (cl-caddr h)) - (cl-cdddr h) - (cddr h)))) - (or (plist-get plist :color) body-color)))) - -(defun hydra--face (h body-color) - "Return the face for a Hydra head H with BODY-COLOR." - (cl-case (hydra--color h body-color) +(defun hydra--make-callable (x) + "Generate a callable symbol from X. +If X is a function symbol or a lambda, return it. Otherwise, it +should be a single statement. Wrap it in an interactive lambda." + (if (or (symbolp x) (functionp x)) + x + `(lambda () + (interactive) + ,x))) + +(defun hydra--head-property (h prop &optional default) + "Return for Hydra head H the value of property PROP. +Return DEFAULT if PROP is not in H." + (let ((plist (if (or (stringp (cl-caddr h)) + (null (cl-caddr h))) + (cl-cdddr h) + (cddr h)))) + (if (memq prop h) + (plist-get plist prop) + default))) + +(defun hydra--head-color (h body) + "Return the color of a Hydra head H with BODY." + (let ((color (hydra--head-property h :color)) + (exit (or (plist-get (cddr body) :exit) + (hydra--head-property h :exit 'default))) + (nonheads (plist-get (cddr body) :nonheads))) + (cond ((null (cadr h)) + 'blue) + ((eq exit t) + 'blue) + ((eq nonheads 'run) + 'pink) + ((eq nonheads 'warn) + (if (eq exit t) + 'teal + 'amaranth)) + ((null color) + (hydra--body-color body)) + (t + color)))) + +(defun hydra--body-color (body) + "Return the color of BODY. +BODY is the second argument to `defhydra'" + (let ((color (plist-get (cddr body) :color)) + (exit (plist-get (cddr body) :exit)) + (nonheads (plist-get (cddr body) :nonheads))) + (cond ((eq nonheads 'warn) + (if exit 'teal 'amaranth)) + ((eq nonheads 'run) 'pink) + (exit 'blue) + (color color) + (t 'red)))) + +(defun hydra--face (h body) + "Return the face for a Hydra head H with BODY." + (cl-case (hydra--head-color h body) (blue 'hydra-face-blue) (red 'hydra-face-red) (amaranth 'hydra-face-amaranth) + (pink 'hydra-face-pink) + (teal 'hydra-face-teal) (t (error "Unknown color for %S" h)))) -(defun hydra--hint (docstring heads body-color) - "Generate a hint from DOCSTRING and HEADS and BODY-COLOR. -It's intended for the echo area, when a Hydra is active." - (format "%s: %s." - docstring - (mapconcat - (lambda (h) - (format - (if (stringp (cl-caddr h)) - (concat "[%s]: " (cl-caddr h)) - "%s") - (propertize - (car h) 'face - (hydra--face h body-color)))) - heads ", "))) +(defun hydra-cleanup () + "Clean up after a Hydra." + (when (window-live-p lv-wnd) + (let ((buf (window-buffer lv-wnd))) + (delete-window lv-wnd) + (kill-buffer buf)))) (defun hydra-disable () "Disable the current Hydra." @@ -198,17 +297,115 @@ It's intended for the echo area, when a Hydra is active." ((functionp hydra-last) (funcall hydra-last)) - ;; Emacs 24.4.1 - ((boundp 'overriding-terminal-local-map) - (setq overriding-terminal-local-map nil)) + ;; Emacs 24.3 or older + ((< emacs-minor-version 4) + (setq emulation-mode-map-alists + (cl-remove-if + (lambda (x) + (and (consp x) + (consp (car x)) + (equal (cdar x) hydra-curr-map))) + emulation-mode-map-alists))) - ;; older + ;; Emacs 24.4.1 (t - (while (and (consp (car emulation-mode-map-alists)) - (consp (caar emulation-mode-map-alists)) - (equal (cl-cdaar emulation-mode-map-alists) ',keymap)) - (setq emulation-mode-map-alists - (cdr emulation-mode-map-alists)))))) + (setq overriding-terminal-local-map nil)))) + +(defun hydra--unalias-var (str prefix) + "Return the symbol named STR if it's bound as a variable. +Otherwise, add PREFIX to the symbol name." + (let ((sym (intern-soft str))) + (if (boundp sym) + sym + (intern (concat prefix "/" str))))) + +(defun hydra--hint (name body docstring heads) + "Generate a hint for the echo area. +NAME, BODY, DOCSTRING and HEADS are parameters to `defhydra'." + (let (alist) + (dolist (h heads) + (let ((val (assoc (cadr h) alist)) + (pstr (hydra-fontify-head h body))) + (unless (and (> (length h) 2) + (null (cl-caddr h))) + (if val + (setf (cadr val) + (concat (cadr val) " " pstr)) + (push + (cons (cadr h) + (cons pstr + (and (stringp (cl-caddr h)) (cl-caddr h)))) + alist))))) + (mapconcat + (lambda (x) + (format + (if (cdr x) + (concat "[%s]: " (cdr x)) + "%s") + (car x))) + (nreverse (mapcar #'cdr alist)) + ", "))) + +(defvar hydra-fontify-head-function nil + "Possible replacement for `hydra-fontify-head-default'.") + +(defun hydra-fontify-head-default (head body) + "Produce a pretty string from HEAD and BODY. +HEAD's binding is returned as a string with a colored face." + (propertize (car head) 'face (hydra--face head body))) + +(defun hydra-fontify-head-greyscale (head body) + "Produce a pretty string from HEAD and BODY. +HEAD's binding is returned as a string wrapped with [] or {}." + (let ((color (hydra--head-color head body))) + (format + (if (eq color 'blue) + "[%s]" + "{%s}") (car head)))) + +(defun hydra-fontify-head (head body) + "Produce a pretty string from HEAD and BODY." + (funcall (or hydra-fontify-head-function 'hydra-fontify-head-default) + head body)) + +(defun hydra--format (name body docstring heads) + "Generate a `format' statement from STR. +\"%`...\" expressions are extracted into \"%S\". +NAME, BODY, DOCSTRING and HEADS are parameters of `defhydra'. +The expressions can be auto-expanded according to NAME." + (setq docstring (replace-regexp-in-string "\\^" "" docstring)) + (let ((rest (hydra--hint name body docstring heads)) + (body-color (hydra--body-color body)) + (prefix (symbol-name name)) + (start 0) + varlist) + (while (setq start + (string-match + "\\(?:%\\( ?-?[0-9]*\\)`\\([a-z-A-Z/0-9]+\\)\\)\\|\\(?:_\\([a-z-~A-Z]+\\)_\\)" + docstring start)) + (if (eq ?_ (aref (match-string 0 docstring) 0)) + (let* ((key (match-string 3 docstring)) + (head (assoc key heads))) + (if head + (progn + (push (hydra-fontify-head head body) varlist) + (setq docstring (replace-match "% 3s" nil nil docstring))) + (error "Unrecognized key: _%s_" key))) + (push (hydra--unalias-var (match-string 2 docstring) prefix) varlist) + (setq docstring (replace-match (concat "%" (match-string 1 docstring) "S") nil nil docstring 0)))) + (if (eq ?\n (aref docstring 0)) + `(concat (format ,docstring ,@(nreverse varlist)) + ,rest) + `(format ,(concat docstring ": " rest "."))))) + +(defun hydra--message (name body docstring heads) + "Generate code to display the hint in the preferred echo area. +Set `hydra-lv' to choose the echo area. +NAME, BODY, DOCSTRING, and HEADS are parameters of `defhydra'." + (let ((format-expr (hydra--format name body docstring heads))) + `(if hydra-lv + (lv-message ,format-expr) + (message ,format-expr)))) (defun hydra--doc (body-key body-name heads) "Generate a part of Hydra docstring. @@ -226,62 +423,152 @@ HEADS is a list of heads." heads ",\n") (format "The body can be accessed via `%S'." body-name))) -;;* Macros -;;** hydra-create -;;;###autoload -(defmacro hydra-create (body heads &optional method) - "Create a hydra with a BODY prefix and HEADS with METHOD. -This will result in `global-set-key' statements with the keys -being the concatenation of BODY and each head in HEADS. HEADS is -an list of (KEY FUNCTION &optional HINT). - -After one of the HEADS is called via BODY+KEY, it and the other -HEADS can be called with only KEY (no need for BODY). This state -is broken once any key binding that is not in HEADS is called. - -METHOD is a lambda takes two arguments: a KEY and a COMMAND. -It defaults to `global-set-key'. -When `(keymapp METHOD)`, it becomes: - - (lambda (key command) (define-key METHOD key command))" - (declare (indent 1)) - `(defhydra ,(intern - (concat - "hydra-" (replace-regexp-in-string " " "_" body))) - ,(cond ((hydra--callablep method) - method) - ((null method) - `(global-map ,body)) - (t - (list method body))) - "hydra" - ,@(eval heads))) +(defun hydra--make-defun (name cmd color + doc hint keymap + body-color body-pre body-post &optional other-post) + "Make a defun wrapper, using NAME, CMD, COLOR, DOC, HINT, and KEYMAP. +BODY-COLOR, BODY-PRE, BODY-POST, and OTHER-POST are used as well." + `(defun ,name () + ,doc + (interactive) + ,@(when body-pre (list body-pre)) + (hydra-disable) + ,@(when (memq color '(blue teal)) '((hydra-cleanup))) + (catch 'hydra-disable + ,@(delq nil + (if (memq color '(blue teal)) + `(,(when cmd `(call-interactively #',cmd)) + ,body-post) + `(,(when cmd + `(condition-case err + (prog1 t + (call-interactively #',cmd)) + ((quit error) + (message "%S" err) + (unless hydra-lv + (sit-for 0.8)) + nil))) + (when hydra-is-helpful + (,hint)) + (setq hydra-last + (hydra-set-transient-map + (setq hydra-curr-map ',keymap) + t + ,(if (and (not (memq body-color '(amaranth pink teal))) body-post) + `(lambda () (hydra-cleanup) ,body-post) + `(lambda () (hydra-cleanup))))) + ,other-post)))))) + +(defun hydra-pink-fallback () + "On intercepting a non-head, try to run it." + (let ((keys (this-command-keys)) + kb) + (when (equal keys [backspace]) + (setq keys "")) + (setq kb (key-binding keys)) + (if kb + (if (commandp kb) + (condition-case err + (call-interactively kb) + ((quit error) + (message "%S" err) + (unless hydra-lv + (sit-for 0.8)))) + (message "Pink Hydra can't currently handle prefixes, continuing")) + (message "Pink Hydra could not resolve: %S" keys)))) + +(defun hydra--handle-nonhead (keymap name body heads) + "Setup KEYMAP for intercepting non-head bindings. +NAME, BODY and HEADS are parameters to `defhydra'." + (let ((body-color (hydra--body-color body)) + (body-post (plist-get (cddr body) :post))) + (when (and body-post (symbolp body-post)) + (setq body-post `(funcall #',body-post))) + (when (memq body-color '(amaranth pink teal)) + (if (cl-some `(lambda (h) + (eq (hydra--head-color h body) 'blue)) + heads) + (progn + (define-key keymap [t] + `(lambda () + (interactive) + ,(cond + ((eq body-color 'amaranth) + '(message "An amaranth Hydra can only exit through a blue head")) + ((eq body-color 'teal) + '(message "A teal Hydra can only exit through a blue head")) + (t + '(hydra-pink-fallback))) + (hydra-set-transient-map hydra-curr-map t) + (when hydra-is-helpful + (unless hydra-lv + (sit-for 0.8)) + (,(intern (format "%S/hint" name))))))) + (error + "An %S Hydra must have at least one blue head in order to exit" + body-color)) + (when hydra-keyboard-quit + (define-key keymap hydra-keyboard-quit + `(lambda () + (interactive) + (hydra-disable) + (hydra-cleanup) + ,body-post)))))) +;;* Macros ;;** defhydra ;;;###autoload (defmacro defhydra (name body &optional docstring &rest heads) - "Create a hydra named NAME with a prefix BODY. + "Create a Hydra - a family of functions with prefix NAME. NAME should be a symbol, it will be the prefix of all functions defined here. -BODY should be either: +BODY has the format: - (BODY-MAP &optional BODY-KEY &rest PLIST) -or: - - (lambda (KEY CMD) ...) - -BODY-MAP should be a keymap; `global-map' is acceptable here. -BODY-KEY should be a string processable by `kbd'. + (BODY-MAP BODY-KEY &rest PLIST) DOCSTRING will be displayed in the echo area to identify the -hydra. - -HEADS is a list of (KEY CMD &optional HINT &rest PLIST). - -PLIST in both cases recognizes only the :color key so far, which -in turn can be either red or blue." +Hydra. + +Functions are created on basis of HEADS, each of which has the +format: + + (KEY CMD &optional HINT &rest PLIST) + +BODY-MAP is a keymap; `global-map' is used quite often. Each +function generated from HEADS will be bound in BODY-MAP to +BODY-KEY + KEY (both are strings passed to `kbd'), and will set +the transient map so that all following heads can be called +though KEY only. + +CMD is a callable expression: either an interactive function +name, or an interactive lambda, or a single sexp (it will be +wrapped in an interactive lambda). + +HINT is a short string that identifies its head. It will be +printed beside KEY in the echo erea if `hydra-is-helpful' is not +nil. If you don't even want the KEY to be printed, set HINT +explicitly to nil. + +The heads inherit their PLIST from the body and are allowed to +override each key. The keys recognized are :color and :bind. +:color can be: + +- red (default): this head will continue the Hydra state. +- blue: this head will stop the Hydra state. +- amaranth (applies to body only): similar to red, but no binding +except a blue head can stop the Hydra state. + +:bind can be: +- nil: this head will not be bound in BODY-MAP. +- a lambda taking KEY and CMD used to bind a head + +It is possible to omit both BODY-MAP and BODY-KEY if you don't +want to bind anything. In that case, typically you will bind the +generated NAME/body command. This command is also the return +result of `defhydra'." + (declare (indent defun)) (unless (stringp docstring) (setq heads (cons docstring heads)) (setq docstring "hydra")) @@ -297,63 +584,29 @@ in turn can be either red or blue." (concat "lambda-" (car x))))))) heads)) (body-name (intern (format "%S/body" name))) + (hint-name (intern (format "%S/hint" name))) (body-key (unless (hydra--callablep body) (cadr body))) - (body-color (if (hydra--callablep body) - 'red - (or (plist-get (cddr body) :color) - 'red))) + (body-color (hydra--body-color body)) (body-pre (plist-get (cddr body) :pre)) (body-post (plist-get (cddr body) :post)) - (method (if (hydra--callablep body) - body - (car body))) - (hint (hydra--hint docstring heads body-color)) + (method (or (plist-get body :bind) + (car body))) (doc (hydra--doc body-key body-name heads))) - (when (and (or body-pre body-post) - (version< emacs-version "24.4")) - (error "At least Emacs 24.4 is needed for :pre and :post")) - (when (eq body-color 'amaranth) - (if (cl-some `(lambda (h) - (eq (hydra--color h ',body-color) 'blue)) - heads) - (define-key keymap [t] - `(lambda () - (interactive) - (message "An amaranth Hydra can only exit through a blue head") - (hydra-set-transient-map hydra-curr-map t) - (when hydra-is-helpful - (sit-for 0.8) - (message ,hint)))) - (error "An amaranth Hydra must have at least one blue head in order to exit"))) + (when (and body-pre (symbolp body-pre)) + (setq body-pre `(funcall #',body-pre))) + (when (and body-post (symbolp body-post)) + (setq body-post `(funcall #',body-post))) + (hydra--handle-nonhead keymap name body heads) `(progn ,@(cl-mapcar (lambda (head name) - `(defun ,name () - ,(format "%s\n\nCall the head: `%S'." doc (cadr head)) - (interactive) - ,@(if body-pre (list body-pre)) - ,@(if (eq (hydra--color head body-color) 'blue) - `((hydra-disable) - ,@(unless (null (cadr head)) - `((call-interactively #',(cadr head)))) - ,@(if body-post (list body-post))) - `((catch 'hydra-disable - (hydra-disable) - (condition-case err - (prog1 t - (call-interactively #',(cadr head))) - ((debug error) - (message "%S" err) - (sit-for 0.8) - nil)) - (when hydra-is-helpful - (message ,hint)) - (setq hydra-last - (hydra-set-transient-map - (setq hydra-curr-map ',keymap) - t - ,@(if body-post `((lambda () ,body-post)))))))))) + (hydra--make-defun + name (hydra--make-callable + (cadr head)) (hydra--head-color head body) + (format "%s\n\nCall the head: `%S'." doc (cadr head)) + hint-name keymap + body-color body-pre body-post)) heads names) ,@(unless (or (null body-key) (null method) @@ -363,26 +616,105 @@ in turn can be either red or blue." ,@(delq nil (cl-mapcar (lambda (head name) - (unless (or (null body-key) (null method)) - (list - (if (hydra--callablep method) - 'funcall - 'define-key) - method - (vconcat (kbd body-key) (kbd (car head))) - (list 'function name)))) + (when (or body-key method) + (let ((bind (hydra--head-property head :bind 'default)) + (final-key + (if body-key + (vconcat (kbd body-key) (kbd (car head))) + (kbd (car head))))) + (cond ((null bind) nil) + + ((eq bind 'default) + (list + (if (hydra--callablep method) + 'funcall + 'define-key) + method + final-key + (list 'function name))) + + ((hydra--callablep bind) + `(funcall (function ,bind) + ,final-key + (function ,name))) + + (t + (error "Invalid :bind property %S" head)))))) heads names)) - (defun ,body-name () - ,doc - (interactive) - ,@(if body-pre (list body-pre)) - (when hydra-is-helpful - (message ,hint)) - (setq hydra-last - (hydra-set-transient-map - ',keymap - t - ,@(if body-post `((lambda () ,body-post))))))))) + (defun ,hint-name () + ,(hydra--message name body docstring heads)) + ,(hydra--make-defun body-name nil nil doc hint-name keymap + body-color body-pre body-post + '(setq prefix-arg current-prefix-arg))))) + +(defmacro defhydradio (name body &rest heads) + "Create radios with prefix NAME. +BODY specifies the options; there are none currently. +HEADS have the format: + + (TOGGLE-NAME &optional VALUE DOC) + +TOGGLE-NAME will be used along with NAME to generate a variable +name and a function that cycles it with the same name. VALUE +should be an array. The first element of VALUE will be used to +inialize the variable. +VALUE defaults to [nil t]. +DOC defaults to TOGGLE-NAME split and capitalized." + (declare (indent defun)) + `(progn + ,@(apply #'append + (mapcar (lambda (h) + (hydra--radio name h)) + heads)) + (defun ,(intern (format "%S/reset-radios" name)) () + ,@(mapcar + (lambda (h) + (let ((full-name (intern (format "%S/%S" name (car h)))) + ) + `(setq ,full-name ,(hydra--quote-maybe + (and (cadr h) (aref (cadr h) 0)))))) + heads)))) + +(defun hydra--radio (parent head) + "Generate a hydradio with PARENT from HEAD." + (let* ((name (car head)) + (full-name (intern (format "%S/%S" parent name))) + (val (or (cadr head) [nil t])) + (doc (or (cl-caddr head) + (mapconcat #'capitalize + (split-string (symbol-name name) "-") + " ")))) + `((defvar ,full-name ,(hydra--quote-maybe (aref val 0)) ,doc) + (put ',full-name 'range ,val) + (defun ,full-name () + (hydra--cycle-radio ',full-name))))) + +(defun hydra--quote-maybe (x) + "Quote X if it's a symbol." + (cond ((null x) + nil) + ((symbolp x) + (list 'quote x)) + (t + x))) + +(defun hydra--cycle-radio (sym) + "Set SYM to the next value in its range." + (let* ((val (symbol-value sym)) + (range (get sym 'range)) + (i 0) + (l (length range))) + (setq i (catch 'done + (while (< i l) + (if (equal (aref range i) val) + (throw 'done (1+ i)) + (incf i))) + (error "Val not in range for %S" sym))) + (set sym + (aref range + (if (>= i l) + 0 + i))))) (provide 'hydra)