[elpa] master 3db82e5 29/36: Implement named columns

[Oleh Krehel]

branch: master
commit 3db82e5f4340e40143c594192177088fe1a61443
Author: David AMAR <address@hidden>
Commit: Oleh Krehel <address@hidden>

    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)