branch: master
commit 3db82e5f4340e40143c594192177088fe1a61443
Author: David AMAR <amardavid3...@gmail.com>
Commit: Oleh Krehel <ohwoeo...@gmail.com>
Implement named columns
This is a first rough implementation to gather early reviews
diff with code snippet from #147:
- Dash dependencies removed
- slight refactoring
Add basic column integration test.
Fixes #220
---
hydra-test.el | 72 +++++++++++++++++++++++++++++++++++++
hydra.el | 114 +++++++++++++++++++++++++++++++++++++++++++++++++++++++---
2 files changed, 182 insertions(+), 4 deletions(-)
diff --git a/hydra-test.el b/hydra-test.el
index 9a3e3d7..5181cfb 100644
--- a/hydra-test.el
+++ b/hydra-test.el
@@ -1409,6 +1409,78 @@ t: info-to"
314 315 (face hydra-face-blue)
322 323 (face hydra-face-blue)))))
+;; checked:
+;; basic rendering
+;; column compatibility with ruby style and no colum specified
+;; column declared several time
+;; nil column
+(ert-deftest hydra-column-1 ()
+ (should (equal (eval
+ (cadr
+ (nth 2
+ (nth 3
+ (macroexpand
+ '(defhydra hydra-rectangle (:body-pre
(rectangle-mark-mode 1)
+ :color pink
+ :post
(deactivate-mark))
+ "
+ ^_k_^ ()()
+_h_ _l_ (O)(o)
+ ^_j_^ ( O )
+^^^^ (’’)(’’)
+^^^^
+"
+ ("h" backward-char nil)
+ ("l" forward-char nil)
+ ("k" previous-line nil)
+ ("j" next-line nil)
+ ("Of" 5x5 "outside of table 1")
+ ("e" exchange-point-and-mark "exchange"
:column "firstcol")
+ ("n" copy-rectangle-as-kill "new-copy")
+ ("d" delete-rectangle "delete")
+ ("r" (if (region-active-p)
+ (deactivate-mark)
+ (rectangle-mark-mode 1)) "reset"
:column "secondcol")
+ ("y" yank-rectangle "yank")
+ ("u" undo "undo")
+ ("s" string-rectangle "string")
+ ("p" kill-rectangle "paste")
+ ("o" nil "ok" :column "firstcol")
+ ("Os" 5x5-bol "outside of table 2" :column
nil)
+ ("Ot" 5x5-eol "outside of table 3")))))))
+
+#(" k ()()
+h l (O)(o)
+ j ( O )
+ (’’)(’’)
+
+
+firstcol | secondcol
+----------- | ------------
+e: exchange | r: reset
+n: new-copy | y: yank
+d: delete | u: undo
+o: ok | s: string
+ | p: paste
+[Of]: outside of table 1, [Os]: outside of table 2, [Ot]: outside of table 3."
+2 3 (face hydra-face-pink)
+17 18 (face hydra-face-pink)
+21 22 (face hydra-face-pink)
+38 39 (face hydra-face-pink)
+142 143 (face hydra-face-pink)
+156 157 (face hydra-face-pink)
+170 171 (face hydra-face-pink)
+184 185 (face hydra-face-pink)
+198 199 (face hydra-face-pink)
+212 213 (face hydra-face-pink)
+226 227 (face hydra-face-blue)
+240 241 (face hydra-face-pink)
+268 269 (face hydra-face-pink)
+283 285 (face hydra-face-pink)
+309 311 (face hydra-face-pink)
+335 337 (face hydra-face-pink)))))
+
+
(provide 'hydra-test)
;;; hydra-test.el ends here
diff --git a/hydra.el b/hydra.el
index eaedd6c..992f9db 100644
--- a/hydra.el
+++ b/hydra.el
@@ -408,6 +408,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)
+ "set a property PROP to the value VALUE in the hydra head H"
+ (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
@@ -469,17 +477,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))
@@ -535,6 +545,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'.")
@@ -952,6 +973,91 @@ 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 sorted by ascending 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))
+ (heads-sorted (cl-sort heads-wo-nil-doc (lambda (it other)
+ (string<
(hydra--head-property it :column)
+
(hydra--head-property other :column))))))
+ ;; 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 list of heads copied from HEADS-GROUPS where each heads group have
the same length.
+This is achieved by adding PADDING-HEAD were needed."
+ (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 with following differences:
+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 HEADS-MATRIX and
BODY data and structure
+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
+ (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)
