;;; bc-menu.el ;;; Copyright (C) 2011 Byrel Mitchell and Steve Mitchell ;;; email: smitchel@bnin.net ;;; email: byrel.mitchell@gmail.com ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3, or (at your option) ;;; any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; ;;; ;;; Description: ;;; ;;; A menu system for setting buffer local face colors. ;;; Allows adding and removing menu entries, and storage of permanent custom colors. ;;; ;;; Afer the first time it runs, on startup, it loads a list of colors from custom.el. ;;; if none found, it creates a list of a few colors to start out with. Thereafter ;;; we keep a list in custom.el of all fg/bg pairs and load that list each time. ;;; ;;; These color changes are by default "by the buffer" (no matter the window or pane it is ;;; displayed in). It can also be set so the color changes will follow a window ;;; (no matter what buffer is displayed there) ;;; Easy to choose between these 2 methods either on the menu or in a customize buffer: ;;; M-x customize-group buffer-colors ;;; ;;; There is also a list of "rules" to colorize new buffers, based on things we can know ;;; about the file, such as read-only, or filename extension, or date-modified, etc. ;;; ;;; Purpose is to have an easy at-hand way to change buffer colors ;;; instead of a full customize buffer, making it easy to: ;;; -ease eye strain--change hourly, daily or as lighting conditions change. ;;; -On a 30" monitor I often have 3-4 buffers open and this helps me keep ;;; straight which file is which--especially when source code and file names ;;; are very, very similar between files. ;;; -organize buffers by catagory: ;;; have one fg/bg color pair for files that you load for referance ;;; have a fg/bg color you use for read only files ;;; have a fg/bg color you use for your try-out buffer ;;; have a fr/bg color for open emails, another pair for replies ;;; Four example "rules" are pre-programmed in, you can remove or reorder ;;; these, or add new rules. Anything you know about a file can be used ;;; to create a "rule" to decide how to colorize files when loading them. ;;; (after they are loaded, and colorized then, you can still change the ;;; colors at any time through either the Buffer Colors menu or ;;; through a customize buffer (under the Buffer Colors menu-->settings). ;;; ;;; Adds a toggle turn buffer colors on/off: Options-->Display-->Buffer Colors ;;; Adds a selection to the Buffers Menu: Buffer Colors. ;;; What it does: ;;; 1. Lets you specify foreground and background colors ;;; differently for each buffer on the fly. ;;; 2. Lets you set new combinations of fg/bg colors ;;; and save the list of colors to disk. ;;; 3. Displays a list in a buffer of valid colors ;;; with their names, for you to refer to. ;;; 3. Creates a file buffercolors.el in your ~/.xemacs directory, ;;; for storing fg/bg colors for the predefined choices on the menu. ;;; 4. All code is in the file buffer-color-menu.el, ;;; All settings are saved in custom.el ;;; ;;; TODO ;;; This implements buffer-colors as a behavior. Currently it needs enabled each session, ;;; by toggling Options-->Display-->Buffer-Colors ;;; We need to find a way to have it on by default. ;;; (define-specifier-tag 'buffer-colors) (define-specifier-tag 'bc-read-only) (defvar bc-fgbg-menu nil "Menu for Buffer Colors") ;; the behaviour lets us ;; disable Buffer Colors, ;; remove the Buffer Colors menu item, ;; and delete all previously set buffer colors, ;; restoring them to the colors in the default face. (define-behavior 'buffer-colors "A system for quickly changing the fg and bg colors of buffers. It includes a rule-based system for coloring new buffers." :enable 'bc-enable-behavior :disable 'bc-disable-behavior) ;;---- functions for rules ---------------------------------------- (defun bc-read-only-p () "Return t if current buffer is read only." buffer-read-only) (defun bc-c-file-p () "Return t if buffer file name ends in .c or .cpp." (string-match "\\.c\\(pp\\)?$" buffer-file-name)) (defun bc-h-file-p () "Return t if buffer file name ends in .h." (string-match "\\.h$" buffer-file-name)) (defun bc-el-file-p () "Return t if buffer file name ends in .el." (string-match "\\.el$" buffer-file-name)) (defmacro bc-set-fgbg (fg bg tag-set) "Sets the fg/bg properties of the default face for the current buffer locale." `(progn (set-face-foreground 'default ,fg (if bc-per-window-flag (selected-window) (current-buffer)) ,tag-set) (set-face-background 'default ,bg (if bc-per-window-flag (selected-window) (current-buffer)) ,tag-set))) (defun bc-set-buffer-fgbg (fg bg tag-set) "Sets the colors of the current buffer to `FG'/`BG'. This specifier will be associated with `TAG-SET'. For the more general function, see `bc-set-fgbg'" (let ((bc-per-window-flag nil)) (bc-set-fgbg fg bg tag-set))) (defmacro bc-equal-fgbg-p (fg bg) "Checks if new `FG'/`BG' are same as current fg/bg." `(and (equal ,fg (color-instance-name (face-foreground-instance 'default))) (equal ,bg (color-instance-name (face-background-instance 'default))))) (defun bc-add-fgbg-combination (&optional fg bg) "Adds a foreground/background pair to Buffer Colors menu. And applies this selection to current buffer.." (when (not fg) (setq fg (facemenu-read-color "Foreground Color Name? :"))) (when (not bg) (setq bg (facemenu-read-color "Background Color Name? :"))) (setq bc-buffer-color-combos (append bc-buffer-color-combos (list (cons (downcase fg) (downcase bg))))) (bc-refresh-buffer-color-menu) (bc-set-fgbg fg bg 'buffer-colors)) (defun bc-delete-fgbg (fg bg) "Removes an entry from buffer colors menu." (delete (cons fg bg) bc-buffer-color-combos) (bc-refresh-buffer-color-menu)) ;;;###autoload (defun bc-refresh-buffer-color-menu () "Refreshes buffer color menu from buffer-color-combos." (setq bc-fgbg-menu `("Buffer Colors" ,@(bc-generate-select-menu) ("Settings" ["Use Windows Instead of Buffers" (if bc-per-window-flag (setq bc-per-window-flag nil) (setq bc-per-window-flag t)) :style toggle :selected bc-per-window-flag] ["New Colors On Bottom Of List" (progn (if bc-new-colors-at-bottom-flag (setq bc-new-colors-at-bottom-flag nil) (setq bc-new-colors-at-bottom-flag t)) (bc-refresh-buffer-color-menu)) :style toggle :selected bc-new-colors-at-bottom-flag] ["Customize Buffer Colors..." (customize-group 'buffer-colors)]) ("Custom Buffer Colors" ["Show all colors..." list-colors-display] ["Define Custom FG/BG" (bc-add-fgbg-combination)] ["Store current list" (bc-write-current-fgbg)] ("Delete colors from list" ,@(bc-generate-delete-menu))) ["Reset Buffer to Defaults" (bc-clear-current-fgbg)] ["Reset All to Defaults" (bc-clear-all-fgbg)])) (add-submenu '("Buffers") bc-fgbg-menu "List All Buffers")) (defun bc-clear-current-fgbg () "Removes any buffer color specification from the current buffer." (remove-specifier (face-foreground 'default) (current-buffer) 'buffer-colors) (remove-specifier (face-background 'default) (current-buffer) 'buffer-colors) (remove-specifier (face-foreground 'default) (selected-window) 'buffer-colors) (remove-specifier (face-background 'default) (selected-window) 'buffer-colors)) (defun bc-clear-all-fgbg () "Removes all buffer color specifications from all buffers." (loop for buffer being each buffer do (remove-specifier (face-foreground 'default) buffer 'buffer-colors) (remove-specifier (face-background 'default) buffer 'buffer-colors)) (loop for window being each window do (remove-specifier (face-foreground 'default) window 'buffer-colors) (remove-specifier (face-background 'default) window 'buffer-colors))) ;;;###autoload (defun bc-enable-behavior () "Enables Buffer Color package By Default, this is done at load time." (add-hook 'after-save-hook 'bc-remove-read-only-tags) (add-hook 'find-file-hooks 'bc-evaluate-color-tests) (bc-refresh-buffer-color-menu) (add-menu-button '("Buffers") "---" "List All Buffers")) ;;;###autoload (defun bc-disable-behavior () "Disables Buffer Color package. This removes the Buffer Color control menu and all currently colored buffers." (bc-clear-all-fgbg) (delete-menu-item '("Buffers" "Buffer Colors")) (delete-menu-item '("Buffers" "---")) (remove-hook 'after-save-hook 'bc-remove-read-only-tags) (remove-hook 'find-file-hooks 'bc-evaluate-color-tests)) ;;;###autoload (defun bc-toggle-behavior () (interactive) (if (behavior-enabled-p 'buffer-colors) (disable-behavior 'buffer-colors) (enable-behavior 'buffer-colors))) (defun bc-write-current-fgbg () "Writes buffer colors menu to file" (custom-save-all)) (defun bc-generate-select-menu () "Returns a list of fg/bg entries for buffer color menu" (let ((temp (if bc-new-colors-at-bottom-flag (reverse bc-buffer-color-combos) bc-buffer-color-combos)) (menu-list nil)) (while temp (let ((fg (caar temp)) (bg (cdar temp))) (setq menu-list (cons `[,(concat (capitalize fg) " on " (capitalize bg)) (bc-set-fgbg ,fg ,bg 'buffer-colors) :style radio :selected (bc-equal-fgbg-p ,fg ,bg)] menu-list)) (setq temp (cdr temp)))) menu-list)) (defun bc-generate-delete-menu () "Returns a list of fg/bg entries for delete buffer color menu" (let ((temp (if bc-new-colors-at-bottom-flag (reverse bc-buffer-color-combos) bc-buffer-color-combos)) (menu-list nil)) (while temp (let ((fg (caar temp)) (bg (cdar temp))) (setq menu-list (cons `[ ,(concat "Delete " (capitalize fg) " on " (capitalize bg)) (bc-delete-fgbg ,fg ,bg) ] menu-list)) (setq temp (cdr temp)))) menu-list)) (defun bc-remove-read-only-tags () (remove-specifier (face-foreground 'default) (current-buffer) 'bc-read-only) (remove-specifier (face-background 'default) (current-buffer) 'bc-read-only)) (defun bc-evaluate-color-tests () "Evaluates color tests to find the initial colors for a new buffer." (loop for (enabledp predicate fg bg tag-set) in bc-file-color-tests do (when (and enabledp (funcall predicate)) (when tag-set (unless (listp tag-set) (setq tag-set (list tag-set)))) (bc-set-buffer-fgbg fg bg (cons 'buffer-colors tag-set))))) ;;;;--- create a customization group and variables for a customize buffer --- (defgroup buffer-colors nil "A system for easily modifying default foreground and backgrounds of buffers.") ;; define new widget so in a customize buffer we can validate a user-input color name. ;; validates both string names and rgb Hex codes for colors. (define-widget 'color 'string "A widget for entering displayable color names. Accepts either names or direct hex-codes (#rrggbb or #rrrrggggbbbb)." :validate (lambda (widget) (if (or (string-match "^#[0-9a-f]\\{6,6\\}\\([0-9a-f]\\{6,6\\}\\)?$" (widget-value widget)) (member (widget-value widget) (color-list))) nil (widget-put widget :error (concat (widget-value widget) " is not a valid color name.")))) :tag "Color" :prompt-value (lambda (widget prompt value unbound) (read-color prompt nil (unless unbound value)))) ;; this variable controls whether the buffer colors follow windows or buffers. ;; if the colors follow by buffer, the buffer contents stay that color no matter which ;; windows the buffer is displayed in. ;; if the colors follow the window, then the window will stay those colors no matter ;; which buffer is displayed in that window. (defcustom bc-per-window-flag nil "Scope of color assignments. Colors can follow current window or current buffer." :tag "Buffer color scope" :group 'buffer-colors :initialize 'custom-initialize-default :set (lambda (symbol value) (set-default symbol value) (bc-refresh-buffer-color-menu)) :type '(choice :tag "Colors follow" (const :tag "Buffer" nil) (const :tag "Window" t))) ;; by default, additional color pairs are put in the top of the menu list. ;; this variable adds additional color pairs at the bottom of the menu list instead. (defcustom bc-new-colors-at-bottom-flag nil "Sorting direction for Buffer Colors menu" :tag "Buffer Colors menu sort direction" :group 'buffer-colors :initialize 'custom-initialize-default :set (lambda (symbol value) (set-default symbol value) (bc-refresh-buffer-color-menu)) :type '(choice :tag "Buffer Colors menu is sorted from" (const :tag "Newest to Oldest" nil) (const :tag "Oldest to Newest" t))) ;; list of a few foreground/background color pairs to start out with. ;; usually only used the first time the program is run. ;; as soon as some fg/bg pairs are defined and saved in custom.el, ;; they are loaded instead of these. (defcustom bc-buffer-color-combos '(("black" . "white") ("white" . "black") ("green" . "black") ("yellow" . "black")) "Foreground/background pairs for default buffer text. These will show up on the Buffers->Buffer Colors menu." :group 'buffer-colors :initialize 'custom-initialize-default :set (lambda (symbol value) (set-default symbol value) (bc-refresh-buffer-color-menu)) :type '(repeat (cons :tag "Menu entry" (color :tag "Foreground") (color :tag "Background")))) ;; a list of rules to start out with. They can be individualy disabled ;; and as soon as more are added, and saved in custom.el, those are loaded ;; instead of this list. (defcustom bc-file-color-tests '((t bc-read-only-p "tomato" "black" (bc-read-only)) (t bc-c-file-p "mediumspringgreen" "black" nil) (t bc-h-file-p "mediumspringgreen" "navy" nil) (t bc-el-file-p "PaleGreen" "black" nil)) "A list of rules for coloring new buffers. If a Predicate evaluates to non-nil, the associated color pair will be applied to the new buffer. Predicate will be evaluated in the new buffer, so buffer-local variables (eg `buffer-file-name') will be correct. The last matching rule is used." :group 'buffer-colors :type '(repeat (list :tag "Rule" :extra-offset 4 (choice :tag "This rule is" (const :tag "Enabled" t) (const :tag "Disabled" nil)) (symbol :tag "Predicate") (string :tag "Foreground") (string :tag "Background") (choice :tag "Tag-set" (const :tag "None" nil) (repeat :tag "List" (symbol :tag "Tag" :value bc-read-only)))))) ;;;;--- start up code ---------------------------------------------- ;;;###autoload( add-menu-button '("Options" "Display") "---") ;add a separator ;;;###autoload( add-menu-button '("Options" "Display") [ "Buffer Colors" bc-toggle-behavior :style toggle :selected (behavior-enabled-p 'buffer-colors) ]) ;;; Autoloads to be removed for build version: (add-menu-button '("Options" "Display") "---") ;add a separator (add-menu-button '("Options" "Display") [ "Buffer Colors" bc-toggle-behavior :style toggle :selected (behavior-enabled-p 'buffer-colors) ]) ;;; end of bc-menu.el