New upstream version 0.14

1 files changed, 159 insertions, 23 deletions

diff --git a/hydra.el b/hydra.el
index 09a0052..e3b3703 100644
--- a/hydra.el
+++ b/hydra.el
@@ -5,7 +5,7 @@
 ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
 ;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
 ;; URL: https://github.com/abo-abo/hydra
-;; Version: 0.13.6
+;; Version: 0.14.0
 ;; Keywords: bindings
 ;; Package-Requires: ((cl-lib "0.5"))
 
@@ -82,6 +82,7 @@
 ;;* Requires
 (require 'cl-lib)
 (require 'lv)
+(require 'ring)
 
 (defvar hydra-curr-map nil
   "The keymap of the current Hydra called.")
@@ -99,6 +100,9 @@
   "If a Hydra head sets this to t, exit the Hydra.
 This will be done even if the head wasn't designated for exiting.")
 
+(defvar hydra-amaranth-warn-message "An amaranth Hydra can only exit through a blue head"
+  "Amaranth Warning message.  Shown when the user tries to press an unbound/non-exit key while in an amaranth head.")
+
 (defun hydra-set-transient-map (keymap on-exit &optional foreign-keys)
   "Set KEYMAP to the highest priority.
 
@@ -184,7 +188,7 @@ warn: keep KEYMAP and issue a warning instead of running the command."
 (defun hydra-amaranth-warn ()
   "Issue a warning that the current input was ignored."
   (interactive)
-  (message "An amaranth Hydra can only exit through a blue head"))
+  (message hydra-amaranth-warn-message))
 
 ;;* Customize
 (defgroup hydra nil
@@ -213,10 +217,19 @@ the body or the head."
 
 (defcustom hydra-key-format-spec "%s"
   "Default `format'-style specifier for _a_  syntax in docstrings.
-When nil, you can specify your own at each location like this: _ 5a_.")
+When nil, you can specify your own at each location like this: _ 5a_."
+  :type 'string)
 
 (defcustom hydra-doc-format-spec "%s"
-  "Default `format'-style specifier for ?a?  syntax in docstrings.")
+  "Default `format'-style specifier for ?a?  syntax in docstrings."
+  :type 'string)
+
+(defcustom hydra-look-for-remap nil
+  "When non-nil, hydra binding behaves as keymap binding with [remap].
+When calling a head with a simple command, hydra will lookup for a potential
+remap command according to the current active keymap and call it instead if
+found"
+  :type 'boolean)
 
 (make-obsolete-variable
  'hydra-key-format-spec
@@ -402,6 +415,14 @@ one of the properties on the list."
 Return DEFAULT if PROP is not in H."
   (hydra-plist-get-default (cl-cdddr h) prop default))
 
+(defun hydra--head-set-property (h prop value)
+  "In hydra Head H, set a property PROP to the value VALUE."
+  (cons (car h) (plist-put (cdr h) prop value)))
+
+(defun hydra--head-has-property (h prop)
+  "Return non nil if heads H has the property PROP."
+  (plist-member (cdr h) prop))
+
 (defun hydra--body-foreign-keys (body)
   "Return what BODY does with a non-head binding."
   (or
@@ -463,17 +484,19 @@ Return DEFAULT if PROP is not in H."
 
 (defun hydra-key-doc-function-default (key key-width doc doc-width)
   "Doc"
-  (format (format "%%%ds: %%%ds" key-width (- -1 doc-width))
-          key doc))
+  (cond
+   ((equal key " ") (format (format "%%-%ds" (+ 3 key-width doc-width)) doc))
+   (t (format (format "%%%ds: %%%ds" key-width (- -1 doc-width)) key doc))))
 
 (defun hydra--to-string (x)
   (if (stringp x)
       x
     (eval x)))
 
-(defun hydra--hint (body heads)
+(defun hydra--hint-heads-wocol (body heads)
   "Generate a hint for the echo area.
-BODY, and HEADS are parameters to `defhydra'."
+BODY, and HEADS are parameters to `defhydra'.
+Works for heads without a property :column."
   (let (alist)
     (dolist (h heads)
       (let ((val (assoc (cadr h) alist))
@@ -529,6 +552,17 @@ BODY, and HEADS are parameters to `defhydra'."
           (eval res)
         res))))
 
+(defun hydra--hint (body heads)
+  "Generate a hint for the echo area.
+BODY, and HEADS are parameters to `defhydra'."
+  (let* ((sorted-heads (hydra--sort-heads (hydra--normalize-heads heads)))
+         (heads-w-col (cl-remove-if-not (lambda (heads) (hydra--head-property (nth 0 heads) :column)) sorted-heads))
+         (heads-wo-col (cl-remove-if (lambda (heads) (hydra--head-property (nth 0 heads) :column)) sorted-heads)))
+    (concat (when heads-w-col
+              (concat "\n" (hydra--hint-from-matrix body (hydra--generate-matrix heads-w-col))))
+            (when heads-wo-col
+              (hydra--hint-heads-wocol body (car heads-wo-col))))))
+
 (defvar hydra-fontify-head-function nil
   "Possible replacement for `hydra-fontify-head-default'.")
 
@@ -549,18 +583,17 @@ HEAD's binding is returned as a string with a colored face."
     (when (and (null (cadr head))
                (not head-exit))
       (hydra--complain "nil cmd can only be blue"))
-    (propertize (if (string= (car head) "%")
-                    "%%"
-                  (car head))
-                'face
-                (or (hydra--head-property head :face)
-                    (cl-case head-color
-                      (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" head)))))))
+    (propertize
+     (replace-regexp-in-string "%" "%%" (car head))
+     'face
+     (or (hydra--head-property head :face)
+         (cl-case head-color
+           (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" head)))))))
 
 (defun hydra-fontify-head-greyscale (head _body)
   "Produce a pretty string from HEAD and BODY.
@@ -714,6 +747,16 @@ HEADS is a list of heads."
     heads ",\n")
    (format "The body can be accessed via `%S'." body-name)))
 
+(defun hydra--call-interactively-remap-maybe (cmd)
+  "`call-interactively' the given CMD or its remapped equivalent.
+Only when `hydra-look-for-remap' is non nil."
+  (let ((remapped-cmd (if hydra-look-for-remap
+                          (command-remapping `,cmd)
+                        nil)))
+    (if remapped-cmd
+        (call-interactively `,remapped-cmd)
+      (call-interactively `,cmd))))
+
 (defun hydra--call-interactively (cmd name)
   "Generate a `call-interactively' statement for CMD.
 Set `this-command' to NAME."
@@ -721,8 +764,8 @@ Set `this-command' to NAME."
            (not (memq name '(nil body))))
       `(progn
          (setq this-command ',name)
-         (call-interactively #',cmd))
-    `(call-interactively #',cmd)))
+         (hydra--call-interactively-remap-maybe #',cmd))
+    `(hydra--call-interactively-remap-maybe #',cmd)))
 
 (defun hydra--make-defun (name body doc head
                           keymap body-pre body-before-exit
@@ -769,7 +812,7 @@ BODY-AFTER-EXIT is added to the end of the wrapper."
                  `(condition-case err
                       ,(hydra--call-interactively cmd (cadr head))
                     ((quit error)
-                     (message "%S" err)
+                     (message (error-message-string err))
                      (unless hydra-lv
                        (sit-for 0.8)))))
               ,(if (and body-idle (eq (cadr head) 'body))
@@ -947,6 +990,98 @@ NAMES should be defined by `defhydradio' or similar."
   (dolist (n names)
     (set n (aref (get n 'range) 0))))
 
+;; Following functions deal with automatic docstring table generation from :column head property
+(defun hydra--normalize-heads (heads)
+  "Ensure each head from HEADS have a property :column.
+Set it to the same value as preceding head or nil if no previous value
+was defined."
+  (let ((current-col nil))
+    (mapcar (lambda (head)
+              (if (hydra--head-has-property head :column)
+                  (setq current-col (hydra--head-property head :column)))
+              (hydra--head-set-property head :column current-col))
+            heads)))
+
+(defun hydra--sort-heads (normalized-heads)
+  "Return a list of heads with non-nil doc grouped by column property.
+Each head of NORMALIZED-HEADS must have a column property."
+  (let* ((heads-wo-nil-doc (cl-remove-if-not (lambda (head) (nth 2 head)) normalized-heads))
+         (columns-list (delete-dups (mapcar (lambda (head) (hydra--head-property head :column))
+                                            normalized-heads)))
+         (get-col-index-fun (lambda (head) (cl-position (hydra--head-property head :column)
+                                                        columns-list
+                                                        :test 'equal)))
+         (heads-sorted (cl-sort heads-wo-nil-doc (lambda (it other)
+                                                   (< (funcall get-col-index-fun it)
+                                                      (funcall get-col-index-fun other))))))
+    ;; this operation partition the sorted head list into lists of heads with same column property
+    (cl-loop for head in heads-sorted
+       for column-name = (hydra--head-property head :column)
+       with prev-column-name = (hydra--head-property (nth 0 heads-sorted) :column)
+       unless (equal prev-column-name column-name) collect heads-one-column into heads-all-columns
+       and do (setq heads-one-column nil)
+       collect head into heads-one-column
+       do (setq prev-column-name column-name)
+       finally return (append heads-all-columns (list heads-one-column)))))
+
+(defun hydra--pad-heads (heads-groups padding-head)
+  "Return a copy of HEADS-GROUPS padded where applicable with PADDING-HEAD."
+  (cl-loop for heads-group in heads-groups
+     for this-head-group-length = (length heads-group)
+     with head-group-max-length = (apply #'max (mapcar (lambda (heads) (length heads)) heads-groups))
+     if (<= this-head-group-length head-group-max-length)
+     collect (append heads-group (make-list (- head-group-max-length this-head-group-length) padding-head))
+     into balanced-heads-groups
+     else collect heads-group into balanced-heads-groups
+     finally return balanced-heads-groups))
+
+(defun hydra--generate-matrix (heads-groups)
+  "Return a copy of HEADS-GROUPS decorated with table formating information.
+Details of modification:
+2 virtual heads acting as table header were added to each heads-group.
+Each head is decorated with 2 new properties max-doc-len and max-key-len
+representing the maximum dimension of their owning group.
+ Every heads-group have equal length by adding padding heads where applicable."
+  (when heads-groups
+    (cl-loop for heads-group in (hydra--pad-heads heads-groups '(" " nil " " :exit t))
+             for column-name = (hydra--head-property (nth 0 heads-group) :column)
+             for max-key-len = (apply #'max (mapcar (lambda (x) (length (car x))) heads-group))
+             for max-doc-len = (apply #'max
+                                      (length column-name)
+                                      (mapcar (lambda (x) (length (hydra--to-string (nth 2 x)))) heads-group))
+             for header-virtual-head = `(" " nil ,column-name :column ,column-name :exit t)
+             for separator-virtual-head = `(" " nil ,(make-string (+ 2 max-doc-len max-key-len) ?-) :column ,column-name :exit t)
+             for decorated-heads = (copy-tree (apply 'list header-virtual-head separator-virtual-head heads-group))
+             collect (mapcar (lambda (it)
+                               (hydra--head-set-property it :max-key-len max-key-len)
+                               (hydra--head-set-property it :max-doc-len max-doc-len))
+                             decorated-heads)
+             into decorated-heads-matrix
+             finally return decorated-heads-matrix)))
+
+(defun hydra--hint-from-matrix (body heads-matrix)
+  "Generate a formated table-style docstring according to BODY and HEADS-MATRIX.
+HEADS-MATRIX is expected to be a list of heads with following features:
+Each heads must have the same length
+Each head must have a property max-key-len and max-doc-len."
+  (when heads-matrix
+    (cl-loop with first-heads-col = (nth 0 heads-matrix)
+             with last-row-index = (- (length first-heads-col) 1)
+             for row-index from 0 to last-row-index
+             for heads-in-row = (mapcar (lambda (heads) (nth row-index heads)) heads-matrix)
+             concat (concat
+                     (replace-regexp-in-string "\s+$" ""
+                                               (mapconcat (lambda (head)
+                                                            (funcall hydra-key-doc-function
+                                                                     (hydra-fontify-head head body) ;; key
+                                                                     (hydra--head-property head :max-key-len)
+                                                                     (nth 2 head) ;; doc
+                                                                     (hydra--head-property head :max-doc-len)))
+                                                          heads-in-row "| ")) "\n")
+             into matrix-image
+             finally return matrix-image)))
+;; previous functions dealt with automatic docstring table generation from :column head property
+
 (defun hydra-idle-message (secs hint name)
   "In SECS seconds display HINT."
   (cancel-timer hydra-message-timer)
@@ -1027,6 +1162,7 @@ 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))
+  (setq heads (copy-tree heads))
   (cond ((stringp docstring))
         ((and (consp docstring)
               (memq (car docstring) '(hydra--table concat format)))