code.delx.au - gnu-emacs-elpa/blob - packages/xpm/xpm-ui.el

   1 ;;; xpm-ui.el --- xpm-* plus pretty redisplay   -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation, either version 3 of the License, or
   8 ;; (at your option) any later version.
   9
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19
  20 ;; TODO
  21 ;;
  22 ;; ??? hmm, since this will probably be the future home of xpm-mode,
  23 ;;     why not rename the file as xpm-mode.el?
  24
  25 ;;; Code:
  26
  27 ;; todo: var ‘xpm-current-px’ (or maybe ‘xpm-quill’)
  28
  29 (eval-when-compile (require 'cl-lib))
  30 (require 'xpm)
  31
  32 (defun xpm-set-pen-func (parent normal _none)
  33   (lambda (color)
  34     ;; see "hang" below
  35     (let* ((was (current-buffer))
  36            (px (get-text-property 0 'px color))
  37            (again (assoc px normal)))
  38       (switch-to-buffer parent)
  39       (message "%S | %S %s | %S" was px color again))))
  40
  41 (defun xpm-list-palette-display ()
  42   "Display palette in another buffer."
  43   (interactive)
  44   (xpm--w/gg (cpp pinfo) (xpm--gate)
  45     (let ((inhibit-read-only t)
  46           (name (format "*%s Palette*" (buffer-name)))
  47           normal none)
  48       ;; normalize and extract "None" if necessary
  49       (cl-loop for (px . alist) in (xpm--palette-alist cpp pinfo)
  50                ;; todo: handle case where there is no ‘c’
  51                do (let ((color (cdr (assq 'c alist))))
  52                     (if (member color '("none" "None"))
  53                         (setq none px)
  54                       (push (cons px color)
  55                             normal)))
  56                finally do (setq normal (nreverse normal)))
  57       (list-colors-display (mapcar 'cdr normal) name
  58                            (xpm-set-pen-func (current-buffer)
  59                                              normal
  60                                              none))
  61       (switch-to-buffer name)
  62       (delete-other-windows)
  63       (goto-char (point-min))
  64       ;; ugly; better to not ‘insert’ and just add text properties.
  65       ;; also, focus is on px so we can hang it on ‘color-name’ directly
  66       (when none
  67         (insert (propertize (format "%S\tnone" none)
  68                             'color-name (propertize "none" 'px none))
  69                 "\n"))
  70       (while normal
  71         (let* ((px (car (pop normal)))
  72                (all (text-properties-at (point)))
  73                (color (plist-get all 'color-name))
  74                (button (plist-get all 'button))
  75                (action (plist-get all 'action)))
  76           (insert (propertize
  77                    (format "%S\t" px)
  78                    'color-name (propertize color 'px px)
  79                    'button button
  80                    'action action
  81                    'category 'default-button
  82                    'follow-link t)))
  83         (forward-line 1))
  84       (goto-char (point-min)))))
  85
  86 ;;; xpm-ui.el ends here