Download
(require 'widget)
(eval-when-compile
(require 'wid-edit))
(require 'color-theme)
(defvar color-theme-maker-regexp nil)
(defvar color-theme-maker-name nil)
(defun color-theme-maker ()
"Interactively create color subthemes.
Based on the faces currently defined, produce a color theme function
that sets only the faces matching a regexp."
(interactive)
(switch-to-buffer "*Color Theme Maker*")
(kill-all-local-variables)
(make-local-variable 'color-theme-maker-regexp)
(make-local-variable 'color-theme-maker-name)
(let ((inhibit-read-only t))
(erase-buffer)
(widget-insert
"Welcome to the Color Theme Maker\n"
"\n"
"The Regexp will be used to filter all faces currently defined.\n"
"\n"
"Regexp: ")
(setq color-theme-maker-regexp (widget-create 'editable-field))
(widget-insert
"\n\n"
"The name determines what the resulting color theme function will be called.\n"
"\n"
"Name: ")
(setq color-theme-maker-name (widget-create 'editable-field))
(widget-insert "\n")
(widget-create
'push-button
:notify (lambda (&rest ignore)
(color-theme-maker-print (widget-value color-theme-maker-regexp)
(widget-value color-theme-maker-name)))
"Done"))
(use-local-map widget-keymap)
(widget-setup)
(goto-char (point-min))
(widget-forward 1))
(defun color-theme-maker-print (regexp func-name)
"Create a color theme function FUNC-NAME with faces matching REGEXP."
(message "Making subtheme...")
(let ((faces (color-theme-filter (color-theme-get-faces) regexp)))
(unless faces
(error "No faces match %s" regexp))
(let ((buf (get-buffer-create (concat func-name ".el"))))
(switch-to-buffer buf)
(let ((inhibit-read-only t))
(erase-buffer)
(insert "(defun " func-name " ()\n"
" \"Color subtheme, created " (format-time-string "%Y-%m-%d") ".\"\n"
" (interactive)\n"
" (color-theme-install\n"
" '(" func-name " nil nil")
(when faces (insert "\n "))
(dolist (face faces)
(when (= (preceding-char) ?\))
(insert "\n "))
(prin1 (color-theme-spec face) (current-buffer))))))
(insert ")))\n"
"(provide '" func-name ")")
(emacs-lisp-mode)
(goto-char (point-min))
(message "Making subtheme... done"))
(provide 'color-theme-maker)