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 (defun xpm-set-pen-func (parent normal none)
  30   (lexical-let ((parent parent))
  31     (lambda (color)
  32       ;; see "hang" below
  33       (let* ((was (current-buffer))
  34              (px (get-text-property 0 'px color))
  35              (again (assoc px normal)))
  36         (switch-to-buffer parent)
  37         (message "%S | %S %s | %S" was px color again)))))
  38
  39 (defun xpm-list-palette-display ()
  40   "Display palette in another buffer."
  41   (interactive)
  42   (xpm--w/gg (cpp pinfo) (xpm--gate)
  43     (let ((inhibit-read-only t)
  44           (name (format "*%s Palette*" (buffer-name)))
  45           normal none)
  46       ;; normalize and extract "None" if necessary
  47       (loop for (px . alist) in (xpm--palette-alist cpp pinfo)
  48             ;; todo: handle case where there is no ‘c’
  49             do (let ((color (cdr (assq 'c alist))))
  50                  (if (member color '("none" "None"))
  51                      (setq none px)
  52                    (push (cons px color)
  53                          normal)))
  54             finally do (setq normal (nreverse normal)))
  55       (list-colors-display (mapcar 'cdr normal) name
  56                            (xpm-set-pen-func (current-buffer)
  57                                              normal
  58                                              none))
  59       (switch-to-buffer name)
  60       (delete-other-windows)
  61       (goto-char (point-min))
  62       ;; ugly; better to not ‘insert’ and just add text properties.
  63       ;; also, focus is on px so we can hang it on ‘color-name’ directly
  64       (when none
  65         (insert (propertize (format "%S\tnone" none)
  66                             'color-name (propertize "none" 'px none))
  67                 "\n"))
  68       (while normal
  69         (let* ((px (car (pop normal)))
  70                (all (text-properties-at (point)))
  71                (color (plist-get all 'color-name))
  72                (button (plist-get all 'button))
  73                (action (plist-get all 'action)))
  74           (insert (propertize
  75                    (format "%S\t" px)
  76                    'color-name (propertize color 'px px)
  77                    'button button
  78                    'action action
  79                    'category 'default-button
  80                    'follow-link t)))
  81         (forward-line 1))
  82       (goto-char (point-min)))))
  83
  84 ;;; xpm-ui.el ends here