Source

edit-utils / buffer-colors.el

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
;;; buffer-colors.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.
;;;
(require 'menubar)  ;contains add-menu-button
(require 'wid-edit) ;contains widget-value

(define-specifier-tag 'buffer-colors)

(define-specifier-tag 'bc-read-only)

(defvar bc-fgbg-menu nil "Menu for Buffer Colors")
(defvar bc-buffer-colors-enabled-p nil
  "Is buffer-colors currently loaded.
This variable is used on systems without behavior functionality to keep track of whether buffer-colors is currently loaded.")

;; 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.  
(when (functionp 'define-behavior)
  (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)))

;;;###autoload
(defun bc-toggle-no-behavior ()
  (interactive)
  (if bc-buffer-colors-enabled-p
      (bc-disable-behavior)
    (bc-enable-behavior))
  (setq bc-buffer-colors-enabled-p (not bc-buffer-colors-enabled-p)))
	

(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 ---
;;;###autoload
(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.
;;;###autoload
(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. 
;;;###autoload
(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.
;;;###autoload
(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.
;;;###autoload
(defcustom bc-buffer-color-combos '(("black" . "white")
				    ("white" . "black")
				    ("green" . "black")
				    ("yellow" . "black")
				    ("lightgoldenrod" . "sandybrown")
				    ("orchid" . "mediumvioletred")
				    ("deepskyblue" . "saddlebrowwn")
				    ("yellowgreen" . "darkslategrey")
				    ("slateblue" . "cornflowerblue")
				    ("yellow" . "navyblue")
				    ("darkslategrey" . "coral"))
  "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.
;;;###autoload
(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
(unless (featurep 'buffer-colors)
  (when (boundp 'current-menubar) 
    (add-menu-button '("Options" "Display")
		     "---"))) ;add a separator only first time loaded

;;;###autoload
(when (boundp 'current-menubar) 
  (if (functionp 'define-behavior)
      (add-menu-button '("Options" "Display")
		       [ "Buffer Colors" bc-toggle-behavior
			 :style toggle
			 :selected (behavior-enabled-p 'buffer-colors)])
    (add-menu-button '("Options" "Display")
		     [ "Buffer Colors" bc-toggle-no-behavior
		       :style toggle
		       :selected bc-buffer-colors-enabled-p])))


(provide 'buffer-colors)

;;; end of buffer-colors.el