[elpa] externals/ef-themes e0e41efe40 3/4: Make the preview palette mechanism use tabulated-list-mode

[ELPA Syncer]

branch: externals/ef-themes
commit e0e41efe409a0ebc775779e3556af51641f0d933
Author: Protesilaos Stavrou <info@protesilaos.com>
Commit: Protesilaos Stavrou <info@protesilaos.com>

    Make the preview palette mechanism use tabulated-list-mode
    
    This makes it possible to sort by column.
---
 ef-themes.el | 153 +++++++++++++++++++++++++++++------------------------------
 1 file changed, 76 insertions(+), 77 deletions(-)

diff --git a/ef-themes.el b/ef-themes.el
index 35c4943daa..3b5a5e6b0b 100644
--- a/ef-themes.el
+++ b/ef-themes.el
@@ -755,88 +755,87 @@ the list becomes the last.  Do not modify THEMES in the 
process."
       (user-error "`%s' is not part of the Ef collection" candidate))))
 
 ;;;; Preview a theme palette
-
-(defun ef-themes--preview-colors-render (buffer theme &optional mappings &rest 
_)
-  "Render colors in BUFFER from THEME for `ef-themes-preview-colors'.
-Optional MAPPINGS changes the output to only list the semantic
-color mappings of the palette, instead of its named colors."
+(defun ef-themes--list-colors-get-mappings (palette)
+  "Get the semantic palette entries in PALETTE.
+PALETTE is the value of a variable like `ef-summer-palette'."
+  (seq-remove
+   (lambda (cell)
+     (stringp (cadr cell)))
+   palette))
+
+(defun ef-themes--list-colors-tabulated (theme &optional mappings)
+  "Return a data structure of THEME palette or MAPPINGS for tabulated list."
   (let* ((current-palette (ef-themes--palette-value theme mappings))
          (palette (if mappings
-                      (seq-remove (lambda (cell)
-                                    (stringp (cadr cell)))
-                                  current-palette)
-                    current-palette))
-         (current-buffer buffer)
-         (current-theme theme))
-    (with-help-window buffer
-      (with-current-buffer standard-output
-        (erase-buffer)
-        (when (<= (display-color-cells) 256)
-          (insert (concat "Your display terminal may not render all color 
previews!\n"
-                          "It seems to only support <= 256 colors.\n\n"))
-          (put-text-property (point-min) (point) 'face 'warning))
-        ;; We need this to properly render the first line.
-        (insert " ")
-        (dolist (cell palette)
-          (let* ((name (car cell))
-                 (color (ef-themes-get-color-value name mappings theme))
-                 (pad (make-string 10 ?\s))
-                 (fg (if (eq color 'unspecified)
-                         (progn
-                           (readable-foreground-color 
(ef-themes-get-color-value 'bg-main nil theme))
-                           (setq pad (make-string 6 ?\s)))
-                       (readable-foreground-color color))))
-            (let ((old-point (point)))
-              (insert (format "%s %s" color pad))
-              (put-text-property old-point (point) 'face `( :foreground 
,color)))
-            (let ((old-point (point)))
-              (insert (format " %s %s %s\n" color pad name))
-              (put-text-property old-point (point)
-                                 'face `( :background ,color
-                                          :foreground ,fg
-                                          :extend t)))
-            ;; We need this to properly render the last line.
-            (insert " ")))
-        (setq-local revert-buffer-function
-                    (lambda (_ignore-auto _noconfirm)
-                      (ef-themes--preview-colors-render current-buffer 
current-theme mappings)))))))
-
-(defvar ef-themes--preview-colors-prompt-history '()
-  "Minibuffer history for `ef-themes--preview-colors-prompt'.")
-
-(defun ef-themes--preview-colors-prompt ()
-  "Prompt for Ef theme.
-Helper function for `ef-themes-preview-colors'."
-  (let ((def (format "%s" (ef-themes--current-theme)))
-        (completion-extra-properties `(:annotation-function 
,#'ef-themes--annotate-theme)))
-    (completing-read
-     (format "Use palette from theme [%s]: " def)
-     (ef-themes--load-subset :all-themes)
-     nil t nil
-     'ef-themes--preview-colors-prompt-history def)))
-
-(defun ef-themes-preview-colors (theme &optional mappings)
-  "Preview named colors of the Ef THEME of choice.
-With optional prefix argument for MAPPINGS preview the semantic
-color mappings instead of the named colors."
-  (interactive (list (intern (ef-themes--preview-colors-prompt)) 
current-prefix-arg))
-  (ef-themes--preview-colors-render
-   (format (if mappings "*%s-preview-mappings*" "*%s-preview-colors*") theme)
-   theme
-   mappings))
-
-(defalias 'ef-themes-list-colors 'ef-themes-preview-colors
-  "Alias of `ef-themes-preview-colors'.")
-
-(defun ef-themes-preview-colors-current (&optional mappings)
-  "Call `ef-themes-list-colors' for the current Ef theme.
-Optional prefix argument MAPPINGS has the same meaning as for
-`ef-themes-list-colors'."
+                      (ef-themes--list-colors-get-mappings current-palette)
+                    current-palette)))
+    (mapcar (lambda (cell)
+              (pcase-let* ((`(,name ,value) cell)
+                           (name-string (format "%s" name))
+                           (value-string (format "%s" value))
+                           (value-string-padded (string-pad value-string 30))
+                           (color (ef-themes-get-color-value name mappings 
theme))) ; resolve a semantic mapping
+                (list name
+                      (vector
+                       (if (symbolp value)
+                           "Yes"
+                         "")
+                       name-string
+                       (propertize value-string 'face `( :foreground ,color))
+                       (propertize value-string-padded 'face (list :background 
color
+                                                                   :foreground 
(if (string= color "unspecified")
+                                                                               
    (readable-foreground-color (ef-themes-get-color-value 'bg-main nil theme))
+                                                                               
  (readable-foreground-color color))))))))
+            palette)))
+
+(defvar ef-themes-current-preview nil)
+(defvar ef-themes-current-preview-show-mappings nil)
+
+(defun ef-themes--set-tabulated-entries ()
+  "Set the value of `tabulated-list-entries' with palette entries."
+  (setq-local tabulated-list-entries
+              (ef-themes--list-colors-tabulated ef-themes-current-preview 
ef-themes-current-preview-show-mappings)))
+
+(defun ef-themes-list-colors (theme &optional mappings)
+  "Preview the palette of the Ef THEME of choice.
+With optional prefix argument for MAPPINGS preview only the semantic
+color mappings instead of the complete palette."
+  (interactive
+   (let ((prompt (if current-prefix-arg
+                     "Preview palette mappings of THEME: "
+                   "Preview palette of THEME: ")))
+     (list
+      (ef-themes--select-prompt prompt)
+      current-prefix-arg)))
+  (let ((buffer (get-buffer-create (format (if mappings "*%s-list-mappings*" 
"*%s-list-all*") theme))))
+    (with-current-buffer buffer
+      (let ((ef-themes-current-preview theme)
+            (ef-themes-current-preview-show-mappings mappings))
+        (ef-themes-preview-mode)))
+    (pop-to-buffer buffer)))
+
+(defalias 'ef-themes-preview-colors 'ef-themes-list-colors
+  "Alias for `ef-themes-list-colors'.")
+
+(defun ef-themes-list-colors-current (&optional mappings)
+  "Like `ef-themes-list-colors' with optional MAPPINGS for the current theme."
   (interactive "P")
   (ef-themes-list-colors (ef-themes--current-theme) mappings))
 
-(defalias 'ef-themes-list-colors-current 'ef-themes-preview-colors-current
-  "Alias of `ef-themes-preview-colors-current'.")
+(defalias 'ef-themes-preview-colors-current 'ef-themes-list-colors-current
+  "Alias for `ef-themes-list-colors-current'.")
+
+(define-derived-mode ef-themes-preview-mode tabulated-list-mode "Ef palette"
+  "Major mode to display a Ef themes palette."
+  :interactive nil
+  (setq-local tabulated-list-format
+              [("Mapping?" 10 t)
+               ("Symbol name" 30 t)
+               ("As foreground" 30 t)
+               ("As background" 0 t)])
+  (ef-themes--set-tabulated-entries)
+  (tabulated-list-init-header)
+  (tabulated-list-print))
 
 ;;; Faces and variables