[elpa] externals/dtache 357432877c 033/158: Implement annotation/affixation function

[ELPA Syncer]

branch: externals/dtache
commit 357432877c685c25e9583c9e4e6f2f5585805ecd
Author: Niklas Eklund <niklas.eklund@posteo.net>
Commit: Niklas Eklund <niklas.eklund@posteo.net>

    Implement annotation/affixation function
    
    In order to provide annotations to all users dtache this patch
    implements an annotation/affixation function which will provide
    annotations for dtache-open-session.
---
 dtache.el | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 79 insertions(+), 12 deletions(-)

diff --git a/dtache.el b/dtache.el
index 2ae7b82de1..e31c565795 100644
--- a/dtache.el
+++ b/dtache.el
@@ -79,6 +79,59 @@
   "Hooks to run when compiling a session.")
 (defvar dtache-metadata-annotators-alist nil
   "An alist of annotators for metadata.")
+(defvar dtache-annotation-format
+  `((:width 3 :function dtache--active-str :face dtache-active-face)
+    (:width 3 :function dtache--status-str :face dtache-failure-face)
+    (:width 10 :function dtache--session-host :face dtache-host-face)
+    (:width 40 :function dtache--working-dir-str :face dtache-working-dir-face)
+    (:width 30 :function dtache--metadata-str :face dtache-metadata-face)
+    (:width 10 :function dtache--duration-str :face dtache-duration-face)
+    (:width 8 :function dtache--size-str :face dtache-size-face)
+    (:width 12 :function dtache--creation-str :face dtache-creation-face))
+  "The format of the annotations.")
+
+;;;;; Faces
+
+(defgroup dtache-faces nil
+  "Faces used by `dtache'."
+  :group 'dtache
+  :group 'faces)
+
+(defface dtache-metadata-face
+  '((t :inherit font-lock-builtin-face))
+  "Face used to highlight metadata in `dtache'.")
+
+(defface dtache-failure-face
+  '((t :inherit error))
+  "Face used to highlight failure in `dtache'.")
+
+(defface dtache-active-face
+  '((t :inherit success))
+  "Face used to highlight active in `dtache'.")
+
+(defface dtache-duration-face
+  '((t :inherit font-lock-builtin-face))
+  "Face used to highlight duration in `dtache'.")
+
+(defface dtache-size-face
+  '((t :inherit font-lock-function-name-face))
+  "Face used to highlight size in `dtache'.")
+
+(defface dtache-creation-face
+  '((t :inherit font-lock-comment-face))
+  "Face used to highlight date in `dtache'.")
+
+(defface dtache-working-dir-face
+  '((t :inherit font-lock-variable-name-face))
+  "Face used to highlight working directory in `dtache'.")
+
+(defface dtache-host-face
+  '((t :inherit font-lock-constant-face))
+  "Face used to highlight host in `dtache'.")
+
+(defface dtache-identifier-face
+  '((t :inherit font-lock-comment-face))
+  "Face used to highlight identifier in `dtache'.")
 
 ;;;;; Private
 
@@ -373,6 +426,17 @@ Sessions running on  current host or localhost are 
updated."
                               (dtache--session-short-id it))))
                (prog1 s (put-text-property 0 1 'dtache--data it s))))
            sessions))
+(defun dtache-session-annotation (session)
+  "Return annotation string for SESSION."
+  (mapconcat
+   #'identity
+   (cl-loop for annotation in dtache-annotation-format
+            collect (let ((str (funcall (plist-get annotation :function) 
session)))
+                      (truncate-string-to-width
+                       (propertize str 'face (plist-get annotation :face))
+                       (plist-get annotation :width)
+                       0 ?\s)))
+   "   "))
 
 (defun dtache-update-session (session)
   "Update SESSION."
@@ -487,20 +551,23 @@ Sessions running on  current host or localhost are 
updated."
 (defun dtache-completing-read (sessions)
   "Select a session from SESSIONS through `completing-read'."
   (let* ((candidates (dtache-session-candidates sessions))
-         (metadata '(metadata
+         (metadata `(metadata
                      (category . dtache)
                      (cycle-sort-function . identity)
-                     (display-sort-function . identity)))
-         (coll (lambda (string predicate action)
-                 (if (eq action 'metadata)
-                     metadata
-                   (complete-with-action action candidates string predicate))))
-         (cand (minibuffer-with-setup-hook
-                   (lambda ()
-                     (add-hook 'after-change-functions 'dtache--eat-cookie nil 
t))
-                 (completing-read "Select session: " coll nil t nil
-                                  'dtache-session-history))))
-    (get-text-property 0 'dtache--data (car (member cand candidates)))))
+                     (display-sort-function . identity)
+                     (annotation-function . ,(lambda (s)
+                                               (dtache-session-annotation (cdr 
(assoc s candidates)))))
+                     (affixation-function .
+                                          ,(lambda (cands)
+                                             (seq-map (lambda (s)
+                                                        `(,s nil 
,(dtache-session-annotation (cdr (assoc s candidates)))))
+                                                      cands)))))
+         (collection (lambda (string predicate action)
+                       (if (eq action 'metadata)
+                           metadata
+                         (complete-with-action action candidates string 
predicate))))
+         (cand (completing-read "Select session: " collection nil t nil 
'dtache-session-history)))
+    (cdr (assoc cand candidates))))
 
 (defun dtache-setup-notification (session)
   "Setup notification for SESSION."