cgit.sxemacs.org Git - packages/blob - xemacs-packages/edit-utils/buffer-colors.el

   1 ;;; buffer-colors.el
   2 ;;; Copyright (C) 2011  Byrel Mitchell and Steve Mitchell
   3 ;;; email: smitchel@bnin.net
   4 ;;; email: byrel.mitchell@gmail.com
   5 ;;;
   6 ;;;  This program is free software; you can redistribute it and/or modify
   7 ;;;  it under the terms of the GNU General Public License as published by
   8 ;;;  the Free Software Foundation; either version 3, or (at your option)
   9 ;;;  any later version.
  10 ;;;
  11 ;;;  This program is distributed in the hope that it will be useful,
  12 ;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;  GNU General Public License for more details.
  15 ;;;
  16 ;;;  You should have received a copy of the GNU General Public License
  17 ;;;  along with this program; if not, write to the Free Software
  18 ;;;  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19 ;;;
  20 ;;;
  21 ;;; Description:
  22 ;;;
  23 ;;;     A menu system for setting buffer local face colors.
  24 ;;;     Allows adding and removing menu entries, and storage of permanent custom colors.
  25 ;;;
  26 ;;;    Afer the first time it runs, on startup, it loads a list of colors from custom.el.
  27 ;;;    if none found, it creates a list of a few colors to start out with.  Thereafter
  28 ;;;    we keep a list in custom.el of all fg/bg pairs and load that list each time.
  29 ;;;
  30 ;;;    These color changes are by default "by the buffer" (no matter the window or pane it is
  31 ;;;    displayed in). It can also be set so the color changes will follow a window
  32 ;;;    (no matter what buffer is displayed there)
  33 ;;;    Easy to choose between these 2 methods either on the menu or in a customize buffer:
  34 ;;;      M-x customize-group buffer-colors
  35 ;;;
  36 ;;;    There is also a list of "rules" to colorize new buffers, based on things we can know
  37 ;;;    about the file, such as read-only, or filename extension, or date-modified, etc.
  38 ;;;
  39 ;;; Purpose is to have an easy at-hand way to change buffer colors
  40 ;;;  instead of a full customize buffer, making it easy to:
  41 ;;;  -ease eye strain--change hourly, daily or as lighting conditions change.
  42 ;;;  -On a 30" monitor I often have 3-4 buffers open and this helps me keep
  43 ;;;     straight which file is which--especially when source code and file names
  44 ;;;     are very, very similar between files.
  45 ;;;  -organize buffers by catagory:
  46 ;;;              have one fg/bg color pair for files that you load for referance
  47 ;;;              have a fg/bg color you use for read only files
  48 ;;;              have a fg/bg color you use for your try-out buffer
  49 ;;;              have a fr/bg color for open emails, another pair for replies
  50 ;;;           Four example "rules" are pre-programmed in, you can remove or reorder
  51 ;;;           these, or add new rules.  Anything you know about a file can be used
  52 ;;;           to create a "rule" to decide how to colorize files when loading them.
  53 ;;;           (after they are loaded, and colorized then, you can still change the
  54 ;;;           colors at any time through either the Buffer Colors menu or
  55 ;;;           through a customize buffer (under the Buffer Colors menu-->settings).
  56 ;;;
  57 ;;; Adds a toggle turn buffer colors on/off:  Options-->Display-->Buffer Colors
  58 ;;; Adds a selection to the Buffers Menu: Buffer Colors.
  59 ;;; What it does:
  60 ;;;     1.  Lets you specify foreground and background colors
  61 ;;;           differently for each buffer on the fly.
  62 ;;;     2.  Lets you set new combinations of fg/bg colors
  63 ;;;           and save the list of colors to disk.
  64 ;;;     3.  Displays a list in a buffer of valid colors
  65 ;;;           with their names, for you to refer to.
  66 ;;;     3.  Creates a file buffercolors.el in your ~/.xemacs directory,
  67 ;;;          for storing fg/bg colors for the predefined choices on the menu.
  68 ;;;    4.  All code is in the file buffer-color-menu.el,
  69 ;;;         All settings are saved in custom.el
  70 ;;;
  71 ;;; TODO
  72 ;;;   This implements buffer-colors as a behavior. Currently it needs enabled each session,
  73 ;;;   by toggling Options-->Display-->Buffer-Colors
  74 ;;;     We need to find a way to have it on by default.
  75 ;;;
  76 (require 'menubar)  ;contains add-menu-button
  77 (require 'wid-edit) ;contains widget-value
  78
  79 (define-specifier-tag 'buffer-colors)
  80
  81 (define-specifier-tag 'bc-read-only)
  82
  83 (defvar bc-fgbg-menu nil "Menu for Buffer Colors")
  84
  85 ;;;###autoload
  86 (defvar bc-buffer-colors-enabled-p nil
  87   "Is buffer-colors currently loaded.
  88 This variable is used on systems without behavior functionality to keep track of whether buffer-colors is currently loaded.")
  89
  90 ;; the behaviour lets us
  91 ;;      disable Buffer Colors,
  92 ;;      remove the Buffer Colors menu item,
  93 ;;      and delete all previously set buffer colors,
  94 ;;         restoring them to the colors in the default face.
  95 (when (functionp 'define-behavior)
  96   (define-behavior 'buffer-colors
  97     "A system for quickly changing the fg and bg colors of buffers.
  98 It includes a rule-based system for coloring new buffers."
  99     :enable 'bc-enable-behavior
 100     :disable 'bc-disable-behavior))
 101
 102 ;;---- functions for rules ----------------------------------------
 103 (defun bc-read-only-p ()
 104   "Return t if current buffer is read only."
 105   buffer-read-only)
 106
 107 (defun bc-c-file-p ()
 108   "Return t if buffer file name ends in .c or .cpp."
 109   (string-match "\\.c\\(pp\\)?$" buffer-file-name))
 110
 111 (defun bc-h-file-p ()
 112   "Return t if buffer file name ends in .h."
 113   (string-match "\\.h$" buffer-file-name))
 114
 115 (defun bc-el-file-p ()
 116   "Return t if buffer file name ends in .el."
 117   (string-match "\\.el$" buffer-file-name))
 118
 119 (defmacro bc-set-fgbg (fg bg tag-set)
 120   "Sets the fg/bg properties of the default face for the current buffer locale."
 121   `(progn
 122     (set-face-foreground 'default ,fg
 123                          (if bc-per-window-flag
 124                              (selected-window)
 125                            (current-buffer)) ,tag-set)
 126     (set-face-background 'default ,bg
 127                          (if bc-per-window-flag
 128                              (selected-window)
 129                            (current-buffer)) ,tag-set)))
 130
 131
 132 (defun bc-set-buffer-fgbg (fg bg tag-set)
 133   "Sets the colors of the current buffer to `FG'/`BG'.
 134 This specifier will be associated with `TAG-SET'.
 135 For the more general function, see `bc-set-fgbg'"
 136   (let ((bc-per-window-flag nil))
 137     (bc-set-fgbg fg bg tag-set)))
 138
 139
 140 (defmacro bc-equal-fgbg-p (fg bg)
 141   "Checks if new `FG'/`BG' are same as current fg/bg."
 142   `(and (equal ,fg (color-instance-name (face-foreground-instance 'default)))
 143     (equal ,bg (color-instance-name (face-background-instance 'default)))))
 144
 145
 146 (defun bc-add-fgbg-combination (&optional fg bg)
 147   "Adds a foreground/background pair to Buffer Colors menu.
 148 And applies this selection to current buffer.."
 149   (when (not fg)
 150     (setq fg (facemenu-read-color "Foreground Color Name? :")))
 151   (when (not bg)
 152     (setq bg (facemenu-read-color "Background Color Name? :")))
 153   (setq bc-buffer-color-combos (append bc-buffer-color-combos
 154                                        (list (cons (downcase fg)
 155                                                    (downcase bg)))))
 156   (bc-refresh-buffer-color-menu)
 157   (bc-set-fgbg fg bg 'buffer-colors))
 158
 159
 160 (defun bc-delete-fgbg (fg bg)
 161   "Removes an entry from buffer colors menu."
 162   (delete (cons fg bg) bc-buffer-color-combos)
 163   (bc-refresh-buffer-color-menu))
 164
 165 ;;;###autoload
 166 (defun bc-refresh-buffer-color-menu ()
 167   "Refreshes buffer color menu from buffer-color-combos."
 168   (setq bc-fgbg-menu `("Buffer Colors"
 169                        ,@(bc-generate-select-menu)
 170                        ("Settings"
 171                         ["Use Windows Instead of Buffers"
 172                          (if bc-per-window-flag
 173                              (setq bc-per-window-flag nil)
 174                            (setq bc-per-window-flag t))
 175                          :style toggle
 176                          :selected bc-per-window-flag]
 177                         ["New Colors On Bottom Of List"
 178                          (progn
 179                            (if bc-new-colors-at-bottom-flag
 180                                (setq bc-new-colors-at-bottom-flag nil)
 181                              (setq bc-new-colors-at-bottom-flag t))
 182                            (bc-refresh-buffer-color-menu))
 183                          :style toggle
 184                          :selected bc-new-colors-at-bottom-flag]
 185                         ["Customize Buffer Colors..."
 186                          (customize-group 'buffer-colors)])
 187                        ("Custom Buffer Colors"
 188                         ["Show all colors..." list-colors-display]
 189                         ["Define Custom FG/BG" (bc-add-fgbg-combination)]
 190                         ["Store current list" (bc-write-current-fgbg)]
 191                         ("Delete colors from list"
 192                          ,@(bc-generate-delete-menu)))
 193                        ["Reset Buffer to Defaults" (bc-clear-current-fgbg)]
 194                        ["Reset All to Defaults" (bc-clear-all-fgbg)]))
 195   (add-submenu '("Buffers") bc-fgbg-menu "List All Buffers"))
 196
 197
 198 (defun bc-clear-current-fgbg ()
 199   "Removes any buffer color specification from the current buffer."
 200   (remove-specifier (face-foreground 'default) (current-buffer) 'buffer-colors)
 201   (remove-specifier (face-background 'default) (current-buffer) 'buffer-colors)
 202   (remove-specifier (face-foreground 'default) (selected-window) 'buffer-colors)
 203   (remove-specifier (face-background 'default) (selected-window) 'buffer-colors))
 204
 205
 206 (defun bc-clear-all-fgbg ()
 207   "Removes all buffer color specifications from all buffers."
 208   (loop for buffer being each buffer
 209     do
 210     (remove-specifier (face-foreground 'default) buffer 'buffer-colors)
 211     (remove-specifier (face-background 'default) buffer 'buffer-colors))
 212   (loop for window being each window
 213     do
 214     (remove-specifier (face-foreground 'default) window 'buffer-colors)
 215     (remove-specifier (face-background 'default) window 'buffer-colors)))
 216
 217 ;;;###autoload
 218 (defun bc-enable-behavior ()
 219   "Enables Buffer Color package
 220 By Default, this is done at load time."
 221   (add-hook 'after-save-hook 'bc-remove-read-only-tags)
 222   (add-hook 'find-file-hooks 'bc-evaluate-color-tests)
 223   (bc-refresh-buffer-color-menu)
 224   (add-menu-button '("Buffers") "---" "List All Buffers"))
 225
 226
 227 ;;;###autoload
 228 (defun bc-disable-behavior ()
 229   "Disables Buffer Color package.
 230 This removes the Buffer Color control menu and all currently colored buffers."
 231   (bc-clear-all-fgbg)
 232   (delete-menu-item '("Buffers" "Buffer Colors"))
 233   (delete-menu-item '("Buffers" "---"))
 234   (remove-hook 'after-save-hook 'bc-remove-read-only-tags)
 235   (remove-hook 'find-file-hooks 'bc-evaluate-color-tests))
 236
 237 ;;;###autoload
 238 (defun bc-toggle-behavior ()
 239   (interactive)
 240   (if (behavior-enabled-p 'buffer-colors)
 241       (disable-behavior 'buffer-colors)
 242     (enable-behavior 'buffer-colors)))
 243
 244 ;;;###autoload
 245 (defun bc-toggle-no-behavior ()
 246   (interactive)
 247   (if bc-buffer-colors-enabled-p
 248       (bc-disable-behavior)
 249     (bc-enable-behavior))
 250   (setq bc-buffer-colors-enabled-p (not bc-buffer-colors-enabled-p)))
 251
 252
 253 (defun bc-write-current-fgbg ()
 254   "Writes buffer colors menu to file"
 255   (custom-save-all))
 256
 257 (defun bc-generate-select-menu ()
 258   "Returns a list of fg/bg entries for buffer color menu"
 259   (let ((temp (if bc-new-colors-at-bottom-flag
 260                   (reverse bc-buffer-color-combos)
 261                 bc-buffer-color-combos))
 262         (menu-list nil))
 263     (while temp
 264       (let ((fg (caar temp))
 265             (bg (cdar temp)))
 266         (setq menu-list
 267               (cons `[,(concat (capitalize fg) " on " (capitalize bg))
 268                       (bc-set-fgbg ,fg ,bg 'buffer-colors)
 269                       :style radio
 270                       :selected (bc-equal-fgbg-p ,fg ,bg)] menu-list))
 271         (setq temp (cdr temp))))
 272     menu-list))
 273
 274 (defun bc-generate-delete-menu ()
 275   "Returns a list of fg/bg entries for delete buffer color menu"
 276   (let ((temp (if bc-new-colors-at-bottom-flag
 277                   (reverse bc-buffer-color-combos) bc-buffer-color-combos))
 278         (menu-list nil))
 279     (while temp
 280       (let ((fg (caar temp))
 281             (bg (cdar temp)))
 282         (setq menu-list
 283               (cons `[
 284                       ,(concat "Delete " (capitalize fg) " on " (capitalize bg))
 285                       (bc-delete-fgbg ,fg ,bg) ]
 286                     menu-list))
 287         (setq temp (cdr temp))))
 288     menu-list))
 289
 290 (defun bc-remove-read-only-tags ()
 291   (remove-specifier (face-foreground 'default) (current-buffer) 'bc-read-only)
 292   (remove-specifier (face-background 'default) (current-buffer) 'bc-read-only))
 293
 294 (defun bc-evaluate-color-tests ()
 295   "Evaluates color tests to find the initial colors for a new buffer."
 296   (loop for (enabledp predicate fg bg tag-set) in bc-file-color-tests
 297     do
 298     (when (and enabledp (funcall predicate))
 299       (when tag-set
 300         (unless (listp tag-set)
 301           (setq tag-set (list tag-set))))
 302       (bc-set-buffer-fgbg fg bg (cons 'buffer-colors tag-set)))))
 303
 304
 305
 306
 307 ;;;;---  create a customization group and variables for a customize buffer ---
 308 ;;;###autoload
 309 (defgroup buffer-colors nil
 310   "A system for easily modifying default foreground and backgrounds of buffers.")
 311
 312
 313 ;; define new widget so in a customize buffer we can validate a user-input color name.
 314 ;; validates both string names and rgb Hex codes for colors.
 315 ;;;###autoload
 316 (define-widget 'color 'string
 317   "A widget for entering displayable color names.
 318 Accepts either names or direct hex-codes (#rrggbb or #rrrrggggbbbb)."
 319   :validate (lambda (widget)
 320               (if (or (string-match "^#[0-9a-f]\\{6,6\\}\\([0-9a-f]\\{6,6\\}\\)?$" (widget-value widget))
 321                       (member (widget-value widget) (color-list)))
 322                   nil
 323                 (widget-put widget :error (concat (widget-value widget) " is not a valid color name."))))
 324
 325   :tag "Color"
 326   :prompt-value (lambda (widget prompt value unbound)
 327                   (read-color prompt nil (unless unbound value))))
 328
 329 ;; this variable controls whether the buffer colors follow windows or buffers.
 330 ;; if the colors follow by buffer, the buffer contents stay that color no matter which
 331 ;; windows the buffer is displayed in.
 332 ;; if the colors follow the window, then the window will stay those colors no matter
 333 ;; which buffer is displayed in that window.
 334 ;;;###autoload
 335 (defcustom bc-per-window-flag nil
 336   "Scope of color assignments. Colors can follow current window or current buffer."
 337   :tag "Buffer color scope"
 338   :group 'buffer-colors
 339   :initialize 'custom-initialize-default
 340   :set (lambda (symbol value)
 341          (set-default symbol value)
 342          (bc-refresh-buffer-color-menu))
 343   :type '(choice :tag "Colors follow"
 344           (const :tag "Buffer" nil)
 345           (const :tag "Window" t)))
 346
 347
 348 ;; by default, additional color pairs are put in the top of the menu list.
 349 ;; this variable adds additional color pairs at the bottom of the menu list instead.
 350 ;;;###autoload
 351 (defcustom bc-new-colors-at-bottom-flag nil
 352   "Sorting direction for Buffer Colors menu"
 353   :tag "Buffer Colors menu sort direction"
 354   :group 'buffer-colors
 355   :initialize 'custom-initialize-default
 356   :set (lambda (symbol value)
 357          (set-default symbol value)
 358          (bc-refresh-buffer-color-menu))
 359   :type '(choice :tag "Buffer Colors menu is sorted from"
 360           (const :tag "Newest to Oldest" nil)
 361           (const :tag "Oldest to Newest" t)))
 362
 363
 364
 365 ;; list of a few foreground/background color pairs to start out with.
 366 ;; usually only used the first time the program is run.
 367 ;; as soon as some fg/bg pairs are defined and saved in custom.el,
 368 ;; they are loaded instead of these.
 369 ;;;###autoload
 370 (defcustom bc-buffer-color-combos '(("black" . "white")
 371                                     ("white" . "black")
 372                                     ("green" . "black")
 373                                     ("yellow" . "black")
 374                                     ("lightgoldenrod" . "sandybrown")
 375                                     ("orchid" . "mediumvioletred")
 376                                     ("deepskyblue" . "saddlebrowwn")
 377                                     ("yellowgreen" . "darkslategrey")
 378                                     ("slateblue" . "cornflowerblue")
 379                                     ("yellow" . "navyblue")
 380                                     ("darkslategrey" . "coral"))
 381   "Foreground/background pairs for default buffer text.
 382 These will show up on the Buffers->Buffer Colors menu."
 383   :group 'buffer-colors
 384   :initialize 'custom-initialize-default
 385   :set (lambda (symbol value)
 386          (set-default symbol value)
 387          (bc-refresh-buffer-color-menu))
 388   :type '(repeat (cons :tag "Menu entry"
 389                        (color :tag "Foreground")
 390                        (color :tag "Background"))))
 391
 392
 393 ;; a list of rules to start out with.  They can be individualy disabled
 394 ;; and as soon as more are added, and saved in custom.el, those are loaded
 395 ;; instead of this list.
 396 ;;;###autoload
 397 (defcustom bc-file-color-tests '((t bc-read-only-p "tomato" "black" (bc-read-only))
 398                                  (t bc-c-file-p "mediumspringgreen" "black" nil)
 399                                  (t bc-h-file-p "mediumspringgreen" "navy" nil)
 400                                  (t bc-el-file-p "PaleGreen" "black" nil))
 401   "A list of rules for coloring new buffers.
 402 If a Predicate evaluates to non-nil, the associated color pair will be
 403 applied to the new buffer.  Predicate will be evaluated in the new
 404 buffer, so buffer-local variables (eg `buffer-file-name') will be
 405 correct.
 406 The last matching rule is used."
 407   :group 'buffer-colors
 408   :type '(repeat (list :tag "Rule"
 409                        :extra-offset 4
 410                        (choice :tag "This rule is"
 411                                (const :tag "Enabled" t)
 412                                (const :tag "Disabled" nil))
 413                        (symbol :tag "Predicate")
 414                        (string :tag "Foreground")
 415                        (string :tag "Background")
 416                        (choice :tag "Tag-set"
 417                                (const :tag "None" nil)
 418                                (repeat :tag "List" (symbol
 419                                                     :tag "Tag"
 420                                                     :value bc-read-only))))))
 421
 422 ;;;;--- start up code ----------------------------------------------
 423 ;;;###autoload
 424 (unless (featurep 'buffer-colors)
 425   (when (boundp 'current-menubar)
 426     (add-menu-button '("Options" "Display")
 427                      "---"))) ;add a separator only first time loaded
 428
 429 ;;;###autoload
 430 (when (boundp 'current-menubar)
 431   (if (functionp 'define-behavior)
 432       (add-menu-button '("Options" "Display")
 433                        [ "Buffer Colors" bc-toggle-behavior
 434                          :style toggle
 435                          :selected (behavior-enabled-p 'buffer-colors)])
 436     (add-menu-button '("Options" "Display")
 437                      [ "Buffer Colors" bc-toggle-no-behavior
 438                        :style toggle
 439                        :selected bc-buffer-colors-enabled-p])))
 440
 441
 442 (provide 'buffer-colors)
 443
 444 ;;; end of buffer-colors.el
 445