[bpt/emacs.git] / lisp / cus-theme.el

;;; cus-theme.el -- custom theme creation user interface
;;
;; Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
;;
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: FSF
;; Keywords: help, faces

;; This file is part of GNU Emacs.

;; GNU Emacs 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 2, or (at your option)
;; any later version.

;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Code:

(require 'widget)
(require 'cus-edit)

(eval-when-compile
  (require 'wid-edit))

(defvar custom-new-theme-mode-map
  (let ((map (make-keymap)))
    (set-keymap-parent map widget-keymap)
    (suppress-keymap map)
    (define-key map "n" 'widget-forward)
    (define-key map "p" 'widget-backward)
    (define-key map [mouse-1] 'widget-move-and-invoke)
    map)
  "Keymap for `custom-new-theme-mode'.")

(define-derived-mode custom-new-theme-mode nil "New-Theme"
  "Major mode for the buffer created by `customize-create-theme'.
Do not call this mode function yourself.  It is only meant for internal
use by `customize-create-theme'."
  (use-local-map custom-new-theme-mode-map)
  (define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke)
  (set (make-local-variable 'widget-documentation-face) 'custom-documentation)
  (set (make-local-variable 'widget-button-face) custom-button)
  (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
  (set (make-local-variable 'widget-mouse-face) custom-button-mouse)
  (when custom-raised-buttons
    (set (make-local-variable 'widget-push-button-prefix) "")
    (set (make-local-variable 'widget-push-button-suffix) "")
    (set (make-local-variable 'widget-link-prefix) "")
    (set (make-local-variable 'widget-link-suffix) "")))
(put 'custom-new-theme-mode 'mode-class 'special)

(defvar custom-theme-name)
(defvar custom-theme-variables)
(defvar custom-theme-faces)
(defvar custom-theme-description)

;;;###autoload
(defun customize-create-theme ()
  "Create a custom theme."
  (interactive)
  (if (get-buffer "*New Custom Theme*")
      (kill-buffer "*New Custom Theme*"))
  (switch-to-buffer "*New Custom Theme*")
  (let ((inhibit-read-only t))
    (erase-buffer))
  (custom-new-theme-mode)
  (make-local-variable 'custom-theme-name)
  (make-local-variable 'custom-theme-variables)
  (make-local-variable 'custom-theme-faces)
  (make-local-variable 'custom-theme-description)
  (widget-insert "This buffer helps you write a custom theme elisp file.
This will help you share your customizations with other people.

Just insert the names of all variables and faces you want the theme
to include.  Then clicking mouse-2 or pressing RET on the [Done] button
will write a theme file that sets all these variables and faces to their
current global values.  It will write that file into the directory given
by the variable `custom-theme-directory', usually \"~/.emacs.d/\".

To undo all your edits to the buffer, use the [Reset] button.\n\n")
  (widget-insert "Theme name: ")
  (setq custom-theme-name
	(widget-create 'editable-field
		       :size 10
		       user-login-name))
  (widget-insert "\n\nDocumentation:\n")
  (setq custom-theme-description
	(widget-create 'text
		       :value (format-time-string "Created %Y-%m-%d.")))
  (widget-insert "\nVariables:\n\n")
  (setq custom-theme-variables
     	(widget-create 'editable-list
     		       :entry-format "%i %d %v"
		       'variable))
  (widget-insert "\nFaces:\n\n")
  (setq custom-theme-faces
     	(widget-create 'editable-list
     		       :entry-format "%i %d %v"
		       'face))
  (widget-insert "\n")
  (widget-create 'push-button
     		 :notify (function custom-theme-write)
     		 "Done")
  (widget-insert " ")
  (widget-create 'push-button
     		 :notify (lambda (&rest ignore)
     			   (customize-create-theme))
     		 "Reset")
  (widget-insert " ")
  (widget-create 'push-button
     		 :notify (lambda (&rest ignore)
     			   (bury-buffer))
     		 "Bury Buffer")
  (widget-insert "\n")
  (widget-setup))

(defun custom-theme-write (&rest ignore)
  (let ((name (widget-value custom-theme-name))
	(doc (widget-value custom-theme-description))
	(variables (widget-value custom-theme-variables))
	(faces (widget-value custom-theme-faces)))
    (switch-to-buffer (concat name "-theme.el"))
    (emacs-lisp-mode)
    (unless (file-exists-p custom-theme-directory)
      (make-directory (file-name-as-directory custom-theme-directory) t))
    (setq default-directory custom-theme-directory)
    (setq buffer-file-name (expand-file-name (concat name "-theme.el")))
    (let ((inhibit-read-only t))
      (erase-buffer))
    (insert "(deftheme " name)
    (when doc
      (newline)
      (insert "  \"" doc "\""))
    (insert  ")\n")
    (custom-theme-write-variables name variables)
    (custom-theme-write-faces name faces)
    (insert "\n(provide-theme '" name ")\n")
    (save-buffer)))

(defun custom-theme-write-variables (theme vars)
  "Write a `custom-theme-set-variables' command for THEME.
It includes all variables in list VARS."
  ;; Most code is stolen from `custom-save-variables'.
  (when vars
    (let ((standard-output (current-buffer)))
      (princ "\n(custom-theme-set-variables\n")
      (princ " '")
      (princ theme)
      (princ "\n")
      (mapc (lambda (symbol)
	      (when (boundp symbol)
		(unless (bolp)
		  (princ "\n"))
		(princ " '(")
		(prin1 symbol)
		(princ " ")
		(prin1 (custom-quote (symbol-value symbol)))
		(princ ")")))
	      vars)
      (if (bolp)
	  (princ " "))
      (princ ")")
      (unless (looking-at "\n")
	(princ "\n")))))

(defun custom-theme-write-faces (theme faces)
  "Write a `custom-theme-set-faces' command for THEME.
It includes all faces in list FACES."
  (when faces
    (let ((standard-output (current-buffer)))
      (princ "\n(custom-theme-set-faces\n")
      (princ " '")
      (princ theme)
      (princ "\n")
      (mapc (lambda (symbol)
	      (when (facep symbol)
		(unless (bolp)
		  (princ "\n"))
		(princ " '(")
		(prin1 symbol)
		(princ " ")
		(prin1 (list (append '(t)
				     (custom-face-attributes-get
				      'font-lock-comment-face nil))))
		(princ ")")))
	      faces)
      (if (bolp)
	  (princ " "))
      (princ ")")
      (unless (looking-at "\n")
	(princ "\n")))))

;;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
;;; cus-theme.el ends here
Commit	Line	Data
3656dac0 RS	1	;;; cus-theme.el -- custom theme creation user interface
3656dac0 RS	2	;;
0d30b337	3	;; Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3656dac0 RS	4	;;
	5	;; Author: Alex Schroeder <alex@gnu.org>
	6	;; Maintainer: FSF
	7	;; Keywords: help, faces
	8
	9	;; This file is part of GNU Emacs.
	10
	11	;; GNU Emacs is free software; you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
	13	;; the Free Software Foundation; either version 2, or (at your option)
	14	;; any later version.
	15
	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
	22	;; along with GNU Emacs; see the file COPYING. If not, write to the
086add15 LK	23	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
086add15 LK	24	;; Boston, MA 02110-1301, USA.
3656dac0 RS	25
	26	;;; Code:
	27
	28	(require 'widget)
	29	(require 'cus-edit)
	30
	31	(eval-when-compile
	32	(require 'wid-edit))
	33
bdeaa675	34	(defvar custom-new-theme-mode-map
bdeaa675 CY	35	(let ((map (make-keymap)))
	36	(set-keymap-parent map widget-keymap)
	37	(suppress-keymap map)
	38	(define-key map "n" 'widget-forward)
	39	(define-key map "p" 'widget-backward)
	40	(define-key map [mouse-1] 'widget-move-and-invoke)
	41	map)
	42	"Keymap for `custom-new-theme-mode'.")
	43
077ad61c LT	44	(define-derived-mode custom-new-theme-mode nil "New-Theme"
	45	"Major mode for the buffer created by `customize-create-theme'.
	46	Do not call this mode function yourself. It is only meant for internal
	47	use by `customize-create-theme'."
bdeaa675 CY	48	(use-local-map custom-new-theme-mode-map)
bdeaa675 CY	49	(define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke)
8314bdb8 CY	50	(set (make-local-variable 'widget-documentation-face) 'custom-documentation)
	51	(set (make-local-variable 'widget-button-face) custom-button)
	52	(set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
85a5eb0e	53	(set (make-local-variable 'widget-mouse-face) custom-button-mouse)
8314bdb8 CY	54	(when custom-raised-buttons
	55	(set (make-local-variable 'widget-push-button-prefix) "")
	56	(set (make-local-variable 'widget-push-button-suffix) "")
	57	(set (make-local-variable 'widget-link-prefix) "")
	58	(set (make-local-variable 'widget-link-suffix) "")))
077ad61c LT	59	(put 'custom-new-theme-mode 'mode-class 'special)
	60
	61	(defvar custom-theme-name)
	62	(defvar custom-theme-variables)
	63	(defvar custom-theme-faces)
	64	(defvar custom-theme-description)
	65
87e391a9	66	;;;###autoload
f560e69c	67	(defun customize-create-theme ()
3656dac0 RS	68	"Create a custom theme."
	69	(interactive)
	70	(if (get-buffer "New Custom Theme")
	71	(kill-buffer "New Custom Theme"))
	72	(switch-to-buffer "New Custom Theme")
077ad61c LT	73	(let ((inhibit-read-only t))
	74	(erase-buffer))
	75	(custom-new-theme-mode)
3656dac0 RS	76	(make-local-variable 'custom-theme-name)
	77	(make-local-variable 'custom-theme-variables)
	78	(make-local-variable 'custom-theme-faces)
	79	(make-local-variable 'custom-theme-description)
3656dac0	80	(widget-insert "This buffer helps you write a custom theme elisp file.
077ad61c LT	81	This will help you share your customizations with other people.
	82
	83	Just insert the names of all variables and faces you want the theme
	84	to include. Then clicking mouse-2 or pressing RET on the [Done] button
	85	will write a theme file that sets all these variables and faces to their
	86	current global values. It will write that file into the directory given
	87	by the variable `custom-theme-directory', usually \"~/.emacs.d/\".
	88
	89	To undo all your edits to the buffer, use the [Reset] button.\n\n")
3656dac0 RS	90	(widget-insert "Theme name: ")
	91	(setq custom-theme-name
	92	(widget-create 'editable-field
	93	:size 10
	94	user-login-name))
	95	(widget-insert "\n\nDocumentation:\n")
	96	(setq custom-theme-description
71296446	97	(widget-create 'text
3656dac0 RS	98	:value (format-time-string "Created %Y-%m-%d.")))
	99	(widget-insert "\nVariables:\n\n")
	100	(setq custom-theme-variables
	101	(widget-create 'editable-list
	102	:entry-format "%i %d %v"
	103	'variable))
	104	(widget-insert "\nFaces:\n\n")
	105	(setq custom-theme-faces
	106	(widget-create 'editable-list
	107	:entry-format "%i %d %v"
	108	'face))
	109	(widget-insert "\n")
	110	(widget-create 'push-button
	111	:notify (function custom-theme-write)
	112	"Done")
	113	(widget-insert " ")
	114	(widget-create 'push-button
	115	:notify (lambda (&rest ignore)
392cb21b	116	(customize-create-theme))
3656dac0 RS	117	"Reset")
	118	(widget-insert " ")
	119	(widget-create 'push-button
	120	:notify (lambda (&rest ignore)
	121	(bury-buffer))
	122	"Bury Buffer")
	123	(widget-insert "\n")
3656dac0 RS	124	(widget-setup))
	125
	126	(defun custom-theme-write (&rest ignore)
	127	(let ((name (widget-value custom-theme-name))
	128	(doc (widget-value custom-theme-description))
	129	(variables (widget-value custom-theme-variables))
	130	(faces (widget-value custom-theme-faces)))
	131	(switch-to-buffer (concat name "-theme.el"))
077ad61c LT	132	(emacs-lisp-mode)
	133	(unless (file-exists-p custom-theme-directory)
	134	(make-directory (file-name-as-directory custom-theme-directory) t))
	135	(setq default-directory custom-theme-directory)
3656dac0 RS	136	(setq buffer-file-name (expand-file-name (concat name "-theme.el")))
	137	(let ((inhibit-read-only t))
	138	(erase-buffer))
	139	(insert "(deftheme " name)
	140	(when doc
	141	(newline)
	142	(insert " \"" doc "\""))
	143	(insert ")\n")
	144	(custom-theme-write-variables name variables)
	145	(custom-theme-write-faces name faces)
077ad61c LT	146	(insert "\n(provide-theme '" name ")\n")
077ad61c LT	147	(save-buffer)))
3656dac0 RS	148
	149	(defun custom-theme-write-variables (theme vars)
	150	"Write a `custom-theme-set-variables' command for THEME.
	151	It includes all variables in list VARS."
	152	;; Most code is stolen from `custom-save-variables'.
	153	(when vars
	154	(let ((standard-output (current-buffer)))
	155	(princ "\n(custom-theme-set-variables\n")
	156	(princ " '")
	157	(princ theme)
	158	(princ "\n")
	159	(mapc (lambda (symbol)
	160	(when (boundp symbol)
	161	(unless (bolp)
	162	(princ "\n"))
	163	(princ " '(")
	164	(prin1 symbol)
	165	(princ " ")
bbeb3055	166	(prin1 (custom-quote (symbol-value symbol)))
3656dac0 RS	167	(princ ")")))
	168	vars)
	169	(if (bolp)
	170	(princ " "))
	171	(princ ")")
	172	(unless (looking-at "\n")
	173	(princ "\n")))))
	174
	175	(defun custom-theme-write-faces (theme faces)
	176	"Write a `custom-theme-set-faces' command for THEME.
	177	It includes all faces in list FACES."
	178	(when faces
	179	(let ((standard-output (current-buffer)))
	180	(princ "\n(custom-theme-set-faces\n")
	181	(princ " '")
	182	(princ theme)
	183	(princ "\n")
	184	(mapc (lambda (symbol)
	185	(when (facep symbol)
	186	(unless (bolp)
	187	(princ "\n"))
	188	(princ " '(")
	189	(prin1 symbol)
	190	(princ " ")
79a0aa11 CY	191	(prin1 (list (append '(t)
	192	(custom-face-attributes-get
	193	'font-lock-comment-face nil))))
3656dac0 RS	194	(princ ")")))
	195	faces)
	196	(if (bolp)
	197	(princ " "))
	198	(princ ")")
	199	(unless (looking-at "\n")
	200	(princ "\n")))))
	201
ab5796a9	202	;;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
3656dac0	203	;;; cus-theme.el ends here