+(defun hydra--make-defun (name body doc head
+ keymap body-pre body-post &optional other-post)
+ "Make a defun wrapper, using NAME, BODY, DOC, HEAD, and KEYMAP.
+NAME and BODY are the arguments to `defhydra'.
+DOC was generated with `hydra--doc'.
+HEAD is one of the HEADS passed to `defhydra'.
+BODY-PRE and BODY-POST are pre-processed in `defhydra'.
+OTHER-POST is an optional extension to the :post key of BODY."
+ (let ((name (hydra--head-name head name body))
+ (cmd (when (car head)
+ (hydra--make-callable
+ (cadr head))))
+ (color (when (car head)
+ (hydra--head-color head body)))
+ (doc (if (car head)
+ (format "%s\n\nCall the head: `%S'." doc (cadr head))
+ doc))
+ (hint (intern (format "%S/hint" name)))
+ (body-color (hydra--body-color body))
+ (body-timeout (plist-get body :timeout)))
+ `(defun ,name ()
+ ,doc
+ (interactive)
+ (hydra-default-pre)
+ ,@(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)))))
+ ,(or other-post
+ (when body-timeout
+ (list 'hydra-timeout
+ body-timeout
+ (when body-post
+ (hydra--make-callable body-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 "\7f"))
+ (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--modify-keymap (keymap def)
+ "In KEYMAP, add DEF to each sub-keymap."
+ (cl-labels
+ ((recur (map)
+ (if (atom map)
+ map
+ (if (eq (car map) 'keymap)
+ (cons 'keymap
+ (cons
+ def
+ (recur (cdr map))))
+ (cons
+ (recur (car map))
+ (recur (cdr map)))))))
+ (recur keymap)))
+
+(defmacro hydra--make-funcall (sym)
+ "Transform SYM into a `funcall' that calls it."
+ `(when (and ,sym (symbolp ,sym))
+ (setq ,sym `(funcall #',,sym))))
+
+(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)))
+ (if body-post
+ (hydra--make-funcall body-post)
+ (when hydra-keyboard-quit
+ (define-key keymap hydra-keyboard-quit #'hydra-keyboard-quit)))
+ (when (memq body-color '(amaranth pink teal))
+ (if (cl-some (lambda (h)
+ (memq (hydra--head-color h body) '(blue teal)))
+ heads)
+ (progn
+ (setcdr
+ keymap
+ (cdr
+ (hydra--modify-keymap
+ keymap
+ (cons t
+ `(lambda ()
+ (interactive)
+ ,(cond
+ ((memq body-color '(amaranth teal))
+ '(message "An amaranth 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))))))))))
+ (unless (eq body-color 'teal)
+ (error
+ "An %S Hydra must have at least one blue head in order to exit"
+ body-color))))))
+
+(defun hydra--head-name (h name body)
+ "Return the symbol for head H of hydra with NAME and BODY."
+ (let ((str (format "%S/%s" name
+ (if (symbolp (cadr h))
+ (cadr h)
+ (concat "lambda-" (car h))))))
+ (when (and (memq (hydra--head-color h body) '(blue teal))
+ (not (memq (cadr h) '(body nil))))
+ (setq str (concat str "-and-exit")))
+ (intern str)))
+
+(defun hydra--delete-duplicates (heads)
+ "Return HEADS without entries that have the same CMD part.
+In duplicate HEADS, :cmd-name is modified to whatever they duplicate."
+ (let ((ali '(((hydra-repeat . red) . hydra-repeat)))
+ res entry)
+ (dolist (h heads)
+ (if (setq entry (assoc (cons (cadr h)
+ (hydra--head-color h '(nil nil)))
+ ali))
+ (setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry)))
+ (push (cons (cons (cadr h)
+ (hydra--head-color h '(nil nil)))
+ (plist-get (cl-cdddr h) :cmd-name))
+ ali)
+ (push h res)))
+ (nreverse res)))
+
+(defun hydra--pad (lst n)
+ "Pad LST with nil until length N."
+ (let ((len (length lst)))
+ (if (= len n)
+ lst
+ (append lst (make-list (- n len) nil)))))
+
+(defmacro hydra-multipop (lst n)
+ "Return LST's first N elements while removing them."
+ `(if (<= (length ,lst) ,n)
+ (prog1 ,lst
+ (setq ,lst nil))
+ (prog1 ,lst
+ (setcdr
+ (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst))))
+ nil))))
+
+(defun hydra--matrix (lst rows cols)
+ "Create a matrix from elements of LST.
+The matrix size is ROWS times COLS."
+ (let ((ls (copy-sequence lst))
+ res)
+ (dotimes (_c cols)
+ (push (hydra--pad (hydra-multipop ls rows) rows) res))
+ (nreverse res)))
+
+(defun hydra--cell (fstr names)
+ "Format a rectangular cell based on FSTR and NAMES.
+FSTR is a format-style string with two string inputs: one for the
+doc and one for the symbol name.
+NAMES is a list of variables."
+ (let ((len (cl-reduce
+ (lambda (acc it) (max (length (symbol-name it)) acc))
+ names
+ :initial-value 0)))
+ (mapconcat
+ (lambda (sym)
+ (if sym
+ (format fstr
+ (documentation-property sym 'variable-documentation)
+ (let ((name (symbol-name sym)))
+ (concat name (make-string (- len (length name)) ?^)))
+ sym)
+ ""))
+ names
+ "\n")))
+
+(defun hydra--vconcat (strs &optional joiner)
+ "Glue STRS vertically. They must be the same height.
+JOINER is a function similar to `concat'."
+ (setq joiner (or joiner #'concat))
+ (mapconcat
+ (lambda (s)
+ (if (string-match " +$" s)
+ (replace-match "" nil nil s)
+ s))
+ (apply #'cl-mapcar joiner
+ (mapcar
+ (lambda (s) (split-string s "\n"))
+ strs))
+ "\n"))
+
+(defcustom hydra-cell-format "% -20s %% -8`%s"
+ "The default format for docstring cells."
+ :type 'string)
+
+(defun hydra--table (names rows cols &optional cell-formats)
+ "Format a `format'-style table from variables in NAMES.
+The size of the table is ROWS times COLS.
+CELL-FORMATS are `format' strings for each column.
+If CELL-FORMATS is a string, it's used for all columns.
+If CELL-FORMATS is nil, `hydra-cell-format' is used for all columns."
+ (setq cell-formats
+ (cond ((null cell-formats)
+ (make-list cols hydra-cell-format))
+ ((stringp cell-formats)
+ (make-list cols cell-formats))
+ (t
+ cell-formats)))
+ (hydra--vconcat
+ (cl-mapcar
+ #'hydra--cell
+ cell-formats
+ (hydra--matrix names rows cols))
+ (lambda (&rest x)
+ (mapconcat #'identity x " "))))
+
+(defun hydra-reset-radios (names)
+ "Set varibles NAMES to their defaults.
+NAMES should be defined by `defhydradio' or similar."
+ (dolist (n names)
+ (set n (aref (get n 'range) 0))))
+
+(defun hydra-timeout (secs &optional function)
+ "In SECS seconds call FUNCTION, then function `hydra-keyboard-quit'.
+Cancel the previous `hydra-timeout'."
+ (cancel-timer hydra-timer)
+ (setq hydra-timer (timer-create))
+ (timer-set-time hydra-timer
+ (timer-relative-time (current-time) secs))
+ (timer-set-function
+ hydra-timer
+ `(lambda ()
+ ,(when function
+ `(funcall ,function))
+ (hydra-keyboard-quit)))
+ (timer-activate hydra-timer))