# HG changeset patch # User Luke Hoersten # Date 1372127966 18000 # Node ID d4adcd3d5ef9009bdd41063bc334d25a5d03680b # Parent e1b82f67f96ee168ba7589fb2ba1f1d5da4f39b6 Updated to emacs24 with package management and load-theme diff -r e1b82f67f96e -r d4adcd3d5ef9 .hgignore --- a/.hgignore Sat Jun 22 22:54:53 2013 -0500 +++ b/.hgignore Mon Jun 24 21:39:26 2013 -0500 @@ -1,8 +1,6 @@ syntax: regexp -yasnippet\/ -nav\/ -url\/ - +^url\/ +^elpa\/ \.elc$ ~$ \#.*\#$ diff -r e1b82f67f96e -r d4adcd3d5ef9 haskell-init.el --- a/haskell-init.el Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -;; ~/.emacs.d/haskell-init.el -;; Luke Hoersten - -(add-to-list 'load-path "~/.emacs.d/thirdparty/haskell-mode/") -(require 'haskell-mode-autoloads) - -;; (add-to-list 'load-path "~/.emacs.d/thirdparty/haskell-mode") ; override haskell mode on system -;;(add-to-list 'load-path "~/.cabal/share/ghc-mod-2.0.2") ; load ghc-mod from cabal -;; (autoload 'ghc-init "~/.emacs.d/thirdparty/ghc-mod-2.0.2/ghc" nil t) - -;; (load "haskell-site-file") - -;; ;; scion -;; (if (file-exists-p "~/.cabal/share/scion-0.3/emacs/scion.el") -;; (progn -;; (add-to-list 'load-path "~/.cabal/share/scion-0.3/emacs") -;; (require 'scion) -;; (setq scion-program "~/.cabal/bin/scion-server") -;; (add-hook -;; 'haskell-mode-hook -;; (lambda () -;; (scion-mode 1) -;; (scion-flycheck-on-save 1) -;; (setq scion-completing-read-function 'ido-completing-read))))) - -(add-hook - 'haskell-mode-hook - (lambda () - ;; (ghc-init) - (turn-on-haskell-indent) - (capitalized-words-mode) - (turn-on-haskell-doc-mode) - (turn-on-haskell-decl-scan) - (imenu-add-menubar-index) - (setq - haskell-font-lock-haddock t - haskell-stylish-on-save t - ;; haskell-tags-on-save t - haskell-program-name "ghci" - haskell-indent-offset 4 - whitespace-line-column 78) - )) - -(message "Loading haskell-init...done") -(provide 'haskell-init) diff -r e1b82f67f96e -r d4adcd3d5ef9 init.el --- a/init.el Sat Jun 22 22:54:53 2013 -0500 +++ b/init.el Mon Jun 24 21:39:26 2013 -0500 @@ -40,7 +40,10 @@ ;;; Darwin (if (string-match "darwin" (emacs-version)) (progn - (setq-default mac-command-modifier 'meta))) + (setq-default + mac-command-modifier 'meta + ns-pop-up-frames nil + ispell-program-name "/usr/local/bin/aspell"))) ;;; Xorg (if window-system @@ -75,8 +78,8 @@ ;;;; Mode-Specific ;;;; ;;; text-mode -(add-hook 'fundamental-mode-hook 'flyspell-mode t) ; spellcheck text -(add-hook 'fundamental-mode-hook 'turn-on-auto-fill) ; autofill text +(add-hook 'fundamental-mode-hook 'flyspell-mode t) ; spellcheck text +(add-hook 'fundamental-mode-hook 'turn-on-auto-fill) ; autofill text ;;; ido-mode (ido-mode t) ; file/buffer selector @@ -128,43 +131,60 @@ (ibuffer-switch-to-saved-filter-groups "default"))) -;;;; Requires ;;;; +;;;; Requires and Packages ;;;; -(add-to-list 'load-path "~/.emacs.d/thirdparty") ; set default third party path - -;;; language init +;;; custom inits (require 'c-init) ; c specific elisp -(require 'haskell-init) ; haskell specific elisp -(require 'color-theme-init) ; color theme specific elisp -(require 'rainbow-delimiters) ; multi-colored parens - -;;; function init (require 'align-with-spaces) ; use only spaces for alignment (require 'pastebin-region) ; send selected text to pastebin (require 'move-line) ; move line up or down +(require 'uniquify) ; unique buffer names with dirs + +;;; uniquify +(setq + uniquify-buffer-name-style 'post-forward + uniquify-separator ":") + +;;; packages +(package-initialize) +(add-to-list 'package-archives '("melpa" . "http://melpa.milkbox.net/packages/") t) +(add-to-list 'package-archives '("marmalade" . "http://marmalade-repo.org/packages/") t) + +;; install +(let ((ensure-installed + (lambda (name) + (unless (package-installed-p name) (package-install name)))) + (packages + '(flymake-haskell-multi ghc ghci-completion haskell-mode js2-mode + rainbow-delimiters rainbow-mode scion solarized-theme + yasnippet zencoding-mode))) + (mapc ensure-installed packages)) + +;;; color-theme +(setq-default + custom-safe-themes + '("8aebf25556399b58091e533e455dd50a6a9cba958cc4ebb0aab175863c25b9a4" + "d677ef584c6dfc0697901a44b885cc18e206f05114c8a3b7fde674fce6180879" default)) +(load-theme 'solarized-light) ;;; yasnippets -(add-to-list 'load-path "~/.emacs.d/thirdparty/yasnippet") -(require 'yasnippet) (setq-default yas-prompt-functions '(yas-ido-prompt yas-dropdown-prompt)) ; use ido for multiple snippets -(setq-default yas-snippet-dirs '("~/.emacs.d/thirdparty/yasnippet/snippets" - "~/.emacs.d/thirdparty/snippets")) +(setq-default yas-snippet-dirs + '("~/.emacs.d/thirdparty/yasnippet/snippets" + "~/.emacs.d/thirdparty/snippets")) (yas-global-mode t) ;;; java-mode (add-hook 'java-mode-hook (lambda () (setq whitespace-line-column 140))) +;;; js2-mode +(add-to-list 'auto-mode-alist '("\\.js$" . js2-mode)) +(add-hook 'js-mode-hook 'js2-minor-mode) + ;;; zencoding-mode - html -(require 'zencoding-mode) (add-hook 'sgml-mode-hook 'zencoding-mode) ; Auto-start on any markup modes (add-to-list 'auto-mode-alist '("\\.tpl\\'" . html-mode)) -;;; unique buffer names with dirs -(require 'uniquify) -(setq - uniquify-buffer-name-style 'post-forward - uniquify-separator ":") - ;;; coding-modes map (mapc (lambda (x) @@ -176,3 +196,22 @@ haskell-mode-hook clojure-mode-hook emacs-lisp-mode-hook)) + +;;; haskell-mode +(add-hook + 'haskell-mode-hook + (lambda () + ;; (ghc-init) + (turn-on-haskell-indent) + (capitalized-words-mode) + (turn-on-haskell-doc-mode) + (turn-on-haskell-decl-scan) + (imenu-add-menubar-index) + (setq + haskell-font-lock-haddock t + haskell-stylish-on-save t + ;; haskell-tags-on-save t + haskell-program-name "ghci" + haskell-indent-offset 4 + whitespace-line-column 78) + )) diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/color-theme-solarized/LICENSE --- a/thirdparty/color-theme-solarized/LICENSE Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -Copyright (c) 2011 Ethan Schoonover - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. - diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/color-theme-solarized/README.md --- a/thirdparty/color-theme-solarized/README.md Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,163 +0,0 @@ -Solarized Colorscheme for Emacs -=============================== - -Stolen from Ethan Schoonover by Greg Pfeil - -Visit the [Solarized homepage] ------------------------------- - -See the [Solarized homepage] for screenshots, -details and colorscheme versions for Vim, Mutt, popular terminal emulators and -other applications. - -Screenshots ------------ - -![solarized dark](https://github.com/altercation/solarized/raw/master/img/solarized-vim.png) - -Downloads ---------- - -If you have come across this colorscheme via the [Emacs-only repository] on -github, see the link above to the Solarized homepage or visit the main [Solarized repository]. - -The [Emacs-only repository] is kept in sync with the main [Solarized repository]. Issues, bug reports, changelogs that are not specific to the Emacs implementation should be submitted to the main [Solarized repository]. - -[Solarized homepage]: http://ethanschoonover.com/solarized -[Solarized repository]: https://github.com/altercation/solarized -[Emacs-only repository]: https://github.com/sellout/emacs-color-theme-solarized -[color-theme]: http://www.nongnu.org/color-theme - -Installation & Usage --------------------- - -### Emacs 24 - -1. Add the `emacs-color-theme-solarized` directory to your Emacs `custom-theme-load-path`. -2. Add `(load-theme solarized-[light|dark] t)` to your Emacs init file. -3. Reload the init file, or restart Emacs. - -### [color-theme] \(pre-Emacs 24\) - -1. Download and install [color-theme]. -2. Add the `emacs-color-theme-solarized` directory to your Emacs `load-path`. -3. Add `(require 'color-theme-solarized)` to your Emacs init file (usually `~/.emacs`). -3. Reload the init file, or restart Emacs. -4. Use the usual [color-theme] mechanism to select one of the Solarized themes, or `M-x color-theme-solarized-[light|dark]`. - -### IMPORTANT NOTE FOR TERMINAL USERS: - -If you are going to use Solarized in Terminal mode (i.e. not in a GUI version -like Cocoa or X11 Emacs), **please please please** consider setting your -terminal emulator's colorscheme to use the Solarized palette. The [Solarized -repository] includes palettes for some popular terminal emulator as well as -Xdefaults; or you can download them from the official [Solarized homepage]. -If you use this emacs color theme *without* having changed your emulator's -palette, you will need to configure Solarized to degrade its colorscheme to -a set compatible with the terminal's default limited 256 color palette -(whereas by using the terminal's 16 ANSI color values, you would -see the correct, specific values for the Solarized palette). - -If you do use the custom terminal colors, i.e. the 16 overridden ANSI color -values, the emacs colorscheme should work out of the box for you. If you are -using a terminal emulator that supports 256 colors and don't want to use -the custom Solarized terminal colors, you will need to use the degraded 256 -colorscheme. To do so, simply customize the `solarized-termcolor` variable to -`256`. - -Again, I recommend just changing your terminal colors to Solarized values -either manually or via one of the many terminal schemes available for import. - -Advanced Configuration ----------------------- - -Solarized will work out of the box with just the instructions specified above -but does include several variables that can be customized. - - variable name default optional - -------------------------------------------- - solarized-termcolors = 16 | 256 - solarized-degrade = nil | t - solarized-bold = t | nil - solarized-underline = t | nil - solarized-italic = t | nil - solarized-contrast = normal| high, low - solarized-visibility = normal| high, low - solarized-broken-srgb= nil | t (see details for Mac behavior) - -------------------------------------------- - -### Option Details - -* solarized-termcolors - - This is set to *16* by default, meaning that Solarized will attempt to use - the standard 16 colors of your terminal emulator, assuming that you've set - these colors to the correct Solarized values either manually or by - importing one of the many colorscheme available for popular terminal - emulators and Xdefaults. - If you don't want to use the Solarized colors via the terminal - emulator's palette, you can set this to *256*, which will use a degraded - version of the Solarized palette by displaying the closest colors in - the terminal's default 256 colors as shown in [Xterm's color - chart](http://en.wikipedia.org/wiki/File:Xterm_color_chart.png). - -* solarized-degrade - - For test purposes only; in GUI mode, this forces Solarized to use the 256 - degraded color mode to test the approximate color values for accuracy. - -* solarized-bold | solarized-underline | solarized-italic - - If you wish to stop Solarized from displaying bold, underlined or - italicized typefaces, simply set the appropriate variable to `nil`. - -* solarized-contrast - - Stick with normal! It's been carefully tested. Setting this option to high - or low does use the same Solarized palette but simply shifts some values - up or down in order to expand or compress the tonal range displayed. - -* solarized-visibility - - Special characters such as trailing whitespace, tabs, newlines, when - displayed using `:set list` can be set to one of three levels depending on - your needs. Default value is `normal` with `high` and `low` options. - -* solarized-broken-srgb - - Emacs [bug #8402](http://debbugs.gnu.org/cgi/bugreport.cgi?bug=8402) - results in incorrect color handling on Macs. If this is `t` (the default - on Macs), Solarized works around it with alternative colors. However, - these colors are not totally portable, so you may be able to edit the - "Gen RGB" column in `solarized-definitions.el` to improve them further. - -Code Notes ----------- - -I have attempted to modularize the creation of Emacs colorschemes in this script and, while it could be refactored further, it should be a good foundation for the creation of any color scheme. By simply changing the values in the `solarized-colors` table in `solarized-definitions.el` and testing in a GUI Emacs, you can rapidly prototype new colorschemes without diving into the weeds of line-item editing each syntax highlight declaration. - -The Values ----------- - -L\*a\*b values are canonical (White D65, Reference D50), other values are -matched in sRGB space. - - SOLARIZED HEX 16/8 TERMCOL XTERM/HEX L*A*B RGB HSB - --------- ------- ---- ------- ----------- ---------- ----------- ----------- - base03 #002b36 8/4 brblack 234 #1c1c1c 15 -12 -12 0 43 54 193 100 21 - base02 #073642 0/4 black 235 #262626 20 -12 -12 7 54 66 192 90 26 - base01 #586e75 10/7 brgreen 240 #585858 45 -07 -07 88 110 117 194 25 46 - base00 #657b83 11/7 bryellow 241 #626262 50 -07 -07 101 123 131 195 23 51 - base0 #839496 12/6 brblue 244 #808080 60 -06 -03 131 148 150 186 13 59 - base1 #93a1a1 14/4 brcyan 245 #8a8a8a 65 -05 -02 147 161 161 180 9 63 - base2 #eee8d5 7/7 white 254 #e4e4e4 92 -00 10 238 232 213 44 11 93 - base3 #fdf6e3 15/7 brwhite 230 #ffffd7 97 00 10 253 246 227 44 10 99 - yellow #b58900 3/3 yellow 136 #af8700 60 10 65 181 137 0 45 100 71 - orange #cb4b16 9/3 brred 166 #d75f00 50 50 55 203 75 22 18 89 80 - red #dc322f 1/1 red 160 #d70000 50 65 45 220 50 47 1 79 86 - magenta #d33682 5/5 magenta 125 #af005f 50 65 -05 211 54 130 331 74 83 - violet #6c71c4 13/5 brmagenta 61 #5f5faf 50 15 -45 108 113 196 237 45 77 - blue #268bd2 4/4 blue 33 #0087ff 55 -10 -45 38 139 210 205 82 82 - cyan #2aa198 6/6 cyan 37 #00afaf 60 -35 -05 42 161 152 175 74 63 - green #859900 2/2 green 64 #5f8700 60 -20 65 133 153 0 68 100 60 - diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/color-theme-solarized/color-theme-solarized-pkg.el --- a/thirdparty/color-theme-solarized/color-theme-solarized-pkg.el Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -(define-package "color-theme-solarized" "%%version%%" "Solarized themes for Emacs" '((color-theme "6.6.1"))) diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/color-theme-solarized/color-theme-solarized.el --- a/thirdparty/color-theme-solarized/color-theme-solarized.el Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,56 +0,0 @@ -;;; Author: Ethan Schoonover, Solarized; Greg Pfeil, Emacs adaptation -;;; URL: http://ethanschoonover.com/solarized - -;;; This file is not (YET) part of GNU Emacs. - -;;; # Usage - -;;; 1. Install the color-theme package -;;; (http://www.emacswiki.org/cgi-bin/wiki/ColorTheme) -;;; 2. Load this file -;;; 3. M-x color-theme-solarized-[dark|light] - -(require 'solarized-definitions - (let* ((reqname (concat (file-name-directory (or load-file-name - buffer-file-name)) - "solarized-definitions.el")) - (compreqname (concat reqname "c"))) - (if (file-exists-p compreqname) compreqname reqname))) - -(eval-when-compile - (require 'color-theme)) - -;;;###autoload -(defun color-theme-solarized (mode) - "Color theme by Ethan Schoonover, created 2011-03-24. -Ported to Emacs by Greg Pfeil, http://ethanschoonover.com/solarized." - (interactive "Slight or dark? ") - (color-theme-install - (let* ((definitions (solarized-color-definitions mode)) - (faces (first definitions)) - (variables (second definitions))) - (solarized-color-definitions mode) - `(,(intern (concat "color-theme-solarized-" (symbol-name mode))) - ,variables - ,@faces)))) - -;;;###autoload -(defun color-theme-solarized-dark () - (interactive) - (color-theme-solarized 'dark)) - -;;;###autoload -(defun color-theme-solarized-light () - (interactive) - (color-theme-solarized 'light)) - -(add-to-list 'color-themes - `(color-theme-solarized-light - "Solarized Light" - ,solarized-description)) -(add-to-list 'color-themes - `(color-theme-solarized-dark - "Solarized Dark" - ,solarized-description)) - -(provide 'color-theme-solarized) diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/color-theme-solarized/makepkg.sh --- a/thirdparty/color-theme-solarized/makepkg.sh Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -#!/usr/bin/env bash - -version=$1 - -if [ "$version" = "" ]; then - version=$(date -u '+%Y%m%d') -fi -echo "version = $version" - -dir="color-theme-solarized-${version}" - -mkdir $dir - -cp *.el $dir -sed -i "s/%%version%%/$version/" "$dir/color-theme-solarized-pkg.el" - -tar cf color-theme-solarized-${version}.tar $dir diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/color-theme-solarized/solarized-dark-theme.el --- a/thirdparty/color-theme-solarized/solarized-dark-theme.el Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -(require 'solarized-definitions - (locate-file "solarized-definitions.el" custom-theme-load-path - '("c" ""))) - -(create-solarized-theme dark) diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/color-theme-solarized/solarized-definitions.el --- a/thirdparty/color-theme-solarized/solarized-definitions.el Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,426 +0,0 @@ -(eval-when-compile - (require 'cl)) - -(defconst solarized-description - "Color theme by Ethan Schoonover, created 2011-03-24. -Ported to Emacs by Greg Pfeil, http://ethanschoonover.com/solarized.") - -(defcustom solarized-degrade nil - "For test purposes only; when in GUI mode, forces Solarized to use the 256 -degraded color mode to test the approximate color values for accuracy." - :type 'boolean - :group 'solarized) - -(defcustom solarized-diff-mode 'normal - "Sets the level of highlighting to use in diff-like modes." - :type 'symbol - :options '(high normal low) - :group 'solarized) - -(defcustom solarized-bold t - "Stops Solarized from displaying bold when nil." - :type 'boolean - :group 'solarized) - -(defcustom solarized-underline t - "Stops Solarized from displaying underlines when nil." - :type 'boolean - :group 'solarized) - -(defcustom solarized-italic t - "Stops Solarized from displaying italics when nil." - :type 'boolean - :group 'solarized) - -(defcustom solarized-termcolors 16 - "This setting applies to emacs in terminal (non-GUI) mode. -If set to 16, emacs will use the terminal emulator's colorscheme (best option -as long as you've set your emulator's colors to the Solarized palette). If -set to 256 and your terminal is capable of displaying 256 colors, emacs will -use the 256 degraded color mode." - :type 'integer - :options '(16 256) - :group 'solarized) - -(defcustom solarized-contrast 'normal - "Stick with normal! It's been carefully tested. Setting this option to high or -low does use the same Solarized palette but simply shifts some values up or -down in order to expand or compress the tonal range displayed." - :type 'symbol - :options '(high normal low) - :group 'solarized) - -(defcustom solarized-broken-srgb (if (eq system-type 'darwin) t nil) - "Emacs bug #8402 results in incorrect color handling on Macs. If this is t -(the default on Macs), Solarized works around it with alternative colors. -However, these colors are not totally portable, so you may be able to edit -the \"Gen RGB\" column in solarized-definitions.el to improve them further." - :type 'boolean - :group 'solarized) - -;; FIXME: The Generic RGB colors will actually vary from device to device, but -;; hopefully these are closer to the intended colors than the sRGB values -;; that Emacs seems to dislike -(defvar solarized-colors - ;; name sRGB Gen RGB degraded ANSI(Solarized terminal) - '((base03 "#002b36" "#042028" "#1c1c1c" "#7f7f7f") - (base02 "#073642" "#0a2832" "#262626" "#000000") - (base01 "#586e75" "#465a61" "#585858" "#00ff00") - (base00 "#657b83" "#52676f" "#626262" "#ffff00") - (base0 "#839496" "#708183" "#808080" "#5c5cff") - (base1 "#93a1a1" "#81908f" "#8a8a8a" "#00ffff") - (base2 "#eee8d5" "#e9e2cb" "#e4e4e4" "#e5e5e5") - (base3 "#fdf6e3" "#fcf4dc" "#ffffd7" "#ffffff") - (yellow "#b58900" "#a57705" "#af8700" "#cdcd00") - (orange "#cb4b16" "#bd3612" "#d75f00" "#ff0000") - (red "#dc322f" "#c60007" "#d70000" "#cd0000") - (magenta "#d33682" "#c61b6e" "#af005f" "#cd00cd") - (violet "#6c71c4" "#5859b7" "#5f5faf" "#ff00ff") - (blue "#268bd2" "#2075c7" "#0087ff" "#0000ee") - (cyan "#2aa198" "#259185" "#00afaf" "#00cdcd") - (green "#859900" "#728a05" "#5f8700" "#00cd00")) - "This is a table of all the colors used by the Solarized color theme. Each - column is a different set, one of which will be chosen based on term - capabilities, etc.") - -(defun solarized-color-definitions (mode) - (flet ((find-color (name) - (let ((index (if window-system - (if solarized-degrade - 3 - (if solarized-broken-srgb 2 1)) - (if (= solarized-termcolors 256) - 3 - 4)))) - (nth index (assoc name solarized-colors))))) - (let ((base03 (find-color 'base03)) - (base02 (find-color 'base02)) - (base01 (find-color 'base01)) - (base00 (find-color 'base00)) - (base0 (find-color 'base0)) - (base1 (find-color 'base1)) - (base2 (find-color 'base2)) - (base3 (find-color 'base3)) - (yellow (find-color 'yellow)) - (orange (find-color 'orange)) - (red (find-color 'red)) - (magenta (find-color 'magenta)) - (violet (find-color 'violet)) - (blue (find-color 'blue)) - (cyan (find-color 'cyan)) - (green (find-color 'green)) - (bold (if solarized-bold 'bold 'normal)) - (bright-bold (if solarized-bold 'normal 'bold)) - (underline (if solarized-underline t nil)) - (opt-under nil) - (italic (if solarized-italic 'italic 'normal))) - (when (eq 'light mode) - (rotatef base03 base3) - (rotatef base02 base2) - (rotatef base01 base1) - (rotatef base00 base0)) - (let ((back base03)) - (cond ((eq 'high solarized-contrast) - (let ((orig-base3 base3)) - (rotatef base01 base00 base0 base1 base2 base3) - (setf base3 orig-base3))) - ((eq 'low solarized-contrast) - (setf back base02 - opt-under t))) - (let ((bg-back `(:background ,back)) - (bg-base03 `(:background ,base03)) - (bg-base02 `(:background ,base02)) - (bg-base01 `(:background ,base01)) - (bg-base00 `(:background ,base00)) - (bg-base0 `(:background ,base0)) - (bg-base1 `(:background ,base1)) - (bg-base2 `(:background ,base2)) - (bg-base3 `(:background ,base3)) - (bg-green `(:background ,green)) - (bg-yellow `(:background ,yellow)) - (bg-orange `(:background ,orange)) - (bg-red `(:background ,red)) - (bg-magenta `(:background ,magenta)) - (bg-violet `(:background ,violet)) - (bg-blue `(:background ,blue)) - (bg-cyan `(:background ,cyan)) - - (fg-base03 `(:foreground ,base03)) - (fg-base02 `(:foreground ,base02)) - (fg-base01 `(:foreground ,base01)) - (fg-base00 `(:foreground ,base00)) - (fg-base0 `(:foreground ,base0)) - (fg-base1 `(:foreground ,base1)) - (fg-base2 `(:foreground ,base2)) - (fg-base3 `(:foreground ,base3)) - (fg-green `(:foreground ,green)) - (fg-yellow `(:foreground ,yellow)) - (fg-orange `(:foreground ,orange)) - (fg-red `(:foreground ,red)) - (fg-magenta `(:foreground ,magenta)) - (fg-violet `(:foreground ,violet)) - (fg-blue `(:foreground ,blue)) - (fg-cyan `(:foreground ,cyan)) - - (fmt-bold `(:weight ,bold)) - (fmt-bldi `(:weight ,bold)) - (fmt-undr `(:underline ,underline)) - (fmt-undb `(:underline ,underline :weight ,bold)) - (fmt-undi `(:underline ,underline)) - (fmt-uopt `(:underline ,opt-under)) - (fmt-curl `(:underline t)) ; FIXME: not quite the same - (fmt-ital `(:slant ,italic)) - (fmt-stnd `(:inverse-video t)) ; FIXME: not quite the same - (fmt-revr `(:inverse-video t)) - (fmt-revb `(:inverse-video t :weight ,bold)) - (fmt-revbb `(:inverse-video t :weight ,bright-bold)) - (fmt-revbbu `(:inverse-video t - :weight ,bright-bold - :underline ,underline))) - `((;; basic - (default ((t (,@fg-base0 ,@bg-back)))) ; Normal - (cursor ((t (,@fg-base03 ,@bg-base0)))) ; Cursor - (escape-glyph-face ((t (,@fg-red)))) - (fringe ((t (,@fg-base01 ,@bg-base02)))) - (linum ((t (,@fg-base01 ,@bg-base02)))) - (header-line ((t (,@fg-base0 ,@bg-base2)))) - (highlight ((t (,@bg-base02)))) - - (hl-line ((t (,@fmt-uopt ,@bg-base02)))) ; CursorLine - (isearch ((t (,@fmt-stnd ,@fg-orange)))) ; IncSearch - (lazy-highlight ((t (,@bg-base2 ,@fg-base00)))) - (link ((t (,@fmt-undr ,@fg-violet)))) - (link-visited ((t (,@fmt-undr ,@fg-magenta)))) - (menu ((t (,@fg-base0 ,@bg-base02)))) - (minibuffer-prompt ((t (,@fg-blue)))) - (mode-line - ((t (,@fg-base1 ,@bg-base02 :box (:line-width 1 :color ,base1))))) - (mode-line-buffer-id ((t (,@fg-base1)))) - (mode-line-inactive - ((t (,@fg-base0 ,@bg-base02 - :box (:line-width 1 :color ,base02))))) - (region ((t (,@fg-base01 ,@bg-base03 ,@fmt-revbb)))) ; Visual - (secondary-selection ((t (,@bg-base02)))) - (shadow ((t (,@fg-base01)))) - (trailing-whitespace ((t (,@fmt-revr ,@fg-red)))) - (vertical-border ((t (,@fg-base0)))) - ;; comint - (comint-highlight-prompt ((t (,@fg-blue)))) - ;; compilation - (compilation-info ((t (,@fmt-bold ,@fg-green)))) - (compilation-warning ((t (,@fmt-bold ,@fg-orange)))) - ;; custom - (custom-button - ((t (,@fg-base1 ,@bg-base02 - :box (:line-width 2 :style released-button))))) - (custom-button-mouse - ((t (,@fmt-revr ,@fg-base1 ,@bg-base02 :inherit custom-button)))) - (custom-button-pressed - ((t (,@fmt-revr ,@fg-base1 ,@bg-base02 - :box (:line-width 2 :style pressed-button) - :inherit custom-button-mouse)))) - (custom-changed ((t (,@fmt-revr ,@fg-blue ,@bg-base3)))) - (custom-comment ((t (,@fg-base1 ,@bg-base02)))) - (custom-comment-tag ((t (,@fg-base1 ,@bg-base02)))) - (custom-documentation ((t (:inherit default)))) - (custom-group-tag ((t (,@fg-base1)))) - (custom-group-tag-1 ((t (,fmt-bold ,@fg-base1)))) - (custom-invalid ((t (,@fmt-revr ,@fg-red ,@bg-back)))) - (custom-link ((t (,@fg-violet)))) - (custom-state ((t (,@fg-green)))) - (custom-variable-tag ((t (,@fg-base1)))) - ;; diff - DiffAdd, DiffChange, DiffDelete, and DiffText - ,@(case solarized-diff-mode - (high - `((diff-added ((t (,@fmt-revr ,@fg-green)))) - (diff-changed ((t (,@fmt-revr ,@fg-yellow)))) - (diff-removed ((t (,@fmt-revr ,@fg-red)))) - (diff-header ((t (,@fmt-revr ,@fg-blue ,@bg-back)))))) - (low - `((diff-added ((t (,@fmt-undr ,@fg-green)))) - (diff-changed ((t (,@fmt-undr ,@fg-yellow)))) - (diff-removed ((t (,@fmt-bold ,@fg-red)))) - (diff-header ((t (,@fmt-undr ,@fg-blue ,@bg-back)))))) - (normal - (if window-system - `((diff-added ((t (,@fmt-bold ,@fg-green)))) - (diff-changed ((t (,@fmt-bold ,@fg-yellow)))) - (diff-removed ((t (,@fmt-bold ,@fg-red)))) - (diff-header ((t (,@fmt-bold ,@fg-blue ,@bg-back))))) - `((diff-added ((t (,@fg-green)))) - (diff-changed ((t (,@fg-yellow)))) - (diff-removed ((t (,@fg-red)))) - (diff-header ((t (,@fg-blue ,@bg-back)))))))) - (diff-file-header ((t (,@bg-back)))) - (diff-refine-change ((t (,@bg-base3)))) - ;; IDO - (ido-only-match ((t (,@fg-green)))) - (ido-subdir ((t (,@fg-blue)))) - (ido-first-match ((t (,@fmt-bold ,@fg-green)))) - ;; emacs-wiki - (emacs-wiki-bad-link-face ((t (,@fmt-undr ,@fg-red)))) - (emacs-wiki-link-face ((t (,@fmt-undr ,@fg-blue)))) - (emacs-wiki-verbatim-face ((t (,@fmt-undr ,@fg-base00)))) - ;; eshell - (eshell-ls-archive ((t (,@fg-magenta)))) - (eshell-ls-backup ((t (,@fg-yellow)))) - (eshell-ls-clutter ((t (,@fg-orange)))) - (eshell-ls-directory ((t (,@fg-blue)))) - (eshell-ls-executable ((t (,@fg-green)))) - (eshell-ls-missing ((t (,@fg-red)))) - (eshell-ls-product ((t (,@fg-yellow)))) - (eshell-ls-readonly ((t (,@fg-base1)))) - (eshell-ls-special ((t (,@fg-violet)))) - (eshell-ls-symlink ((t (,@fg-cyan)))) - (eshell-ls-unreadable ((t (,@fg-base00)))) - (eshell-prompt ((t (,@fmt-bold ,@fg-green)))) - ;; font-lock - (font-lock-builtin-face ((t (,@fg-green)))) ; Statement - (font-lock-comment-face ((t (,@fmt-ital ,@fg-base01)))) ; Comment - (font-lock-constant-face ((t (,@fg-cyan)))) ; Constant - (font-lock-function-name-face ((t (,@fg-blue)))) ; Identifier - (font-lock-keyword-face ((t (,@fg-green)))) ; Statement - (font-lock-string-face ((t (,@fg-cyan)))) ; Constant - (font-lock-type-face ((t (,@fg-yellow)))) ; Type - (font-lock-variable-name-face ((t (,@fg-blue)))) ; Identifier - (font-lock-warning-face ((t (,@fmt-bold ,@fg-red)))) ; Error - (font-lock-doc-face ((t (,@fmt-ital ,@fg-cyan)))) - (font-lock-color-constant-face ((t (,@fg-green)))) - (font-lock-comment-delimiter-face ; Comment - ((t (,@fmt-ital ,@fg-base01)))) - (font-lock-doc-string-face ((t (,@fg-green)))) - (font-lock-preprocessor-face ((t (,@fg-orange)))) ; PreProc - (font-lock-reference-face ((t (,@fg-cyan)))) - (font-lock-negation-char-face ((t (,@fg-red)))) - (font-lock-other-type-face ((t (,@fmt-ital ,@fg-blue)))) - (font-lock-regexp-grouping-construct ((t (,@fg-orange)))) - (font-lock-special-keyword-face ((t (,@fg-magenta)))) - (font-lock-exit-face ((t (,@fg-red)))) - (font-lock-other-emphasized-face ((t (,@fmt-bldi ,@fg-violet)))) - (font-lock-regexp-grouping-backslash ((t (,@fg-yellow)))) - ;; info - (info-xref ((t (,@fmt-undr ,@fg-blue)))) - (info-xref-visited ((t (,@fg-magenta :inherit info-xref)))) - ;; org - (org-hide ((t (,@fg-base03)))) - (org-todo ((t (,@fmt-bold ,@fg-base03 ,@bg-red)))) - (org-done ((t (,@fmt-bold ,@fg-green)))) - (org-todo-kwd-face ((t (,@fg-red ,@bg-base03)))) - (org-done-kwd-face ((t (,@fg-green ,@bg-base03)))) - (org-project-kwd-face ((t (,@fg-violet ,@bg-base03)))) - (org-waiting-kwd-face ((t (,@fg-orange ,@bg-base03)))) - (org-someday-kwd-face ((t (,@fg-blue ,@bg-base03)))) - (org-started-kwd-face ((t (,@fg-yellow ,@bg-base03)))) - (org-cancelled-kwd-face ((t (,@fg-green ,@bg-base03)))) - (org-delegated-kwd-face ((t (,@fg-cyan ,@bg-base03)))) - ;; show-paren - MatchParen - (show-paren-match-face ((t (,@fg-cyan ,@fg-base01)))) - (show-paren-mismatch-face ((t (,@fg-red ,@fg-base01)))) - ;; widgets - (widget-field - ((t (,@fg-base1 ,@bg-base02 :box (:line-width 1 :color ,base2) - :inherit default)))) - (widget-single-line-field ((t (:inherit widget-field)))) - ;; extra modules - ;; ------------- - ;; gnus - (gnus-cite-1 ((t (,@fg-magenta)))) - (gnus-cite-2 ((t (,@fg-base2)))) - (gnus-cite-3 ((t (,@fg-base3)))) - (gnus-cite-4 ((t (,@fg-base1)))) - (gnus-cite-5 ((t (,@fg-magenta)))) - (gnus-cite-6 ((t (,@fg-base2)))) - (gnus-cite-7 ((t (,@fg-base3)))) - (gnus-cite-8 ((t (,@fg-base1)))) - (gnus-cite-9 ((t (,@fg-base2)))) - (gnus-cite-10 ((t (,@fg-base3)))) - (gnus-cite-11 ((t (,@fg-blue)))) - (gnus-group-mail-1 ((t (,@fmt-bold ,@fg-base3)))) - (gnus-group-mail-1-empty ((t (,@fg-base3)))) - (gnus-group-mail-2 ((t (,@fmt-bold ,@fg-base2)))) - (gnus-group-mail-2-empty ((t (,@fg-base2)))) - (gnus-group-mail-3 ((t (,@fmt-bold ,@fg-magenta)))) - (gnus-group-mail-3-empty ((t (,@fg-magenta)))) - (gnus-group-mail-low ((t (,@fmt-bold ,@fg-base00)))) - (gnus-group-mail-low-empty ((t (,@fg-base00)))) - (gnus-group-news-1 ((t (,@fmt-bold ,@fg-base1)))) - (gnus-group-news-1-empty ((t (,@fg-base1)))) - (gnus-group-news-2 ((t (,@fmt-bold ,@fg-blue)))) - (gnus-group-news-2-empty ((t (,@fg-blue)))) - (gnus-group-news-low ((t (,@fmt-bold ,@fg-violet)))) - (gnus-group-news-low-empty ((t (,@fg-violet)))) - (gnus-header-content ((t (,@fmt-ital ,@fg-cyan)))) - (gnus-header-from ((t (,@fg-base2)))) - (gnus-header-name ((t (,@fg-blue)))) - (gnus-header-newsgroups ((t (,@fmt-ital ,@fg-green)))) - (gnus-header-subject ((t (,@fg-base1)))) - (gnus-server-agent ((t (,@fmt-bold ,@fg-base3)))) - (gnus-server-closed ((t (,@fmt-ital ,@fg-base1)))) - (gnus-server-denied ((t (,@fmt-bold ,@fg-base2)))) - (gnus-server-offline ((t (,@fmt-bold ,@fg-green)))) - (gnus-server-opened ((t (,@fmt-bold ,@fg-cyan)))) - (gnus-splash ((t (,@fg-base2)))) - (gnus-summary-high-ancient ((t (,@fmt-bold ,@fg-magenta)))) - (gnus-summary-high-read ((t (,@fmt-bold ,@fg-base1)))) - (gnus-summary-high-ticked ((t (,@fmt-bold ,@fg-base3)))) - (gnus-summary-high-undownloaded ((t (,@fmt-bold ,@fg-base2)))) - (gnus-summary-low-ancient ((t (,@fmt-ital ,@fg-magenta)))) - (gnus-summary-low-read ((t (,@fmt-ital ,@fg-base1)))) - (gnus-summary-low-ticked ((t (,@fmt-ital ,@fg-base3)))) - (gnus-summary-low-undownloaded ((t (,@fmt-ital ,@fg-base2)))) - (gnus-summary-normal-ancient ((t (,@fg-magenta)))) - (gnus-summary-normal-read ((t (,@fg-base1)))) - (gnus-summary-normal-ticked ((t (,@fg-base3)))) - (gnus-summary-normal-undownloaded ((t (,@fg-base2)))) - ;; Flymake - (flymake-errline ((t (,@bg-base3)))) - (flymake-warnline ((t (,@bg-base02)))) - ;; whitespace - (whitespace-empty ((t (,@fg-red)))) - (whitespace-hspace ((t (,@fg-orange)))) - (whitespace-indentation ((t (,@fg-base02)))) - (whitespace-space ((t (,@fg-base02)))) - (whitespace-space-after-tab ((t (,@fg-cyan)))) - (whitespace-space-before-tab ((t (,@fmt-bold ,@fg-red)))) - (whitespace-tab ((t (,@fg-base02)))) - (whitespace-trailing ((t (,@fmt-bold ,@fg-red ,@bg-base02)))) - (whitespace-highlight-face ((t (,@fg-red ,@bg-blue)))) - ;; Message - (message-mml ((t (,@fg-blue)))) - (message-cited-text ((t (,@fg-base2)))) - (message-separator ((t (,@fg-base3)))) - (message-header-xheader ((t (,@fg-violet)))) - (message-header-name ((t (,@fg-cyan)))) - (message-header-other ((t (,@fg-red)))) - (message-header-newsgroups ((t (,@fmt-bldi ,@fg-yellow)))) - (message-header-subject ((t (,@fg-base00)))) - (message-header-cc ((t (,@fmt-bold ,@fg-green)))) - (message-header-to ((t (,@fmt-bold ,@fg-base1)))) - ;; rainbow-delimiters - (rainbow-delimiters-depth-1-face ((t (,@fg-cyan)))) - (rainbow-delimiters-depth-2-face ((t (,@fg-yellow)))) - (rainbow-delimiters-depth-3-face ((t (,@fg-blue)))) - (rainbow-delimiters-depth-4-face ((t (,@fg-red)))) - (rainbow-delimiters-depth-5-face ((t (,@fg-green)))) - (rainbow-delimiters-depth-6-face ((t (,@fg-blue)))) - (rainbow-delimiters-depth-7-face ((t (,@fg-orange)))) - (rainbow-delimiters-depth-8-face ((t (,@fg-magenta)))) - (rainbow-delimiters-depth-9-face ((t (,@fg-base0))))) - ((foreground-color . ,base0) - (background-color . ,base03) - (background-mode . ,mode) - (cursor-color . ,base0)))))))) - -(defmacro create-solarized-theme (mode) - (let* ((theme-name (intern (concat "solarized-" (symbol-name mode)))) - (defs (solarized-color-definitions mode)) - (theme-vars (mapcar (lambda (def) (list (car def) (cdr def))) - (second defs))) - (theme-faces (first defs))) - `(progn - (deftheme ,theme-name ,solarized-description) - (apply 'custom-theme-set-variables ',theme-name ',theme-vars) - (apply 'custom-theme-set-faces ',theme-name ',theme-faces) - (provide-theme ',theme-name)))) - -(provide 'solarized-definitions) diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/color-theme-solarized/solarized-light-theme.el --- a/thirdparty/color-theme-solarized/solarized-light-theme.el Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -(require 'solarized-definitions - (locate-file "solarized-definitions.el" custom-theme-load-path - '("c" ""))) - -(create-solarized-theme light) diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/color-theme.el --- a/thirdparty/color-theme.el Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1668 +0,0 @@ -;;; color-theme.el --- install color themes - -;; Copyright (C) 1999, 2000 Jonadab the Unsightly One -;; Copyright (C) 2000, 2001, 2002, 2003 Alex Schroeder -;; Copyright (C) 2003, 2004, 2005, 2006 Xavier Maillard - -;; Version: 6.6.0 -;; Keywords: faces -;; Author: Jonadab the Unsightly One -;; Maintainer: Xavier Maillard -;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ColorTheme - -;; This file is not (YET) part of GNU Emacs. - -;; This 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. -;; -;; This 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., 59 Temple Place - Suite 330, Boston, -;; MA 02111-1307, USA. - -;;; Commentary: - -;; Please read README and BUGS files for any relevant help. -;; Contributors (not themers) should also read HACKING file. - -;;; Thanks - -;; Deepak Goel -;; S. Pokrovsky for ideas and discussion. -;; Gordon Messmer for ideas and discussion. -;; Sriram Karra for the color-theme-submit stuff. -;; Olgierd `Kingsajz' Ziolko for the spec-filter idea. -;; Brian Palmer for color-theme-library ideas and code -;; All the users that contributed their color themes. - - - -;;; Code: -(eval-when-compile - (require 'easymenu) - (require 'reporter) - (require 'sendmail)) - -(require 'cl); set-difference is a function... - -;; for custom-face-attributes-get or face-custom-attributes-get -(require 'cus-face) -(require 'wid-edit); for widget-apply stuff in cus-face.el - -(defconst color-theme-maintainer-address "zedek@gnu.org" - "Address used by `submit-color-theme'.") - -;; Emacs / XEmacs compatibility and workaround layer - -(cond ((and (facep 'tool-bar) - (not (facep 'toolbar))) - (put 'toolbar 'face-alias 'tool-bar)) - ((and (facep 'toolbar) - (not (facep 'tool-bar))) - (put 'tool-bar 'face-alias 'toolbar))) - -(defvar color-theme-xemacs-p (and (featurep 'xemacs) - (string-match "XEmacs" emacs-version)) - "Non-nil if running XEmacs.") - -;; Add this since it appears to miss in emacs-2x -(or (fboundp 'replace-in-string) - (defun replace-in-string (target old new) - (replace-regexp-in-string old new target))) - -;; face-attr-construct has a problem in Emacs 20.7 and older when -;; dealing with inverse-video faces. Here is a short test to check -;; wether you are affected. - -;; (set-background-color "wheat") -;; (set-foreground-color "black") -;; (setq a (make-face 'a-face)) -;; (face-spec-set a '((t (:background "white" :foreground "black" :inverse-video t)))) -;; (face-attr-construct a) -;; => (:background "black" :inverse-video t) - -;; The expected response is the original specification: -;; => (:background "white" :foreground "black" :inverse-video t) - -;; That's why we depend on cus-face.el functionality. - -(cond ((fboundp 'custom-face-attributes-get) - (defun color-theme-face-attr-construct (face frame) - (if (atom face) - (custom-face-attributes-get face frame) - (if (and (consp face) (eq (car face) 'quote)) - (custom-face-attributes-get (cadr face) frame) - (custom-face-attributes-get (car face) frame))))) - ((fboundp 'face-custom-attributes-get) - (defalias 'color-theme-face-attr-construct - 'face-custom-attributes-get)) - (t - (defun color-theme-face-attr-construct (&rest ignore) - (error "Unable to construct face attributes")))) - -(defun color-theme-alist (plist) - "Transform PLIST into an alist if it is a plist and return it. -If the first element of PLIST is a cons cell, we just return PLIST, -assuming PLIST to be an alist. If the first element of plist is not a -symbol, this is an error: We cannot distinguish a plist from an ordinary -list, but a list that doesn't start with a symbol is certainly no plist -and no alist. - -This is used to make sure `default-frame-alist' really is an alist and not -a plist. In XEmacs, the alist is deprecated; a plist is used instead." - (cond ((consp (car plist)) - plist) - ((not (symbolp (car plist))) - (error "Wrong type argument: plist, %S" plist)) - ((featurep 'xemacs) - (plist-to-alist plist)))); XEmacs only - -;; Customization - -(defgroup color-theme nil - "Color Themes for Emacs. -A color theme consists of frame parameter settings, variable settings, -and face definitions." - :version "20.6" - :group 'faces) - -(defcustom color-theme-legal-frame-parameters "\\(color\\|mode\\)$" - "Regexp that matches frame parameter names. -Only frame parameter names that match this regexp can be changed as part -of a color theme." - :type '(choice (const :tag "Colors only" "\\(color\\|mode\\)$") - (const :tag "Colors, fonts, and size" - "\\(color\\|mode\\|font\\|height\\|width\\)$") - (regexp :tag "Custom regexp")) - :group 'color-theme - :link '(info-link "(elisp)Window Frame Parameters")) - -(defcustom color-theme-legal-variables "\\(color\\|face\\)$" - "Regexp that matches variable names. -Only variables that match this regexp can be changed as part of a color -theme. In addition to matching this name, the variables have to be user -variables (see function `user-variable-p')." - :type 'regexp - :group 'color-theme) - -(defcustom color-theme-illegal-faces "^w3-" - "Regexp that matches face names forbidden in themes. -The default setting \"^w3-\" excludes w3 faces since these -are created dynamically." - :type 'regexp - :group 'color-theme - :link '(info-link "(elisp)Faces for Font Lock") - :link '(info-link "(elisp)Standard Faces")) - -(defcustom color-theme-illegal-default-attributes '(:family :height :width) - "A list of face properties to be ignored when installing faces. -This prevents Emacs from doing terrible things to your display just because -a theme author likes weird fonts." - :type '(repeat symbol) - :group 'color-theme) - -(defcustom color-theme-is-global t - "*Determines wether a color theme is installed on all frames or not. -If non-nil, color themes will be installed for all frames. -If nil, color themes will be installed for the selected frame only. - -A possible use for this variable is dynamic binding. Here is a larger -example to put in your ~/.emacs; it will make the Blue Sea color theme -the default used for the first frame, and it will create two additional -frames with different color themes. - -setup: - \(require 'color-theme) - ;; set default color theme - \(color-theme-blue-sea) - ;; create some frames with different color themes - \(let ((color-theme-is-global nil)) - \(select-frame (make-frame)) - \(color-theme-gnome2) - \(select-frame (make-frame)) - \(color-theme-standard)) - -Please note that using XEmacs and and a nil value for -color-theme-is-global will ignore any variable settings for the color -theme, since XEmacs doesn't have frame-local variable bindings. - -Also note that using Emacs and a non-nil value for color-theme-is-global -will install a new color theme for all frames. Using XEmacs and a -non-nil value for color-theme-is-global will install a new color theme -only on those frames that are not using a local color theme." - :type 'boolean - :group 'color-theme) - -(defcustom color-theme-is-cumulative t - "*Determines wether new color themes are installed on top of each other. -If non-nil, installing a color theme will undo all settings made by -previous color themes." - :type 'boolean - :group 'color-theme) - -(defcustom color-theme-directory nil - "Directory where we can find additionnal themes (personnal). -Note that there is at least one directory shipped with the official -color-theme distribution where all contributed themes are located. -This official selection can't be changed with that variable. -However, you still can decide to turn it on or off and thus, -not be shown with all themes but yours." - :type '(repeat string) - :group 'color-theme) - -(defcustom color-theme-libraries (directory-files - (concat - (file-name-directory (locate-library "color-theme")) - "/themes") t "^color-theme") - "A list of files, which will be loaded in color-theme-initialize depending -on `color-theme-load-all-themes' value. -This allows a user to prune the default color-themes (which can take a while -to load)." - :type '(repeat string) - :group 'color-theme) - -(defcustom color-theme-load-all-themes t - "When t, load all color-theme theme files -as presented by `color-theme-libraries'. Else -do not load any of this themes." - :type 'boolean - :group 'color-theme) - -(defcustom color-theme-mode-hook nil - "Hook for color-theme-mode." - :type 'hook - :group 'color-theme) - -(defvar color-theme-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'color-theme-install-at-point) - (define-key map (kbd "c") 'list-colors-display) - (define-key map (kbd "d") 'color-theme-describe) - (define-key map (kbd "f") 'list-faces-display) - (define-key map (kbd "i") 'color-theme-install-at-point) - (define-key map (kbd "l") 'color-theme-install-at-point-for-current-frame) - (define-key map (kbd "p") 'color-theme-print) - (define-key map (kbd "q") 'bury-buffer) - (define-key map (kbd "?") 'color-theme-describe) - (if color-theme-xemacs-p - (define-key map (kbd "") 'color-theme-install-at-mouse) - (define-key map (kbd "") 'color-theme-install-at-mouse)) - map) - "Mode map used for the buffer created by `color-theme-select'.") - -(defvar color-theme-initialized nil - "Internal variable determining whether color-theme-initialize has been invoked yet") - -(defvar color-theme-buffer-name "*Color Theme Selection*" - "Name of the color theme selection buffer.") - -(defvar color-theme-original-frame-alist nil - "nil until one of the color themes has been installed.") - -(defvar color-theme-history nil - "List of color-themes called, in reverse order") - -(defcustom color-theme-history-max-length nil - "Max length of history to maintain. -Two other values are acceptable: t means no limit, and -nil means that no history is maintained." - :type '(choice (const :tag "No history" nil) - (const :tag "Unlimited length" t) - integer) - :group 'color-theme) - -(defvar color-theme-counter 0 - "Counter for every addition to `color-theme-history'. -This counts how many themes were installed, regardless -of `color-theme-history-max-length'.") - -(defvar color-theme-entry-path (cond - ;; Emacs 22.x and later - ((lookup-key global-map [menu-bar tools]) - '("tools")) - ;; XEmacs - ((featurep 'xemacs) - (setq tool-entry '("Tools"))) - ;; Emacs < 22 - (t - '("Tools"))) - "Menu tool entry path.") - -(defun color-theme-add-to-history (name) - "Add color-theme NAME to `color-theme-history'." - (setq color-theme-history - (cons (list name color-theme-is-cumulative) - color-theme-history) - color-theme-counter (+ 1 color-theme-counter)) - ;; Truncate the list if necessary. - (when (and (integerp color-theme-history-max-length) - (>= (length color-theme-history) - color-theme-history-max-length)) - (setcdr (nthcdr (1- color-theme-history-max-length) - color-theme-history) - nil))) - -;; (let ((l '(1 2 3 4 5))) -;; (setcdr (nthcdr 2 l) nil) -;; l) - - - -;; List of color themes used to create the *Color Theme Selection* -;; buffer. - -(defvar color-themes - '((color-theme-aalto-dark "Aalto Dark" "Jari Aalto ") - (color-theme-aalto-light "Aalto Light" "Jari Aalto ") - (color-theme-aliceblue "Alice Blue" "Girish Bharadwaj ") - (color-theme-andreas "Andreas" "Andreas Busch ") - (color-theme-arjen "Arjen" "Arjen Wiersma ") - (color-theme-beige-diff "Beige Diff" "Alex Schroeder " t) - (color-theme-bharadwaj "Bharadwaj" "Girish Bharadwaj ") - (color-theme-bharadwaj-slate "Bharadwaj Slate" "Girish Bharadwaj ") - (color-theme-billw "Billw" "Bill White ") - (color-theme-black-on-gray "BlackOnGray" "Sudhir Bhojwani ") - (color-theme-blippblopp "Blipp Blopp" "Thomas Sicheritz-Ponten") - (color-theme-simple-1 "Black" "Jonadab ") - (color-theme-blue-erc "Blue ERC" "Alex Schroeder " t) - (color-theme-blue-gnus "Blue Gnus" "Alex Schroeder " t) - (color-theme-blue-mood "Blue Mood" "Nelson Loyola ") - (color-theme-blue-sea "Blue Sea" "Alex Schroeder ") - (color-theme-calm-forest "Calm Forest" "Artur Hefczyc ") - (color-theme-charcoal-black "Charcoal Black" "Lars Chr. Hausmann ") - (color-theme-goldenrod "Cheap Goldenrod" "Alex Schroeder ") - (color-theme-clarity "Clarity and Beauty" "Richard Wellum ") - (color-theme-classic "Classic" "Frederic Giroud ") - (color-theme-comidia "Comidia" "Marcelo Dias de Toledo ") - (color-theme-jsc-dark "Cooper Dark" "John S Cooper ") - (color-theme-jsc-light "Cooper Light" "John S Cooper ") - (color-theme-jsc-light2 "Cooper Light 2" "John S Cooper ") - (color-theme-dark-blue "Dark Blue" "Chris McMahan ") - (color-theme-dark-blue2 "Dark Blue 2" "Chris McMahan ") - (color-theme-dark-green "Dark Green" "eddy_woody@hotmail.com") - (color-theme-dark-laptop "Dark Laptop" "Laurent Michel ") - (color-theme-deep-blue "Deep Blue" "Tomas Cerha ") - (color-theme-digital-ofs1 "Digital OFS1" "Gareth Owen ") - (color-theme-euphoria "Euphoria" "oGLOWo@oGLOWo.cjb.net") - (color-theme-feng-shui "Feng Shui" "Walter Higgins ") - (color-theme-fischmeister "Fischmeister" - "Sebastian Fischmeister ") - (color-theme-gnome "Gnome" "Jonadab ") - (color-theme-gnome2 "Gnome 2" "Alex Schroeder ") - (color-theme-gray1 "Gray1" "Paul Pulli ") - (color-theme-gray30 "Gray30" "Girish Bharadwaj ") - (color-theme-kingsajz "Green Kingsajz" "Olgierd `Kingsajz' Ziolko ") - (color-theme-greiner "Greiner" "Kevin Greiner ") - (color-theme-gtk-ide "GTK IDE" "Gordon Messmer ") - (color-theme-high-contrast "High Contrast" "Alex Schroeder ") - (color-theme-hober "Hober" "Edward O'Connor ") - (color-theme-infodoc "Infodoc" "Frederic Giroud ") - (color-theme-jb-simple "JB Simple" "jeff@dvns.com") - (color-theme-jedit-grey "Jedit Grey" "Gordon Messmer ") - (color-theme-jonadabian "Jonadab" "Jonadab ") - (color-theme-jonadabian-slate "Jonadabian Slate" "Jonadab ") - (color-theme-katester "Katester" "Higgins_Walter@emc.com") - (color-theme-late-night "Late Night" "Alex Schroeder ") - (color-theme-lawrence "Lawrence" "lawrence mitchell ") - (color-theme-lethe "Lethe" "Ivica Loncar ") - (color-theme-ld-dark "Linh Dang Dark" "Linh Dang ") - (color-theme-marine "Marine" "Girish Bharadwaj ") - (color-theme-matrix "Matrix" "Walter Higgins ") - (color-theme-marquardt "Marquardt" "Colin Marquardt ") - (color-theme-midnight "Midnight" "Gordon Messmer ") - (color-theme-mistyday "Misty Day" "Hari Kumar ") - (color-theme-montz "Montz" "Brady Montz ") - (color-theme-oswald "Oswald" "Tom Oswald ") - (color-theme-parus "Parus" "Jon K Hellan ") - (color-theme-pierson "Pierson" "Dan L. Pierson ") - (color-theme-ramangalahy "Ramangalahy" "Solofo Ramangalahy ") - (color-theme-raspopovic "Raspopovic" "Pedja Raspopovic ") - (color-theme-renegade "Renegade" "Dave Benjamin ") - (color-theme-resolve "Resolve" "Damien Elmes ") - (color-theme-retro-green "Retro Green" "Alex Schroeder ") - (color-theme-retro-orange "Retro Orange" "Alex Schroeder ") - (color-theme-robin-hood "Robin Hood" "Alex Schroeder ") - (color-theme-rotor "Rotor" "Jinwei Shen ") - (color-theme-ryerson "Ryerson" "Luis Fernandes ") - (color-theme-salmon-diff "Salmon Diff" "Alex Schroeder " t) - (color-theme-salmon-font-lock "Salmon Font-Lock" "Alex Schroeder " t) - (color-theme-scintilla "Scintilla" "Gordon Messmer ") - (color-theme-shaman "Shaman" "shaman@interdon.net") - (color-theme-sitaramv-nt "Sitaram NT" - "Sitaram Venkatraman ") - (color-theme-sitaramv-solaris "Sitaram Solaris" - "Sitaram Venkatraman ") - (color-theme-snow "Snow" "Nicolas Rist ") - (color-theme-snowish "Snowish" "Girish Bharadwaj ") - (color-theme-standard-ediff "Standard Ediff" "Emacs Team, added by Alex Schroeder " t) - (color-theme-standard "Standard Emacs 20" "Emacs Team, added by Alex Schroeder ") - (color-theme-emacs-21 "Standard Emacs 21" "Emacs Team, added by Alex Schroeder ") - (color-theme-emacs-nw "Standard Emacs 21 No Window" "Emacs Team, added by D. Goel ") - (color-theme-xemacs "Standard XEmacs" "XEmacs Team, added by Alex Schroeder ") - (color-theme-subtle-blue "Subtle Blue" "Chris McMahan ") - (color-theme-subtle-hacker "Subtle Hacker" "Colin Walters ") - (color-theme-taming-mr-arneson "Taming Mr Arneson" "Erik Arneson ") - (color-theme-taylor "Taylor" "Art Taylor ") - (color-theme-tty-dark "TTY Dark" "O Polite ") - (color-theme-vim-colors "Vim Colors" "Michael Soulier ") - (color-theme-whateveryouwant "Whateveryouwant" "Fabien Penso , color by Scott Jaderholm ") - (color-theme-wheat "Wheat" "Alex Schroeder ") - (color-theme-pok-wob "White On Black" "S. Pokrovsky ") - (color-theme-pok-wog "White On Grey" "S. Pokrovsky ") - (color-theme-word-perfect "WordPerfect" "Thomas Gehrlein ") - (color-theme-xp "XP" "Girish Bharadwaj ")) - "List of color themes. - -Each THEME is itself a three element list (FUNC NAME MAINTAINER &optional LIBRARY). - -FUNC is a color theme function which does the setup. The function -FUNC may call `color-theme-install'. The color theme function may be -interactive. - -NAME is the name of the theme and MAINTAINER is the name and/or email of -the maintainer of the theme. - -If LIBRARY is non-nil, the color theme will be considered a library and -may not be shown in the default menu. - -If you defined your own color theme and want to add it to this list, -use something like this: - - (add-to-list 'color-themes '(color-theme-gnome2 \"Gnome2\" \"Alex\"))") - -;;; Functions - -(defun color-theme-backup-original-values () - "Back up the original `default-frame-alist'. -The values are stored in `color-theme-original-frame-alist' on -startup." - (if (null color-theme-original-frame-alist) - (setq color-theme-original-frame-alist - (color-theme-filter (frame-parameters (selected-frame)) - color-theme-legal-frame-parameters)))) -(add-hook 'after-init-hook 'color-theme-backup-original-values) - -;;;###autoload -(defun color-theme-select (&optional arg) - "Displays a special buffer for selecting and installing a color theme. -With optional prefix ARG, this buffer will include color theme libraries -as well. A color theme library is in itself not complete, it must be -used as part of another color theme to be useful. Thus, color theme -libraries are mainly useful for color theme authors." - (interactive "P") - (unless color-theme-initialized (color-theme-initialize)) - (switch-to-buffer (get-buffer-create color-theme-buffer-name)) - (setq buffer-read-only nil) - (erase-buffer) - ;; recreate the snapshot if necessary - (when (or (not (assq 'color-theme-snapshot color-themes)) - (not (commandp 'color-theme-snapshot))) - (fset 'color-theme-snapshot (color-theme-make-snapshot)) - (setq color-themes (delq (assq 'color-theme-snapshot color-themes) - color-themes) - color-themes (delq (assq 'bury-buffer color-themes) - color-themes) - color-themes (append '((color-theme-snapshot - "[Reset]" "Undo changes, if possible.") - (bury-buffer - "[Quit]" "Bury this buffer.")) - color-themes))) - (dolist (theme color-themes) - (let ((func (nth 0 theme)) - (name (nth 1 theme)) - (author (nth 2 theme)) - (library (nth 3 theme)) - (desc)) - (when (or (not library) arg) - (setq desc (format "%-23s %s" - (if library (concat name " [lib]") name) - author)) - (put-text-property 0 (length desc) 'color-theme func desc) - (put-text-property 0 (length name) 'face 'bold desc) - (put-text-property 0 (length name) 'mouse-face 'highlight desc) - (insert desc) - (newline)))) - (goto-char (point-min)) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - (color-theme-mode)) - -(when (require 'easymenu) - (easy-menu-add-item nil color-theme-entry-path "--") - (easy-menu-add-item nil color-theme-entry-path - ["Color Themes" color-theme-select t])) - -(defun color-theme-mode () - "Major mode to select and install color themes. - -Use \\[color-theme-install-at-point] to install a color theme on all frames. -Use \\[color-theme-install-at-point-for-current-frame] to install a color theme for the current frame only. - -The changes are applied on top of your current setup. This is a -feature. - -Some of the themes should be considered extensions to the standard color -theme: they modify only a limited number of faces and variables. To -verify the final look of a color theme, install the standard color -theme, then install the other color theme. This is a feature. It allows -you to mix several color themes. - -Use \\[color-theme-describe] to read more about the color theme function at point. -If you want to install the color theme permanently, put the call to the -color theme function into your ~/.emacs: - - \(require 'color-theme) - \(color-theme-gnome2) - -If you worry about the size of color-theme.el: You are right. Use -\\[color-theme-print] to print the current color theme and save the resulting buffer -as ~/.emacs-color-theme. Now you can install only this specific color -theme in your .emacs: - - \(load-file \"~/.emacs-color-theme\") - \(my-color-theme) - -The Emacs menu is not affected by color themes within Emacs. Depending -on the toolkit you used to compile Emacs, you might have to set specific -X ressources. See the info manual for more information. Here is an -example ~/.Xdefaults fragment: - - emacs*Background: DarkSlateGray - emacs*Foreground: wheat - -\\{color-theme-mode-map} - -The color themes are listed in `color-themes', which see." - (kill-all-local-variables) - (setq major-mode 'color-theme-mode) - (setq mode-name "Color Themes") - (use-local-map color-theme-mode-map) - (when (functionp 'goto-address); Emacs - (goto-address)) - (run-hooks 'color-theme-mode-hook)) - -;;; Commands in Color Theme Selection mode - -;;;###autoload -(defun color-theme-describe () - "Describe color theme listed at point. -This shows the documentation of the value of text-property color-theme -at point. The text-property color-theme should be a color theme -function. See `color-themes'." - (interactive) - (describe-function (get-text-property (point) 'color-theme))) - -;;;###autoload -(defun color-theme-install-at-mouse (event) - "Install color theme clicked upon using the mouse. -First argument EVENT is used to set point. Then -`color-theme-install-at-point' is called." - (interactive "e") - (save-excursion - (mouse-set-point event) - (color-theme-install-at-point))) - -;;;autoload -(defun color-theme-install-at-point () - "Install color theme at point. -This calls the value of the text-property `color-theme' at point. -The text-property `color-theme' should be a color theme function. -See `color-themes'." - (interactive) - (let ((func (get-text-property (point) 'color-theme))) - ;; install theme - (if func - (funcall func)) - ;; If goto-address is being used, remove all overlays in the current - ;; buffer and run it again. The face used for the mail addresses in - ;; the the color theme selection buffer is based on the variable - ;; goto-address-mail-face. Changes in that variable will not affect - ;; existing overlays, however, thereby confusing users. - (when (functionp 'goto-address); Emacs - (dolist (o (overlays-in (point-min) (point-max))) - (delete-overlay o)) - (goto-address)))) - -;;;###autoload -(defun color-theme-install-at-point-for-current-frame () - "Install color theme at point for current frame only. -Binds `color-theme-is-global' to nil and calls -`color-theme-install-at-point'." - (interactive) - (let ((color-theme-is-global nil)) - (color-theme-install-at-point))) - - - -;; Taking a snapshot of the current color theme and pretty printing it. - -(defun color-theme-filter (old-list regexp &optional exclude) - "Filter OLD-LIST. -The resulting list will be newly allocated and contains only elements -with names matching REGEXP. OLD-LIST may be a list or an alist. If you -want to filter a plist, use `color-theme-alist' to convert your plist to -an alist, first. - -If the optional argument EXCLUDE is non-nil, then the sense is -reversed: only non-matching elements will be retained." - (let (elem new-list) - (dolist (elem old-list) - (setq name (symbol-name (if (listp elem) (car elem) elem))) - (when (or (and (not exclude) - (string-match regexp name)) - (and exclude - (not (string-match regexp name)))) - ;; Now make sure that if elem is a cons cell, and the cdr of - ;; that cons cell is a string, then we need a *new* string in - ;; the new list. Having a new cons cell is of no use because - ;; modify-frame-parameters will modify this string, thus - ;; modifying our color theme functions! - (when (and (consp elem) - (stringp (cdr elem))) - (setq elem (cons (car elem) - (copy-sequence (cdr elem))))) - ;; Now store elem - (setq new-list (cons elem new-list)))) - new-list)) - -(defun color-theme-spec-filter (spec) - "Filter the attributes in SPEC. -This makes sure that SPEC has the form ((t (PLIST ...))). -Only properties not in `color-theme-illegal-default-attributes' -are included in the SPEC returned." - (let ((props (cadar spec)) - result prop val) - (while props - (setq prop (nth 0 props) - val (nth 1 props) - props (nthcdr 2 props)) - (unless (memq prop color-theme-illegal-default-attributes) - (setq result (cons val (cons prop result))))) - `((t ,(nreverse result))))) - -;; (color-theme-spec-filter '((t (:background "blue3")))) -;; (color-theme-spec-filter '((t (:stipple nil :background "Black" :foreground "SteelBlue" :inverse-video nil :box nil :strike-through nil :overline nil :underline nil :slant normal :weight normal :width semi-condensed :family "misc-fixed")))) - -(defun color-theme-plist-delete (plist prop) - "Delete property PROP from property list PLIST by side effect. -This modifies PLIST." - ;; deal with prop at the start - (while (eq (car plist) prop) - (setq plist (cddr plist))) - ;; deal with empty plist - (when plist - (let ((lastcell (cdr plist)) - (l (cddr plist))) - (while l - (if (eq (car l) prop) - (progn - (setq l (cddr l)) - (setcdr lastcell l)) - (setq lastcell (cdr l) - l (cddr l)))))) - plist) - -;; (color-theme-plist-delete '(a b c d e f g h) 'a) -;; (color-theme-plist-delete '(a b c d e f g h) 'b) -;; (color-theme-plist-delete '(a b c d e f g h) 'c) -;; (color-theme-plist-delete '(a b c d e f g h) 'g) -;; (color-theme-plist-delete '(a b c d c d e f g h) 'c) -;; (color-theme-plist-delete '(a b c d e f c d g h) 'c) - -(if (or (featurep 'xemacs) - (< emacs-major-version 21)) - (defalias 'color-theme-spec-compat 'identity) - (defun color-theme-spec-compat (spec) - "Filter the attributes in SPEC such that is is never invalid. -Example: Eventhough :bold works in Emacs, it is not recognized by -`customize-face' -- and then the face is uncustomizable. This -function replaces a :bold attribute with the corresponding :weight -attribute, if there is no :weight, or deletes it. This undoes the -doings of `color-theme-spec-canonical-font', more or less." - (let ((props (cadar spec))) - (when (plist-member props :bold) - (setq props (color-theme-plist-delete props :bold)) - (unless (plist-member props :weight) - (setq props (plist-put props :weight 'bold)))) - (when (plist-member props :italic) - (setq props (color-theme-plist-delete props :italic)) - (unless (plist-member props :slant) - (setq props (plist-put props :slant 'italic)))) - `((t ,props))))) - -;; (color-theme-spec-compat '((t (:foreground "blue" :bold t)))) -;; (color-theme-spec-compat '((t (:bold t :foreground "blue" :weight extra-bold)))) -;; (color-theme-spec-compat '((t (:italic t :foreground "blue")))) -;; (color-theme-spec-compat '((t (:slant oblique :italic t :foreground "blue")))) - -(defun color-theme-spec-canonical-font (atts) - "Add :bold and :italic attributes if necessary." - ;; add these to the front of atts -- this will keept the old value for - ;; customize-face in Emacs 21. - (when (and (memq (plist-get atts :weight) - '(ultra-bold extra-bold bold semi-bold)) - (not (plist-get atts :bold))) - (setq atts (cons :bold (cons t atts)))) - (when (and (not (memq (plist-get atts :slant) - '(normal nil))) - (not (plist-get atts :italic))) - (setq atts (cons :italic (cons t atts)))) - atts) -;; (color-theme-spec-canonical-font (color-theme-face-attr-construct 'bold (selected-frame))) -;; (defface foo '((t (:weight extra-bold))) "foo") -;; (color-theme-spec-canonical-font (color-theme-face-attr-construct 'foo (selected-frame))) -;; (face-spec-set 'foo '((t (:weight extra-bold))) nil) -;; (face-spec-set 'foo '((t (:bold t))) nil) -;; (face-spec-set 'foo '((t (:bold t :weight extra-bold))) nil) - -;; Handle :height according to NEWS file for Emacs 21 -(defun color-theme-spec-resolve-height (old new) - "Return the new height given OLD and NEW height. -OLD is the current setting, NEW is the setting inherited from." - (cond ((not old) - new) - ((integerp old) - old) - ((and (floatp old) - (integerp new)) - (round (* old new))) - ((and (floatp old) - (floatp new)) - (* old new)) - ((and (functionp old) - (integerp new)) - (round (funcall old new))) - ((and (functionp old) - (float new)) - `(lambda (f) (* (funcall ,old f) ,new))) - ((and (functionp old) - (functionp new)) - `(lambda (f) (* (funcall ,old (funcall ,new f))))) - (t - (error "Illegal :height attributes: %S or %S" old new)))) -;; (color-theme-spec-resolve-height 12 1.2) -;; (color-theme-spec-resolve-height 1.2 1.2) -;; (color-theme-spec-resolve-height 1.2 12) -;; (color-theme-spec-resolve-height 1.2 'foo) -;; (color-theme-spec-resolve-height (lambda (f) (* 2 f)) 5) -;; (color-theme-spec-resolve-height (lambda (f) (* 2 f)) 2.0) -;; the following lambda is the result from the above calculation -;; (color-theme-spec-resolve-height (lambda (f) (* (funcall (lambda (f) (* 2 f)) f) 2.0)) 5) - -(defun color-theme-spec-resolve-inheritance (atts) - "Resolve all occurences of the :inherit attribute." - (let ((face (plist-get atts :inherit))) - ;; From the Emacs 21 NEWS file: "Attributes from inherited faces are - ;; merged into the face like an underlying face would be." -- - ;; therefore properties of the inherited face only add missing - ;; attributes. - (when face - ;; remove :inherit face from atts -- this assumes only one - ;; :inherit attribute. - (setq atts (delq ':inherit (delq face atts))) - (let ((more-atts (color-theme-spec-resolve-inheritance - (color-theme-face-attr-construct - face (selected-frame)))) - att val) - (while more-atts - (setq att (car more-atts) - val (cadr more-atts) - more-atts (cddr more-atts)) - ;; Color-theme assumes that no value is ever 'unspecified. - (cond ((eq att ':height); cumulative effect! - (setq atts (plist-put atts - ':height - (color-theme-spec-resolve-height - (plist-get atts att) - val)))) - ;; Default: Only put if it has not been specified before. - ((not (plist-get atts att)) - (setq atts (cons att (cons val atts)))) - -)))) - atts)) -;; (color-theme-spec-resolve-inheritance '(:bold t)) -;; (color-theme-spec-resolve-inheritance '(:bold t :foreground "blue")) -;; (color-theme-face-attr-construct 'font-lock-comment-face (selected-frame)) -;; (color-theme-spec-resolve-inheritance '(:bold t :inherit font-lock-comment-face)) -;; (color-theme-spec-resolve-inheritance '(:bold t :foreground "red" :inherit font-lock-comment-face)) -;; (color-theme-face-attr-construct 'Info-title-2-face (selected-frame)) -;; (color-theme-face-attr-construct 'Info-title-3-face (selected-frame)) -;; (color-theme-face-attr-construct 'Info-title-4-face (selected-frame)) -;; (color-theme-spec-resolve-inheritance '(:inherit Info-title-2-face)) - -;; The :inverse-video attribute causes Emacs to swap foreground and -;; background colors, XEmacs does not. Therefore, if anybody chooses -;; the inverse-video attribute, we 1. swap the colors ourselves in Emacs -;; and 2. we remove the inverse-video attribute in Emacs and XEmacs. -;; Inverse-video is only useful on a monochrome tty. -(defun color-theme-spec-maybe-invert (atts) - "Remove the :inverse-video attribute from ATTS. -If ATTS contains :inverse-video t, remove it and swap foreground and -background color. Return ATTS." - (let ((inv (plist-get atts ':inverse-video))) - (if inv - (let (result att) - (while atts - (setq att (car atts) - atts (cdr atts)) - (cond ((and (eq att :foreground) (not color-theme-xemacs-p)) - (setq result (cons :background result))) - ((and (eq att :background) (not color-theme-xemacs-p)) - (setq result (cons :foreground result))) - ((eq att :inverse-video) - (setq atts (cdr atts))); this prevents using dolist - (t - (setq result (cons att result))))) - (nreverse result)) - ;; else - atts))) -;; (color-theme-spec-maybe-invert '(:bold t)) -;; (color-theme-spec-maybe-invert '(:foreground "blue")) -;; (color-theme-spec-maybe-invert '(:background "red")) -;; (color-theme-spec-maybe-invert '(:inverse-video t)) -;; (color-theme-spec-maybe-invert '(:inverse-video t :foreground "red")) -;; (color-theme-spec-maybe-invert '(:inverse-video t :background "red")) -;; (color-theme-spec-maybe-invert '(:inverse-video t :background "red" :foreground "blue" :bold t)) -;; (color-theme-spec-maybe-invert '(:inverse-video nil :background "red" :foreground "blue" :bold t)) - -(defun color-theme-spec (face) - "Return a list for FACE which has the form (FACE SPEC). -See `defface' for the format of SPEC. In this case we use only one -DISPLAY, t, and determine ATTS using `color-theme-face-attr-construct'. -If ATTS is nil, (nil) is used instead. - -If ATTS contains :inverse-video t, we remove it and swap foreground and -background color using `color-theme-spec-maybe-invert'. We do this -because :inverse-video is handled differently in Emacs and XEmacs. We -will loose on a tty without colors, because in that situation, -:inverse-video means something." - (let ((atts - (color-theme-spec-canonical-font - (color-theme-spec-maybe-invert - (color-theme-spec-resolve-inheritance - (color-theme-face-attr-construct face (selected-frame))))))) - (if atts - `(,face ((t ,atts))) - `(,face ((t (nil))))))) - -(defun color-theme-get-params () - "Return a list of frame parameter settings usable in a color theme. -Such an alist may be installed by `color-theme-install-frame-params'. The -frame parameters returned must match `color-theme-legal-frame-parameters'." - (let ((params (color-theme-filter (frame-parameters (selected-frame)) - color-theme-legal-frame-parameters))) - (sort params (lambda (a b) (string< (symbol-name (car a)) - (symbol-name (car b))))))) - -(defun color-theme-get-vars () - "Return a list of variable settings usable in a color theme. -Such an alist may be installed by `color-theme-install-variables'. -The variable names must match `color-theme-legal-variables', and the -variable must be a user variable according to `user-variable-p'." - (let ((vars) - (val)) - (mapatoms (lambda (v) - (and (boundp v) - (user-variable-p v) - (string-match color-theme-legal-variables - (symbol-name v)) - (setq val (eval v)) - (add-to-list 'vars (cons v val))))) - (sort vars (lambda (a b) (string< (car a) (car b)))))) - -(defun color-theme-print-alist (alist) - "Print ALIST." - (insert "\n " (if alist "(" "nil")) - (dolist (elem alist) - (when (= (preceding-char) ?\)) - (insert "\n ")) - (prin1 elem (current-buffer))) - (when (= (preceding-char) ?\)) (insert ")"))) - -(defun color-theme-get-faces () - "Return a list of faces usable in a color theme. -Such an alist may be installed by `color-theme-install-faces'. The -faces returned must not match `color-theme-illegal-faces'." - (let ((faces (color-theme-filter (face-list) color-theme-illegal-faces t))) - ;; default face must come first according to comments in - ;; custom-save-faces, the rest is to be sorted by name - (cons 'default (sort (delq 'default faces) 'string-lessp)))) - -(defun color-theme-get-face-definitions () - "Return face settings usable in a color-theme." - (let ((faces (color-theme-get-faces))) - (mapcar 'color-theme-spec faces))) - -(defun color-theme-print-faces (faces) - "Print face settings for all faces returned by `color-theme-get-faces'." - (when faces - (insert "\n ")) - (dolist (face faces) - (when (= (preceding-char) ?\)) - (insert "\n ")) - (prin1 face (current-buffer)))) - -(defun color-theme-reset-faces () - "Reset face settings for all faces returned by `color-theme-get-faces'." - (let ((faces (color-theme-get-faces)) - (face) (spec) (entry) - (frame (if color-theme-is-global nil (selected-frame)))) - (while faces - (setq entry (color-theme-spec (car faces))) - (setq face (nth 0 entry)) - (setq spec '((t (nil)))) - (setq faces (cdr faces)) - (if (functionp 'face-spec-reset-face) - (face-spec-reset-face face frame) - (face-spec-set face spec frame) - (if color-theme-is-global - (put face 'face-defface-spec spec)))))) - -(defun color-theme-print-theme (func doc params vars faces) - "Print a theme into the current buffer. -FUNC is the function name, DOC the doc string, PARAMS the -frame parameters, VARS the variable bindings, and FACES -the list of faces and their specs." - (insert "(defun " (symbol-name func) " ()\n" - " \"" doc "\"\n" - " (interactive)\n" - " (color-theme-install\n" - " '(" (symbol-name func)) - ;; alist of frame parameters - (color-theme-print-alist params) - ;; alist of variables - (color-theme-print-alist vars) - ;; remaining elements of snapshot: face specs - (color-theme-print-faces faces) - (insert ")))\n") - (insert "(add-to-list 'color-themes '(" (symbol-name func) " " - " \"THEME NAME\" \"YOUR NAME\"))") - (goto-char (point-min))) - -;;;###autoload -(defun color-theme-print (&optional buf) - "Print the current color theme function. - -You can contribute this function to or -paste it into your .emacs file and call it. That should recreate all -the settings necessary for your color theme. - -Example: - - \(require 'color-theme) - \(defun my-color-theme () - \"Color theme by Alex Schroeder, created 2000-05-17.\" - \(interactive) - \(color-theme-install - '(... - ... - ...))) - \(my-color-theme) - -If you want to use a specific color theme function, you can call the -color theme function in your .emacs directly. - -Example: - - \(require 'color-theme) - \(color-theme-gnome2)" - (interactive) - (message "Pretty printing current color theme function...") - (switch-to-buffer (if buf - buf - (get-buffer-create "*Color Theme*"))) - (unless buf - (setq buffer-read-only nil) - (erase-buffer)) - ;; insert defun - (insert "(eval-when-compile" - " (require 'color-theme))\n") - (color-theme-print-theme 'my-color-theme - (concat "Color theme by " - (if (string= "" user-full-name) - (user-login-name) - user-full-name) - ", created " (format-time-string "%Y-%m-%d") ".") - (color-theme-get-params) - (color-theme-get-vars) - (mapcar 'color-theme-spec (color-theme-get-faces))) - (unless buf - (emacs-lisp-mode)) - (goto-char (point-min)) - (message "Pretty printing current color theme function... done")) - -(defun color-theme-analyze-find-theme (code) - "Find the sexpr that calls `color-theme-install'." - (let (theme) - (while (and (not theme) code) - (when (eq (car code) 'color-theme-install) - (setq theme code)) - (when (listp (car code)) - (setq theme (color-theme-analyze-find-theme (car code)))) - (setq code (cdr code))) - theme)) - -;; (equal (color-theme-analyze-find-theme -;; '(defun color-theme-blue-eshell () -;; "Color theme for eshell faces only." -;; (color-theme-install -;; '(color-theme-blue-eshell -;; nil -;; (eshell-ls-archive-face ((t (:bold t :foreground "IndianRed")))) -;; (eshell-ls-backup-face ((t (:foreground "Grey")))))))) -;; '(color-theme-install -;; (quote -;; (color-theme-blue-eshell -;; nil -;; (eshell-ls-archive-face ((t (:bold t :foreground "IndianRed")))) -;; (eshell-ls-backup-face ((t (:foreground "Grey"))))))))) - -(defun color-theme-analyze-add-face (a b regexp faces) - "If only one of A or B are in FACES, the other is added, and FACES is returned. -If REGEXP is given, this is only done if faces contains a match for regexps." - (when (or (not regexp) - (catch 'found - (dolist (face faces) - (when (string-match regexp (symbol-name (car face))) - (throw 'found t))))) - (let ((face-a (assoc a faces)) - (face-b (assoc b faces))) - (if (and face-a (not face-b)) - (setq faces (cons (list b (nth 1 face-a)) - faces)) - (if (and (not face-a) face-b) - (setq faces (cons (list a (nth 1 face-b)) - faces)))))) - faces) - -;; (equal (color-theme-analyze-add-face -;; 'blue 'violet nil -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; '((violet ((t (:foreground "blue")))) -;; (blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; (equal (color-theme-analyze-add-face -;; 'violet 'blue nil -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; '((violet ((t (:foreground "blue")))) -;; (blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; (equal (color-theme-analyze-add-face -;; 'violet 'blue "foo" -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; (equal (color-theme-analyze-add-face -;; 'violet 'blue "blue" -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) -;; '((violet ((t (:foreground "blue")))) -;; (blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t)))))) - -(defun color-theme-analyze-add-faces (faces) - "Add missing faces to FACES and return it." - ;; The most important thing is to add missing faces for the other - ;; editor. These are the most important faces to check. The - ;; following rules list two faces, A and B. If either of the two is - ;; part of the theme, the other must be, too. The optional third - ;; argument specifies a regexp. Only if an existing face name - ;; matches this regexp, is the rule applied. - (let ((rules '((font-lock-builtin-face font-lock-reference-face) - (font-lock-doc-face font-lock-doc-string-face) - (font-lock-constant-face font-lock-preprocessor-face) - ;; In Emacs 21 `modeline' is just an alias for - ;; `mode-line'. I recommend the use of - ;; `modeline' until further notice. - (modeline mode-line) - (modeline modeline-buffer-id) - (modeline modeline-mousable) - (modeline modeline-mousable-minor-mode) - (region primary-selection) - (region zmacs-region) - (font-lock-string-face dired-face-boring "^dired") - (font-lock-function-name-face dired-face-directory "^dired") - (default dired-face-executable "^dired") - (font-lock-warning-face dired-face-flagged "^dired") - (font-lock-warning-face dired-face-marked "^dired") - (default dired-face-permissions "^dired") - (default dired-face-setuid "^dired") - (default dired-face-socket "^dired") - (font-lock-keyword-face dired-face-symlink "^dired") - (tool-bar menu)))) - (dolist (rule rules) - (setq faces (color-theme-analyze-add-face - (nth 0 rule) (nth 1 rule) (nth 2 rule) faces)))) - ;; The `fringe' face defines what the left and right borders of the - ;; frame look like in Emacs 21. To give them default fore- and - ;; background colors, use (fringe ((t (nil)))) in your color theme. - ;; Usually it makes more sense to choose a color slightly lighter or - ;; darker from the default background. - (unless (assoc 'fringe faces) - (setq faces (cons '(fringe ((t (nil)))) faces))) - ;; The tool-bar should not be part of the frame-parameters, since it - ;; should not appear or disappear depending on the color theme. The - ;; apppearance of the toolbar, however, can be changed by the color - ;; theme. For Emacs 21, use the `tool-bar' face. The easiest way - ;; to do this is to give it the default fore- and background colors. - ;; This can be achieved using (tool-bar ((t (nil)))) in the theme. - ;; Usually it makes more sense, however, to provide the same colors - ;; as used in the `menu' face, and to specify a :box attribute. In - ;; order to alleviate potential Emacs/XEmacs incompatibilities, - ;; `toolbar' will be defined as an alias for `tool-bar' if it does - ;; not exist, and vice-versa. This is done eventhough the face - ;; `toolbar' seems to have no effect on XEmacs. If you look at - ;; XEmacs lisp/faces.el, however, you will find that it is in fact - ;; referenced for XPM stuff. - (unless (assoc 'tool-bar faces) - (setq faces (cons '(tool-bar ((t (nil)))) faces))) - ;; Move the default face back to the front, and sort the rest. - (unless (eq (caar faces) 'default) - (let ((face (assoc 'default faces))) - (setq faces (cons face - (sort (delete face faces) - (lambda (a b) - (string-lessp (car a) (car b)))))))) - faces) - -(defun color-theme-analyze-remove-heights (faces) - "Remove :height property where it is an integer and return FACES." - ;; I don't recommend making font sizes part of a color theme. Most - ;; users would be surprised to see their font sizes change when they - ;; install a color-theme. Therefore, remove all :height attributes - ;; if the value is an integer. If the value is a float, this is ok - ;; -- the value is relative to the default height. One notable - ;; exceptions is for a color-theme created for visually impaired - ;; people. These *must* use a larger font in order to be usable. - (let (result) - (dolist (face faces) - (let ((props (cadar (nth 1 face)))) - (if (and (plist-member props :height) - (integerp (plist-get props :height))) - (setq props (color-theme-plist-delete props :height) - result (cons (list (car face) `((t ,props))) - result)) - (setq result (cons face result))))) - (nreverse result))) - -;; (equal (color-theme-analyze-remove-heights -;; '((blue ((t (:foreground "blue" :height 2)))) -;; (bold ((t (:bold t :height 1.0)))))) -;; '((blue ((t (:foreground "blue")))) -;; (bold ((t (:bold t :height 1.0)))))) - -;;;###autoload -(defun color-theme-analyze-defun () - "Once you have a color-theme printed, check for missing faces. -This is used by maintainers who receive a color-theme submission -and want to make sure it follows the guidelines by the color-theme -author." - ;; The support for :foreground and :background attributes works for - ;; Emacs 20 and 21 as well as for XEmacs. :inverse-video is taken - ;; care of while printing color themes. - (interactive) - ;; Parse the stuff and find the call to color-theme-install - (save-excursion - (save-restriction - (narrow-to-defun) - ;; define the function - (eval-defun nil) - (goto-char (point-min)) - (let* ((code (read (current-buffer))) - (theme (color-theme-canonic - (eval - (cadr - (color-theme-analyze-find-theme - code))))) - (func (color-theme-function theme)) - (doc (documentation func t)) - (variables (color-theme-variables theme)) - (faces (color-theme-faces theme)) - (params (color-theme-frame-params theme))) - (setq faces (color-theme-analyze-remove-heights - (color-theme-analyze-add-faces faces))) - ;; Remove any variable bindings of faces that point to their - ;; symbol? Perhaps not, because another theme might want to - ;; change this, so it is important to be able to reset them. - ;; (let (result) - ;; (dolist (var variables) - ;; (unless (eq (car var) (cdr var)) - ;; (setq result (cons var result)))) - ;; (setq variables (nreverse result))) - ;; Now modify the theme directly. - (setq theme (color-theme-analyze-find-theme code)) - (setcdr (cadadr theme) (list params variables faces)) - (message "Pretty printing analysed color theme function...") - (with-current-buffer (get-buffer-create "*Color Theme*") - (setq buffer-read-only nil) - (erase-buffer) - ;; insert defun - (color-theme-print-theme func doc params variables faces) - (emacs-lisp-mode)) - (message "Pretty printing analysed color theme function... done") - (ediff-buffers (current-buffer) - (get-buffer "*Color Theme*")))))) - -;;; Creating a snapshot of the current color theme - -(defun color-theme-snapshot nil) - -;;;###autoload -(defun color-theme-make-snapshot () - "Return the definition of the current color-theme. -The function returned will recreate the color-theme in use at the moment." - (eval `(lambda () - "The color theme in use when the selection buffer was created. -\\[color-theme-select] creates the color theme selection buffer. At the -same time, this snapshot is created as a very simple undo mechanism. -The snapshot is created via `color-theme-snapshot'." - (interactive) - (color-theme-install - '(color-theme-snapshot - ;; alist of frame parameters - ,(color-theme-get-params) - ;; alist of variables - ,(color-theme-get-vars) - ;; remaining elements of snapshot: face specs - ,@(color-theme-get-face-definitions)))))) - - - -;;; Handling the various parts of a color theme install - -(defvar color-theme-frame-param-frobbing-rules - '((foreground-color default foreground) - (background-color default background)) - "List of rules to use when frobbing faces based on frame parameters. -This is only necessary for XEmacs, because in Emacs 21 changing the -frame paramters automatically affects the relevant faces.") - -;; fixme: silent the bytecompiler with set-face-property -(defun color-theme-frob-faces (params) - "Change certain faces according to PARAMS. -This uses `color-theme-frame-param-frobbing-rules'." - (dolist (rule color-theme-frame-param-frobbing-rules) - (let* ((param (nth 0 rule)) - (face (nth 1 rule)) - (prop (nth 2 rule)) - (val (cdr (assq param params))) - (frame (if color-theme-is-global nil (selected-frame)))) - (when val - (set-face-property face prop val frame))))) - -(defun color-theme-alist-reduce (old-list) - "Reduce OLD-LIST. -The resulting list will be newly allocated and will not contain any elements -with duplicate cars. This will speed the installation of new themes by -only installing unique attributes." - (let (new-list) - (dolist (elem old-list) - (when (not (assq (car elem) new-list)) - (setq new-list (cons elem new-list)))) - new-list)) - -(defun color-theme-install-frame-params (params) - "Change frame parameters using alist PARAMETERS. - -If `color-theme-is-global' is non-nil, all frames are modified using -`modify-frame-parameters' and the PARAMETERS are prepended to -`default-frame-alist'. The value of `initial-frame-alist' is not -modified. If `color-theme-is-global' is nil, only the selected frame is -modified. If `color-theme-is-cumulative' is nil, the frame parameters -are restored from `color-theme-original-frame-alist'. - -If the current frame parameters have a parameter `minibuffer' with -value `only', then the frame parameters are not installed, since this -indicates a dedicated minibuffer frame. - -Called from `color-theme-install'." - (setq params (color-theme-filter - params color-theme-legal-frame-parameters)) - ;; We have a new list in params now, therefore we may use - ;; destructive nconc. - (if color-theme-is-global - (let ((frames (frame-list))) - (if (or color-theme-is-cumulative - (null color-theme-original-frame-alist)) - (setq default-frame-alist - (append params (color-theme-alist default-frame-alist)) - minibuffer-frame-alist - (append params (color-theme-alist minibuffer-frame-alist))) - (setq default-frame-alist - (append params color-theme-original-frame-alist) - minibuffer-frame-alist - (append params (color-theme-alist minibuffer-frame-alist)))) - (setq default-frame-alist - (color-theme-alist-reduce default-frame-alist) - minibuffer-frame-alist - (color-theme-alist-reduce minibuffer-frame-alist)) - (dolist (frame frames) - (let ((params (if (eq 'only (cdr (assq 'minibuffer (frame-parameters frame)))) - minibuffer-frame-alist - default-frame-alist))) - (condition-case var - (modify-frame-parameters frame params) - (error (message "Error using params %S: %S" params var)))))) - (condition-case var - (modify-frame-parameters (selected-frame) params) - (error (message "Error using params %S: %S" params var)))) - (when color-theme-xemacs-p - (color-theme-frob-faces params))) - -;; (setq default-frame-alist (cons '(height . 30) default-frame-alist)) - -(defun color-theme-install-variables (vars) - "Change variables using alist VARS. -All variables matching `color-theme-legal-variables' are set. - -If `color-theme-is-global' and `color-theme-xemacs-p' are nil, variables -are made frame-local before setting them. Variables are set using `set' -in either case. This may lead to problems if changing the variable -requires the usage of the function specified with the :set tag in -defcustom declarations. - -Called from `color-theme-install'." - (let ((vars (color-theme-filter vars color-theme-legal-variables))) - (dolist (var vars) - (if (or color-theme-is-global color-theme-xemacs-p) - (set (car var) (cdr var)) - (make-variable-frame-local (car var)) - (modify-frame-parameters (selected-frame) (list var)))))) - -(defun color-theme-install-faces (faces) - "Change faces using FACES. - -Change faces for all frames and create any faces listed in FACES which -don't exist. The modified faces will be marked as \"unchanged from -its standard setting\". This is OK, since the changes made by -installing a color theme should never by saved in .emacs by -customization code. - -FACES should be a list where each entry has the form: - - (FACE SPEC) - -See `defface' for the format of SPEC. - -If `color-theme-is-global' is non-nil, faces are modified on all frames -using `face-spec-set'. If `color-theme-is-global' is nil, faces are -only modified on the selected frame. Non-existing faces are created -using `make-empty-face' in either case. If `color-theme-is-cumulative' -is nil, all faces are reset before installing the new faces. - -Called from `color-theme-install'." - ;; clear all previous faces - (when (not color-theme-is-cumulative) - (color-theme-reset-faces)) - ;; install new faces - (let ((faces (color-theme-filter faces color-theme-illegal-faces t)) - (frame (if color-theme-is-global nil (selected-frame)))) - (dolist (entry faces) - (let ((face (nth 0 entry)) - (spec (nth 1 entry))) - (or (facep face) - (make-empty-face face)) - ;; remove weird properties from the default face only - (when (eq face 'default) - (setq spec (color-theme-spec-filter spec))) - ;; Emacs/XEmacs customization issues: filter out :bold when - ;; the spec contains :weight, etc, such that the spec remains - ;; "valid" for custom. - (setq spec (color-theme-spec-compat spec)) - ;; using a spec of ((t (nil))) to reset a face doesn't work - ;; in Emacs 21, we use the new function face-spec-reset-face - ;; instead - (if (and (functionp 'face-spec-reset-face) - (equal spec '((t (nil))))) - (face-spec-reset-face face frame) - (condition-case var - (progn - (face-spec-set face spec frame) - (if color-theme-is-global - (put face 'face-defface-spec spec))) - (error (message "Error using spec %S: %S" spec var)))))))) - -;; `custom-set-faces' is unusable here because it doesn't allow to set -;; the faces for one frame only. - -;; Emacs `face-spec-set': If FRAME is nil, the face is created and -;; marked as a customized face. This is achieved by setting the -;; `face-defface-spec' property. If we don't, new frames will not be -;; created using the face we installed because `face-spec-set' is -;; broken: If given a FRAME of nil, it will not set the default faces; -;; instead it will walk through all the frames and set modify the faces. -;; If we do set a property (`saved-face' or `face-defface-spec'), -;; `make-frame' will correctly use the faces we defined with our color -;; theme. If we used the property `saved-face', -;; `customize-save-customized' will save all the faces installed as part -;; of a color-theme in .emacs. That's why we use the -;; `face-defface-spec' property. - - - -;;; Theme accessor functions, canonicalization, merging, comparing - -(defun color-theme-canonic (theme) - "Return the canonic form of THEME. -This deals with all the backwards compatibility stuff." - (let (function frame-params variables faces) - (when (functionp (car theme)) - (setq function (car theme) - theme (cdr theme))) - (setq frame-params (car theme) - theme (cdr theme)) - ;; optional variable defintions (for backwards compatibility) - (when (listp (caar theme)) - (setq variables (car theme) - theme (cdr theme))) - ;; face definitions - (setq faces theme) - (list function frame-params variables faces))) - -(defun color-theme-function (theme) - "Return function used to create THEME." - (nth 0 theme)) - -(defun color-theme-frame-params (theme) - "Return frame-parameters defined by THEME." - (nth 1 theme)) - -(defun color-theme-variables (theme) - "Return variables set by THEME." - (nth 2 theme)) - -(defun color-theme-faces (theme) - "Return faces defined by THEME." - (nth 3 theme)) - -(defun color-theme-merge-alists (&rest alists) - "Merges all the alist arguments into one alist. -Only the first instance of every key will be part of the resulting -alist. Membership will be tested using `assq'." - (let (result) - (dolist (l alists) - (dolist (entry l) - (unless (assq (car entry) result) - (setq result (cons entry result))))) - (nreverse result))) -;; (color-theme-merge-alists '((a . 1) (b . 2))) -;; (color-theme-merge-alists '((a . 1) (b . 2) (a . 3))) -;; (color-theme-merge-alists '((a . 1) (b . 2)) '((a . 3))) -;; (color-theme-merge-alists '((a . 1) (b . 2)) '((c . 3))) -;; (color-theme-merge-alists '((a . 1) (b . 2)) '((c . 3) (d . 4))) -;; (color-theme-merge-alists '((a . 1) (b . 2)) '((c . 3) (d . 4) (b . 5))) - -;;;###autoload -(defun color-theme-compare (theme-a theme-b) - "Compare two color themes. -This will print the differences between installing THEME-A and -installing THEME-B. Note that the order is important: If a face is -defined in THEME-A and not in THEME-B, then this will not show up as a -difference, because there is no reset before installing THEME-B. If a -face is defined in THEME-B and not in THEME-A, then this will show up as -a difference." - (interactive - (list - (intern - (completing-read "Theme A: " - (mapcar (lambda (i) (list (symbol-name (car i)))) - color-themes) - (lambda (i) (string-match "color-theme" (car i))))) - (intern - (completing-read "Theme B: " - (mapcar (lambda (i) (list (symbol-name (car i)))) - color-themes) - (lambda (i) (string-match "color-theme" (car i))))))) - ;; install the themes in a new frame and get the definitions - (let ((color-theme-is-global nil)) - (select-frame (make-frame)) - (funcall theme-a) - (setq theme-a (list theme-a - (color-theme-get-params) - (color-theme-get-vars) - (color-theme-get-face-definitions))) - (funcall theme-b) - (setq theme-b (list theme-b - (color-theme-get-params) - (color-theme-get-vars) - (color-theme-get-face-definitions))) - (delete-frame)) - (let ((params (set-difference - (color-theme-frame-params theme-b) - (color-theme-frame-params theme-a) - :test 'equal)) - (vars (set-difference - (color-theme-variables theme-b) - (color-theme-variables theme-a) - :test 'equal)) - (faces (set-difference - (color-theme-faces theme-b) - (color-theme-faces theme-a) - :test 'equal))) - (list 'diff - params - vars - faces))) - - - -;;; Installing a color theme -;;;###autoload -(defun color-theme-install (theme) - "Install a color theme defined by frame parameters, variables and faces. - -The theme is installed for all present and future frames; any missing -faces are created. See `color-theme-install-faces'. - -THEME is a color theme definition. See below for more information. - -If you want to install a color theme from your .emacs, use the output -generated by `color-theme-print'. This produces color theme function -which you can copy to your .emacs. - -A color theme definition is a list: -\([FUNCTION] FRAME-PARAMETERS VARIABLE-SETTINGS FACE-DEFINITIONS) - -FUNCTION is the color theme function which called `color-theme-install'. -This is no longer used. There was a time when this package supported -automatic factoring of color themes. This has been abandoned. - -FRAME-PARAMETERS is an alist of frame parameters. These are installed -with `color-theme-install-frame-params'. These are installed last such -that any changes to the default face can be changed by the frame -parameters. - -VARIABLE-DEFINITIONS is an alist of variable settings. These are -installed with `color-theme-install-variables'. - -FACE-DEFINITIONS is an alist of face definitions. These are installed -with `color-theme-install-faces'. - -If `color-theme-is-cumulative' is nil, a color theme will undo face and -frame-parameter settings of previous color themes." - (setq theme (color-theme-canonic theme)) - (color-theme-install-variables (color-theme-variables theme)) - (color-theme-install-faces (color-theme-faces theme)) - ;; frame parameters override faces - (color-theme-install-frame-params (color-theme-frame-params theme)) - (when color-theme-history-max-length - (color-theme-add-to-history - (car theme)))) - - - -;; Sharing your stuff -;;;###autoload -(defun color-theme-submit () - "Submit your color-theme to the maintainer." - (interactive) - (require 'reporter) - (let ((reporter-eval-buffer (current-buffer)) - final-resting-place - after-sep-pos - (reporter-status-message "Formatting buffer...") - (reporter-status-count 0) - (problem "Yet another color-theme") - (agent (reporter-compose-outgoing)) - (mailbuf (current-buffer)) - hookvar) - ;; do the work - (require 'sendmail) - ;; If mailbuf did not get made visible before, make it visible now. - (let (same-window-buffer-names same-window-regexps) - (pop-to-buffer mailbuf) - ;; Just in case the original buffer is not visible now, bring it - ;; back somewhere - (and pop-up-windows (display-buffer reporter-eval-buffer))) - (goto-char (point-min)) - (mail-position-on-field "to") - (insert color-theme-maintainer-address) - (mail-position-on-field "subject") - (insert problem) - ;; move point to the body of the message - (mail-text) - (setq after-sep-pos (point)) - (unwind-protect - (progn - (setq final-resting-place (point-marker)) - (goto-char final-resting-place)) - (color-theme-print (current-buffer)) - (goto-char final-resting-place) - (insert "\n\n") - (goto-char final-resting-place) - (insert "Hello there!\n\nHere's my color theme named: ") - (set-marker final-resting-place nil)) - ;; compose the minibuf message and display this. - (let* ((sendkey-whereis (where-is-internal - (get agent 'sendfunc) nil t)) - (abortkey-whereis (where-is-internal - (get agent 'abortfunc) nil t)) - (sendkey (if sendkey-whereis - (key-description sendkey-whereis) - "C-c C-c")); TBD: BOGUS hardcode - (abortkey (if abortkey-whereis - (key-description abortkey-whereis) - "M-x kill-buffer"))); TBD: BOGUS hardcode - (message "Enter a message and type %s to send or %s to abort." - sendkey abortkey)))) - - - -;; Use this to define themes -(defmacro define-color-theme (name author description &rest forms) - (let ((n name)) - `(progn - (add-to-list 'color-themes - (list ',n - (upcase-initials - (replace-in-string - (replace-in-string - (symbol-name ',n) "^color-theme-" "") "-" " ")) - ,author)) - (defun ,n () - ,description - (interactive) - ,@forms)))) - - -;;; FIXME: is this useful ?? -;;;###autoload -(defun color-theme-initialize () - "Initialize the color theme package by loading color-theme-libraries." - (interactive) - - (cond ((and (not color-theme-load-all-themes) - color-theme-directory) - (setq color-theme-libraries - (directory-files color-theme-directory t "^color-theme"))) - (color-theme-directory - (push (cdr (directory-files color-theme-directory t "^color-theme")) - color-theme-libraries))) - (dolist (library color-theme-libraries) - (load library))) - -(when nil - (setq color-theme-directory "themes/" - color-theme-load-all-themes nil) - (color-theme-initialize) -) -;; TODO: I don't like all those function names cluttering up my namespace. -;; Instead, a hashtable for the color-themes should be created. Now that -;; define-color-theme is around, it should be easy to change in just the -;; one place. - - -(provide 'color-theme) - -;;; color-theme.el ends here diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/rainbow-delimiters.el --- a/thirdparty/rainbow-delimiters.el Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,392 +0,0 @@ -;;; rainbow-delimiters.el --- Color nested parentheses, brackets, and braces according to their depth. - -;; Copyright (C) 2010-2011 Jeremy L. Rayman. -;; Author: Jeremy L. Rayman -;; Maintainer: Jeremy L. Rayman -;; Created: 2010-09-02 -;; Version: 1.2.1 -;; Keywords: faces, convenience, lisp, matching, tools -;; EmacsWiki: RainbowDelimiters -;; URL: http://www.emacswiki.org/emacs/rainbow-delimiters.el - -;; 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 of the License, 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, see . - - -;;; Commentary: - -;; This is a "rainbow parentheses" mode which includes support for -;; parens "()", brackets "[]", and braces "{}". It conveys nesting -;; depth by using a different face for each level. It colors all -;; statements at a given level using the same color - if several -;; statements are all at the same nested depth, they will all be the -;; same color. -;; -;; Great care has been taken to make this mode FAST. You should see no -;; discernible change in scrolling or editing speed while using it, -;; even with delimiter-rich languages like Clojure, Lisp, and Scheme. -;; -;; The one exception is with extremely large nested data structures -;; having hundreds of delimiters; in that case there will be a brief -;; pause to colorize the structure the very first time it is displayed -;; on screen; from then on editing this structure will perform at full -;; speed. -;; -;; Default colors have been chosen with the philosophy that it's -;; better be less intrusive than to be more colorful. Color schemes -;; are always a matter of taste. If you do take the time to design a -;; new color scheme, please post it on the EmacsWiki page! -;; URL: http://www.emacswiki.org/emacs/RainbowDelimiters - -;;; Installation: - -;; 1. Place rainbow-delimiters.el on your emacs load-path. -;; -;; 2. Compile the file (necessary for speed): -;; M-x byte-compile-file -;; -;; 3. Add the following to your dot-emacs/init file: -;; (require 'rainbow-delimiters) -;; -;; 4. Add hooks for modes where you want it enabled, for example: -;; (add-hook 'clojure-mode-hook 'rainbow-delimiters-mode) -;; -;; - To activate rainbow-delimiters mode temporarily in a buffer: -;; M-x rainbow-delimiters-mode - -;;; Customization: - -;; To customize various options, including the color scheme: -;; M-x customize-group rainbow-delimiters -;; -;; color-theme.el users: -;; If you use the color-theme package, you can specify custom colors -;; by adding the appropriate faces to your theme. -;; - Faces take the form of: -;; 'rainbow-delimiters-depth-#-face' with # being the depth. -;; Depth begins at 1, the outermost color. -;; Faces exist for depths 1-12. -;; - The unmatched delimiter face is: -;; 'rainbow-delimiters-unmatched-delimiter-face' - -;;; Change Log: - -;; 1.0 - Initial release. -;; 1.1 - Stop tracking each delimiter's depth independently. -;; This had lead to confusing results when viewing clojure -;; code. Instead, just color based on current nesting inside -;; all delimiters combined. -;; - Added 'all-delimiters' faces to apply a color scheme to -;; all delimiters at once. Other faces inherit from this group. -;; 1.1.1 - Change color scheme to a lighter, more subtle style. -;; 1.1.2: (2011-03-25) -;; - Add an unmatched-delimiter face and correct problem with -;; coloring of text following unmatched closing delims. -;; 1.2: (2011-03-28) -;; - Unify delimiter faces: all delimiter types now use the same depth -;; faces, of form 'rainbow-delimiters-depth-#-face'. -;; 1.2.1: (2011-03-29) -;; - Conform to ELPA conventions. - -;;; TODO: - -;; - Add support for nested tags (XML, HTML) - -;;; Issues: - -;; - Rainbow-delimiters mode does not appear to change the color of -;; delimiters when Org-mode is enabled. - - -;;; Code: - -(eval-when-compile (require 'cl)) - - -;;; Customize interface: - -(defgroup rainbow-delimiters nil - "Color nested parentheses, brackets, and braces according to their depth." - :prefix "rainbow-delimiters-" - :link '(url-link :tag "Website for rainbow-delimiters (EmacsWiki)" - "http://www.emacswiki.org/emacs/RainbowDelimiters") - :group 'applications) - -(defgroup rainbow-delimiters-faces nil - "Faces for each nested depth. Used to color delimiter pairs. - -Depths 1-12 are defined. Depth 1 is the outermost delimiter pair." - :group 'rainbow-delimiters - :link '(custom-group-link "rainbow-delimiters") - :prefix 'rainbow-delimiters-faces-) - - -;;; Faces: - -;; Unmatched delimiter face: -(defface rainbow-delimiters-unmatched-face - '((t (:foreground "#88090B"))) - "Face to color unmatched closing delimiters with." - :group 'rainbow-delimiters - :group 'rainbow-delimiters-faces) - - -;; NOTE: The use of repetitious definitions for depth faces is temporary. -;; Once the emacs 24 color theme support comes in, this will be reevaluated. - -;; Faces for colorizing delimiters at each level: -(defface rainbow-delimiters-depth-1-face - '((t (:foreground "grey55"))) - "Rainbow-delimiters nested delimiter face, depth 1 - the outermost pair." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-2-face - '((t (:foreground "#93a8c6"))) - "Rainbow-delimiters nested delimiter face, depth 2." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-3-face - '((t (:foreground "#b0b1a3"))) - "Rainbow-delimiters nested delimiter face, depth 3." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-4-face - '((t (:foreground "#97b098"))) - "Rainbow-delimiters nested delimiter face, depth 4." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-5-face - '((t (:foreground "#aebed8"))) - "Rainbow-delimiters nested delimiter face, depth 5." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-6-face - '((t (:foreground "#b0b0b3"))) - "Rainbow-delimiters nested delimiter face, depth 6." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-7-face - '((t (:foreground "#90a890"))) - "Rainbow-delimiters nested delimiter face, depth 7." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-8-face - '((t (:foreground "#a2b6da"))) - "Rainbow-delimiters nested delimiter face, depth 8." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-9-face - '((t (:foreground "#9cb6ad"))) - "Rainbow-delimiters nested delimiter face, depth 9." - :group 'rainbow-delimiters-faces) - -;; Emacs doesn't sort face names by number correctly above 1-9; trick it into -;; proper sorting by prepending a _ before the faces with depths over 10. -(defface rainbow-delimiters-depth-_10-face - '((t (:foreground "#83787e"))) - "Rainbow-delimiters nested delimiter face, depth 10." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-_11-face - '((t (:foreground "#e1ddca"))) - "Rainbow-delimiters nested delimiter face, depth 11." - :group 'rainbow-delimiters-faces) - -(defface rainbow-delimiters-depth-_12-face - '((t (:foreground "#e0c7c7"))) - "Rainbow-delimiters nested delimiter face, depth 12." - :group 'rainbow-delimiters-faces) - -;; Variable aliases for faces 10+: -;; We prepend an underline to numbers 10+ to force customize to sort correctly. -;; Here we define aliases without the underline for use everywhere else. -(put 'rainbow-delimiters-depth-10-face - 'face-alias - 'rainbow-delimiters-depth-_10-face) -(put 'rainbow-delimiters-depth-11-face - 'face-alias - 'rainbow-delimiters-depth-_11-face) -(put 'rainbow-delimiters-depth-12-face - 'face-alias - 'rainbow-delimiters-depth-_12-face) - - -;;; Face utility functions - -;; inlining this function for speed: -;; see: http://www.gnu.org/s/emacs/manual/html_node/elisp/Compilation-Tips.html -;; this will cause problems with debugging. To debug, change defsubst -> defun. -(defsubst rainbow-delimiters-depth-face (depth) - "Return face-name 'rainbow-delimiters-depth-DEPTH-face' as a string. - -DEPTH is the number of nested levels deep for the delimiter being colorized. - -Returns a face namestring the of form 'rainbow-delimiters-depth-DEPTH-face', -e.g. 'rainbow-delimiters-depth-1-face'." - (concat "rainbow-delimiters-depth-" (number-to-string depth) "-face")) - - -;;; Nesting level - -;; syntax-table: used with parse-partial-sexp for determining current depth. -(defvar rainbow-delimiters-delim-syntax-table - (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) - (modify-syntax-entry ?\( "() " table) - (modify-syntax-entry ?\) ")( " table) - (modify-syntax-entry ?\[ "(]" table) - (modify-syntax-entry ?\] ")[" table) - (modify-syntax-entry ?\{ "(}" table) - (modify-syntax-entry ?\} "){" table) - table) - "Syntax table for recognizing all supported delimiter types.") - -(defun rainbow-delimiters-depth (point) - "Return # of nested levels of parens, brackets, braces POINT is inside of." - (save-excursion - (beginning-of-defun) - (let ((depth - (with-syntax-table rainbow-delimiters-delim-syntax-table - (car (parse-partial-sexp (point) point))))) - (if (>= depth 0) - depth - 0)))) ; ignore negative depths created by unmatched closing parens. - - -;;; Text properties - -;; inlining this function for speed: -;; see: http://www.gnu.org/s/emacs/manual/html_node/elisp/Compilation-Tips.html -;; this will cause problems with debugging. To debug, change defsubst -> defun. -(defsubst rainbow-delimiters-propertize-delimiter (point depth) - "Colorize delimiter at POINT according to DEPTH. - -POINT is the point of character to propertize. -DEPTH is the nested delimiter depth at POINT, which determines the face to use. - -Sets text properties: -`font-lock-face' to the corresponding delimiter face. -`rear-nonsticky' to prevent color from bleeding into subsequent characters typed by the user." - (with-silent-modifications - (let ((delim-face (if (<= depth 0) - "rainbow-delimiters-unmatched-face" - (rainbow-delimiters-depth-face depth)))) - ;; (when (eq depth -1) (message "Unmatched delimiter at char %s." point)) - (add-text-properties point (1+ point) - `(font-lock-face ,delim-face - rear-nonsticky t))))) - - -(defun rainbow-delimiters-unpropertize-delimiter (point) - "Remove text properties set by rainbow-delimiters mode from char at POINT." - (remove-text-properties point (1+ point) - '(font-lock-face nil - rear-nonsticky nil))) - - -(defun rainbow-delimiters-char-ineligible-p (point) - "Return t if char at POINT should be skipped, e.g. if inside a comment. - -Returns t if char at point meets one of the following conditions: -- Inside a string. -- Inside a comment. -- Is an escaped char, e.g. ?\)" - (let ((parse-state (save-excursion - (beginning-of-defun) - ;; (point) is at beg-of-defun; point is the char location - (parse-partial-sexp (point) point)))) - (or - (nth 3 parse-state) ; inside string? - (nth 4 parse-state) ; inside comment? - (and (eq (char-before point) ?\\) ; escaped char, e.g. ?\) - not counted - (and (not (eq (char-before (1- point)) ?\\)) ; special-case: ignore ?\\ - (eq (char-before (1- point)) ?\?)))))) -;; standard char read syntax '?)' is not tested for because emacs manual states -;; that punctuation such as delimiters should _always_ use escaped '?\)' form. - - -;;; JIT-Lock functionality - -;; Used to skip delimiter-by-delimiter `rainbow-delimiters-propertize-region'. -(defvar rainbow-delimiters-delim-regex "\\(\(\\|\)\\|\\[\\|\\]\\|\{\\|\}\\)" - "Regex matching all opening and closing delimiters we intend to colorize.") - -;; main function called by jit-lock: -(defun rainbow-delimiters-propertize-region (start end) - "Colorize delimiters in region between START and END. - -Used by jit-lock for dynamic highlighting." - (save-excursion - (goto-char start) - ;; START can be anywhere in buffer; begin depth counts from values at START. - (let ((depth (rainbow-delimiters-depth start))) - (while (and (< (point) end) - (re-search-forward rainbow-delimiters-delim-regex end t)) - (backward-char) ; re-search-forward places point after delim; go back. - (unless (rainbow-delimiters-char-ineligible-p (point)) - (let ((delim (char-after (point)))) - (cond ((eq ?\( delim) ; ( - (setq depth (1+ depth)) - (rainbow-delimiters-propertize-delimiter (point) - depth)) - ((eq ?\) delim) ; ) - (rainbow-delimiters-propertize-delimiter (point) - depth) - (setq depth (or (and (<= depth 0) 0) ; unmatched paren - (1- depth)))) - ((eq ?\[ delim) ; [ - (setq depth (1+ depth)) - (rainbow-delimiters-propertize-delimiter (point) - depth)) - ((eq ?\] delim) ; ] - (rainbow-delimiters-propertize-delimiter (point) - depth) - (setq depth (or (and (<= depth 0) 0) ; unmatched bracket - (1- depth)))) - ((eq ?\{ delim) ; { - (setq depth (1+ depth)) - (rainbow-delimiters-propertize-delimiter (point) - depth)) - ((eq ?\} delim) ; } - (rainbow-delimiters-propertize-delimiter (point) - depth) - (setq depth (or (and (<= depth 0) 0) ; unmatched brace - (1- depth))))))) - ;; move past delimiter so re-search-forward doesn't pick it up again - (forward-char))))) - -(defun rainbow-delimiters-unpropertize-region (start end) - "Remove mode faces from delimiters in region between START and END." - (save-excursion - (goto-char start) - (while (and (< (point) end) - (re-search-forward rainbow-delimiters-delim-regex end t)) - ;; re-search-forward places point 1 further than the delim matched: - (rainbow-delimiters-unpropertize-delimiter (1- (point)))))) - - -;;; Minor mode: - -;;;###autoload -(define-minor-mode rainbow-delimiters-mode - "Color nested parentheses, brackets, and braces according to their depth." - nil "" nil ; No modeline lighter - it's already obvious when the mode is on. - (if (not rainbow-delimiters-mode) - (progn - (jit-lock-unregister 'rainbow-delimiters-propertize-region) - (rainbow-delimiters-unpropertize-region (point-min) (1- (point-max)))) - (jit-lock-register 'rainbow-delimiters-propertize-region t))) - - -(provide 'rainbow-delimiters) - -;;; rainbow-delimiters.el ends here. diff -r e1b82f67f96e -r d4adcd3d5ef9 thirdparty/zencoding-mode.el --- a/thirdparty/zencoding-mode.el Sat Jun 22 22:54:53 2013 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1064 +0,0 @@ -;;; zencoding-mode.el --- Unfold CSS-selector-like expressions to markup - -;; Copyright (C) 2009, Chris Done - -;; Version: 0.5.1 -;; Author: Chris Done -;; URL: https://github.com/rooney/zencoding -;; Last-Updated: 2011-12-31 Sat -;; Keywords: convenience - -;; This file 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 file 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. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Unfold CSS-selector-like expressions to markup. Intended to be used -;; with sgml-like languages; xml, html, xhtml, xsl, etc. -;; -;; See `zencoding-mode' for more information. -;; -;; Copy zencoding-mode.el to your load-path and add to your .emacs: -;; -;; (require 'zencoding-mode) -;; -;; Example setup: -;; -;; (add-to-list 'load-path "~/Emacs/zencoding/") -;; (require 'zencoding-mode) -;; (add-hook 'sgml-mode-hook 'zencoding-mode) ;; Auto-start on any markup modes -;; -;; Enable the minor mode with M-x zencoding-mode. -;; -;; See ``Test cases'' section for a complete set of expression types. -;; -;; If you are hacking on this project, eval (zencoding-test-cases) to -;; ensure that your changes have not broken anything. Feel free to add -;; new test cases if you add new features. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; History: -;; -;; Modified by Lennart Borgman. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(defconst zencoding-mode:version "0.5.1") - -;; Include the trie data structure for caching -;(require 'zencoding-trie) - -(require 'cl) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Generic parsing macros and utilities - -(defmacro zencoding-aif (test-form then-form &rest else-forms) - "Anaphoric if. Temporary variable `it' is the result of test-form." - `(let ((it ,test-form)) - (if it ,then-form ,@(or else-forms '(it))))) - -(defmacro zencoding-pif (test-form then-form &rest else-forms) - "Parser anaphoric if. Temporary variable `it' is the result of test-form." - `(let ((it ,test-form)) - (if (not (eq 'error (car it))) ,then-form ,@(or else-forms '(it))))) - -(defmacro zencoding-parse (regex nums label &rest body) - "Parse according to a regex and update the `input' variable." - `(zencoding-aif (zencoding-regex ,regex input ',(number-sequence 0 nums)) - (let ((input (elt it ,nums))) - ,@body) - `,`(error ,(concat "expected " ,label)))) - -(defmacro zencoding-run (parser then-form &rest else-forms) - "Run a parser and update the input properly, extract the parsed - expression." - `(zencoding-pif (,parser input) - (let ((input (cdr it)) - (expr (car it))) - ,then-form) - ,@(or else-forms '(it)))) - -(defmacro zencoding-por (parser1 parser2 then-form &rest else-forms) - "OR two parsers. Try one parser, if it fails try the next." - `(zencoding-pif (,parser1 input) - (let ((input (cdr it)) - (expr (car it))) - ,then-form) - (zencoding-pif (,parser2 input) - (let ((input (cdr it)) - (expr (car it))) - ,then-form) - ,@else-forms))) - -(defun zencoding-regex (regexp string refs) - "Return a list of (`ref') matches for a `regex' on a `string' or nil." - (if (string-match (concat "^" regexp "\\([^\n]*\\)$") string) - (mapcar (lambda (ref) (match-string ref string)) - (if (sequencep refs) refs (list refs))) - nil)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Zen coding parsers - -(defun zencoding-expr (input) - "Parse a zen coding expression with optional filters." - (zencoding-pif (zencoding-parse "\\(.*?\\)|" 2 "expr|filter" it) - (let ((input (elt it 1)) - (filters (elt it 2))) - (zencoding-pif (zencoding-extract-filters filters) - (zencoding-filter input it) - it)) - (zencoding-filter input (zencoding-default-filter)))) - -(defun zencoding-subexpr (input) - "Parse a zen coding expression with no filter. This pretty much defines precedence." - (zencoding-run zencoding-siblings - it - (zencoding-run zencoding-parent-child - it - (zencoding-run zencoding-multiplier - it - (zencoding-run zencoding-pexpr - it - (zencoding-run zencoding-tag - it - '(error "no match, expecting ( or a-zA-Z0-9"))))))) - -(defun zencoding-extract-filters (input) - "Extract filters from expression." - (zencoding-pif (zencoding-parse "\\([^\\|]+?\\)|" 2 "" it) - (let ((filter-name (elt it 1)) - (more-filters (elt it 2))) - (zencoding-pif (zencoding-extract-filters more-filters) - (cons filter-name it) - it)) - (zencoding-parse "\\([^\\|]+\\)" 1 "filter name" `(,(elt it 1))))) - -(defun zencoding-filter (input filters) - "Construct AST with specified filters." - (zencoding-pif (zencoding-subexpr input) - (let ((result (car it)) - (rest (cdr it))) - `((filter ,filters ,result) . ,rest)) - it)) - -(defun zencoding-default-filter () - "Default filter(s) to be used if none is specified." - (let* ((file-ext (car (zencoding-regex ".*\\(\\..*\\)" (or (buffer-file-name) "") 1))) - (defaults '(".html" ("html") - ".htm" ("html") - ".haml" ("haml") - ".clj" ("hic"))) - (default-else '("html")) - (selected-default (member file-ext defaults))) - (if selected-default - (cadr selected-default) - default-else))) - -(defun zencoding-multiplier (input) - (zencoding-por zencoding-pexpr zencoding-tag - (let ((multiplier expr)) - (zencoding-parse "\\*\\([0-9]+\\)" 2 "*n where n is a number" - (let ((multiplicand (read (elt it 1)))) - `((list ,(make-list multiplicand multiplier)) . ,input)))) - '(error "expected *n multiplier"))) - -(defun zencoding-tag (input) - "Parse a tag." - (zencoding-run zencoding-tagname - (let ((tagname (cadr expr)) - (has-body? (cddr expr))) - (zencoding-pif (zencoding-run zencoding-identifier - (zencoding-tag-classes - `(tag (,tagname ,has-body? ,(cddr expr))) input) - (zencoding-tag-classes - `(tag (,tagname ,has-body? nil)) input)) - (let ((expr (car it)) - (input (cdr it))) - (zencoding-tag-props expr input)))) - (zencoding-default-tag input))) - -(defun zencoding-default-tag (input) - "Parse a #id or .class" - (zencoding-parse "\\([#|\\.]\\)" 1 "tagname" - (zencoding-tag (concat "div" (elt it 0))))) - -(defun zencoding-tag-props (tag input) - (let ((tag-data (cadr tag))) - (zencoding-run zencoding-props - (let ((props (cdr expr))) - `((tag ,(append tag-data (list props))) . ,input)) - `((tag ,(append tag-data '(nil))) . ,input)))) - -(defun zencoding-props (input) - "Parse many props." - (zencoding-run zencoding-prop - (zencoding-pif (zencoding-props input) - `((props . ,(cons expr (cdar it))) . ,(cdr it)) - `((props . ,(list expr)) . ,input)))) - -(defun zencoding-prop (input) - (zencoding-parse - " " 1 "space" - (zencoding-run - zencoding-name - (let ((name (cdr expr))) - (zencoding-pif (zencoding-prop-value name input) - it - `((,(read name) "") . ,input)))))) - -(defun zencoding-prop-value (name input) - (zencoding-pif (zencoding-parse "=\"\\(.*?\\)\"" 2 - "=\"property value\"" - (let ((value (elt it 1)) - (input (elt it 2))) - `((,(read name) ,value) . ,input))) - it - (zencoding-parse "=\\([^\\,\\+\\>\\ )]*\\)" 2 - "=property value" - (let ((value (elt it 1)) - (input (elt it 2))) - `((,(read name) ,value) . ,input))))) - -(defun zencoding-tag-classes (tag input) - (let ((tag-data (cadr tag))) - (zencoding-run zencoding-classes - (let ((classes (mapcar (lambda (cls) (cdadr cls)) - (cdr expr)))) - `((tag ,(append tag-data (list classes))) . ,input)) - `((tag ,(append tag-data '(nil))) . ,input)))) - -(defun zencoding-tagname (input) - "Parse a tagname a-zA-Z0-9 tagname (e.g. html/head/xsl:if/br)." - (zencoding-parse "\\([a-zA-Z][a-zA-Z0-9:-]*\/?\\)" 2 "tagname, a-zA-Z0-9" - (let* ((tag-spec (elt it 1)) - (empty-tag (zencoding-regex "\\([^\/]*\\)\/" tag-spec 1)) - (tag (if empty-tag - (car empty-tag) - tag-spec))) - `((tagname . (,tag . ,(not empty-tag))) . ,input)))) - -(defun zencoding-pexpr (input) - "A zen coding expression with parentheses around it." - (zencoding-parse "(" 1 "(" - (zencoding-run zencoding-subexpr - (zencoding-aif (zencoding-regex ")" input '(0 1)) - `(,expr . ,(elt it 1)) - '(error "expecting `)'"))))) - -(defun zencoding-parent-child (input) - "Parse an tag>e expression, where `n' is an tag and `e' is any - expression." - (zencoding-run zencoding-multiplier - (let* ((items (cadr expr)) - (rest (zencoding-child-sans expr input))) - (if (not (eq (car rest) 'error)) - (let ((child (car rest)) - (input (cdr rest))) - (cons (cons 'list - (cons (mapcar (lambda (parent) - `(parent-child ,parent ,child)) - items) - nil)) - input)) - '(error "expected child"))) - (zencoding-run zencoding-tag - (zencoding-child expr input) - '(error "expected parent")))) - -(defun zencoding-child-sans (parent input) - (zencoding-parse ">" 1 ">" - (zencoding-run zencoding-subexpr - it - '(error "expected child")))) - -(defun zencoding-child (parent input) - (zencoding-parse ">" 1 ">" - (zencoding-run zencoding-subexpr - (let ((child expr)) - `((parent-child ,parent ,child) . ,input)) - '(error "expected child")))) - -(defun zencoding-sibling (input) - (zencoding-por zencoding-pexpr zencoding-multiplier - it - (zencoding-run zencoding-tag - it - '(error "expected sibling")))) - -(defun zencoding-siblings (input) - "Parse an e+e expression, where e is an tag or a pexpr." - (zencoding-run zencoding-sibling - (let ((parent expr)) - (zencoding-parse "\\+" 1 "+" - (zencoding-run zencoding-subexpr - (let ((child expr)) - `((sibling ,parent ,child) . ,input)) - (zencoding-expand parent input)))) - '(error "expected first sibling"))) - -(defvar zencoding-expandable-tags - '("dl" ">(dt+dd)" - "ol" ">li" - "ul" ">li" - "table" ">tr>td")) - -(defun zencoding-expand (parent input) - "Parse an e+ expression, where e is an expandable tag" - (let* ((parent-tag (car (elt parent 1))) - (expandable (member parent-tag zencoding-expandable-tags))) - (if expandable - (let ((expansion (zencoding-child parent (concat (cadr expandable))))) - (zencoding-pif (zencoding-parse "+\\(.*\\)" 1 "+expr" - (zencoding-subexpr (elt it 1))) - `((sibling ,(car expansion) ,(car it))) - expansion)) - '(error "expected second sibling")))) - -(defun zencoding-name (input) - "Parse a class or identifier name, e.g. news, footer, mainimage" - (zencoding-parse "\\([a-zA-Z][a-zA-Z0-9-_:]*\\)" 2 "class or identifer name" - `((name . ,(elt it 1)) . ,input))) - -(defun zencoding-class (input) - "Parse a classname expression, e.g. .foo" - (zencoding-parse "\\." 1 "." - (zencoding-run zencoding-name - `((class ,expr) . ,input) - '(error "expected class name")))) -(defun zencoding-identifier (input) - "Parse an identifier expression, e.g. #foo" - (zencoding-parse "#" 1 "#" - (zencoding-run zencoding-name - `((identifier . ,expr) . ,input)))) - -(defun zencoding-classes (input) - "Parse many classes." - (zencoding-run zencoding-class - (zencoding-pif (zencoding-classes input) - `((classes . ,(cons expr (cdar it))) . ,(cdr it)) - `((classes . ,(list expr)) . ,input)) - '(error "expected class"))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Zen coding transformer from AST to string - -(defvar zencoding-inline-tags - '("a" - "abbr" - "acronym" - "cite" - "code" - "dd" - "dfn" - "dt" - "em" - "h1" "h2" "h3" "h4" "h5" "h6" - "kbd" - "li" - "q" - "span" - "strong" - "var")) - -(defvar zencoding-block-tags - '("p")) - -(defvar zencoding-self-closing-tags - '("br" - "img" - "input")) - -(defvar zencoding-leaf-function nil - "Function to execute when expanding a leaf node in the - Zencoding AST.") - -(defvar zencoding-filters - '("html" (zencoding-primary-filter zencoding-make-html-tag) - "c" (zencoding-primary-filter zencoding-make-commented-html-tag) - "haml" (zencoding-primary-filter zencoding-make-haml-tag) - "hic" (zencoding-primary-filter zencoding-make-hiccup-tag) - "e" (zencoding-escape-xml))) - -(defun zencoding-primary-filter (input proc) - "Process filter that needs to be executed first, ie. not given output from other filter." - (if (listp input) - (let ((tag-maker (cadr proc))) - (zencoding-transform-ast input tag-maker)) - nil)) - -(defun zencoding-process-filter (filters input) - "Process filters, chain one filter output as the input of the next filter." - (let ((filter-data (member (car filters) zencoding-filters)) - (more-filters (cdr filters))) - (if filter-data - (let* ((proc (cadr filter-data)) - (fun (car proc)) - (filter-output (funcall fun input proc))) - (if more-filters - (zencoding-process-filter more-filters filter-output) - filter-output)) - nil))) - -(defun zencoding-make-tag (tag-maker tag-info &optional content) - "Extract tag info and pass them to tag-maker." - (let* ((name (pop tag-info)) - (has-body? (pop tag-info)) - (id (pop tag-info)) - (classes (pop tag-info)) - (props (pop tag-info)) - (self-closing? (not (or content - (and has-body? - (not (member name zencoding-self-closing-tags))))))) - (funcall tag-maker name id classes props self-closing? - (if content content - (if zencoding-leaf-function (funcall zencoding-leaf-function)))))) - -(defun zencoding-make-html-tag (tag-name tag-id tag-classes tag-props self-closing? content) - "Create HTML markup string" - (let* ((id (zencoding-concat-or-empty " id=\"" tag-id "\"")) - (classes (zencoding-mapconcat-or-empty " class=\"" tag-classes " " "\"")) - (props (zencoding-mapconcat-or-empty " " tag-props " " nil - (lambda (prop) - (concat (symbol-name (car prop)) "=\"" (cadr prop) "\"")))) - (content-multiline? (and content (string-match "\n" content))) - (block-tag? (or (member tag-name zencoding-block-tags) - (and (> (length tag-name) 1) - (not (member tag-name zencoding-inline-tags))))) - (lf (if (or content-multiline? block-tag?) - "\n"))) - (concat "<" tag-name id classes props (if self-closing? - "/>" - (concat ">" (if content - (if (or content-multiline? block-tag?) - (zencoding-indent content) - content)) - lf - ""))))) - -(defun zencoding-make-commented-html-tag (tag-name tag-id tag-classes tag-props self-closing? content) - "Create HTML markup string with extra comments for elements with #id or .classes" - (let ((body (zencoding-make-html-tag tag-name tag-id tag-classes tag-props self-closing? content))) - (if (or tag-id tag-classes) - (let ((id (zencoding-concat-or-empty "#" tag-id)) - (classes (zencoding-mapconcat-or-empty "." tag-classes "."))) - (concat "\n" - body - "\n")) - body))) - -(defun zencoding-make-haml-tag (tag-name tag-id tag-classes tag-props self-closing? content) - "Create HAML string" - (let ((name (if (and (equal tag-name "div") - (or tag-id tag-classes)) - "" - (concat "%" tag-name))) - (id (zencoding-concat-or-empty "#" tag-id)) - (classes (zencoding-mapconcat-or-empty "." tag-classes ".")) - (props (zencoding-mapconcat-or-empty "{" tag-props ", " "}" - (lambda (prop) - (concat ":" (symbol-name (car prop)) " => \"" (cadr prop) "\""))))) - (concat name id classes props (if content - (zencoding-indent content))))) - -(defun zencoding-make-hiccup-tag (tag-name tag-id tag-classes tag-props self-closing? content) - "Create Hiccup string" - (let* ((id (zencoding-concat-or-empty "#" tag-id)) - (classes (zencoding-mapconcat-or-empty "." tag-classes ".")) - (props (zencoding-mapconcat-or-empty " {" tag-props ", " "}" - (lambda (prop) - (concat ":" (symbol-name (car prop)) " \"" (cadr prop) "\"")))) - (content-multiline? (and content (string-match "\n" content))) - (block-tag? (or (member tag-name zencoding-block-tags) - (and (> (length tag-name) 1) - (not (member tag-name zencoding-inline-tags)))))) - (concat "[:" tag-name id classes props - (if content - (if (or content-multiline? block-tag?) - (zencoding-indent content) - (concat " " content))) - "]"))) - -(defun zencoding-concat-or-empty (prefix body &optional suffix) - "Return prefixed suffixed text or empty string." - (if body - (concat prefix body suffix) - "")) - -(defun zencoding-mapconcat-or-empty (prefix list-body delimiter &optional suffix map-fun) - "Return prefixed suffixed mapconcated text or empty string." - (if list-body - (let* ((mapper (if map-fun map-fun 'identity)) - (body (mapconcat mapper list-body delimiter))) - (concat prefix body suffix)) - "")) - -(defun zencoding-escape-xml (input proc) - "Escapes XML-unsafe characters: <, > and &." - (replace-regexp-in-string - "<" "<" - (replace-regexp-in-string - ">" ">" - (replace-regexp-in-string - "&" "&" - (if (stringp input) - input - (zencoding-process-filter (zencoding-default-filter) input)))))) - -(defun zencoding-transform (ast-with-filters) - "Transform AST (containing filter data) into string." - (let ((filters (cadr ast-with-filters)) - (ast (caddr ast-with-filters))) - (zencoding-process-filter filters ast))) - -(defun zencoding-transform-ast (ast tag-maker) - "Transform AST (without filter data) into string." - (let ((type (car ast))) - (cond - ((eq type 'list) - (mapconcat (lexical-let ((make-tag-fun tag-maker)) - #'(lambda (sub-ast) - (zencoding-transform-ast sub-ast make-tag-fun))) - (cadr ast) - "\n")) - ((eq type 'tag) - (zencoding-make-tag tag-maker (cadr ast))) - ((eq type 'parent-child) - (let ((parent (cadadr ast)) - (children (zencoding-transform-ast (caddr ast) tag-maker))) - (zencoding-make-tag tag-maker parent children))) - ((eq type 'sibling) - (let ((sib1 (zencoding-transform-ast (cadr ast) tag-maker)) - (sib2 (zencoding-transform-ast (caddr ast) tag-maker))) - (concat sib1 "\n" sib2)))))) - -(defun zencoding-indent (text) - "Indent the text" - (if text - (replace-regexp-in-string "\n" "\n " (concat "\n" text)) - nil)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Test-cases - -(defun zencoding-test-cases () - (let ((tests '(;; Tags - ("a" "") - ("a.x" "") - ("a#q.x" "") - ("a#q.x.y.z" "") - ("#q" "
" - "
") - (".x" "
" - "
") - ("#q.x" "
" - "
") - ("#q.x.y.z" "
" - "
") - ;; Empty tags - ("a/" "") - ("a/.x" "") - ("a/#q.x" "") - ("a/#q.x.y.z" "") - ;; Self-closing tags - ("input type=text" "") - ("img" "") - ("img>metadata/*2" "" - " " - " " - "") - ;; Siblings - ("a+b" "" - "") - ("a+b+c" "" - "" - "") - ("a.x+b" "" - "") - ("a#q.x+b" "" - "") - ("a#q.x.y.z+b" "" - "") - ("a#q.x.y.z+b#p.l.m.n" "" - "") - ;; Tag expansion - ("table+" "" - " " - " " - " " - "
" - "
") - ("dl+" "
" - "
" - "
" - "
") - ("ul+" "
    " - "
  • " - "
") - ("ul++ol+" "
    " - "
  • " - "
" - "
    " - "
  1. " - "
") - ("ul#q.x.y m=l+" "
    " - "
  • " - "
") - ;; Parent > child - ("a>b" "") - ("a>b>c" "") - ("a.x>b" "") - ("a#q.x>b" "") - ("a#q.x.y.z>b" "") - ("a#q.x.y.z>b#p.l.m.n" "") - ("#q>.x" "
" - "
" - "
" - "
") - ("a>b+c" "" - " " - " " - "") - ("a>b+c>d" "" - " " - " " - "") - ;; Multiplication - ("a*1" "") - ("a*2" "" - "") - ("a/*2" "" - "") - ("a*2+b*2" "" - "" - "" - "") - ("a*2>b*2" "" - " " - " " - "" - "" - " " - " " - "") - ("a>b*2" "" - " " - " " - "") - ("a#q.x>b#q.x*2" "" - " " - " " - "") - ("a#q.x>b/#q.x*2" "" - " " - " " - "") - ;; Properties - ("a x" "") - ("a x=" "") - ("a x=\"\"" "") - ("a x=y" "") - ("a x=\"y\"" "") - ("a x=\"()\"" "") - ("a x m" "") - ("a x= m=\"\"" "") - ("a x=y m=l" "") - ("a/ x=y m=l" "") - ("a#foo x=y m=l" "") - ("a.foo x=y m=l" "") - ("a#foo.bar.mu x=y m=l" "") - ("a/#foo.bar.mu x=y m=l" "") - ("a x=y+b" "" - "") - ("a x=y+b x=y" "" - "") - ("a x=y>b" "") - ("a x=y>b x=y" "") - ("a x=y>b x=y+c x=y" "" - " " - " " - "") - ;; Parentheses - ("(a)" "") - ("(a)+(b)" "" - "") - ("a>(b)" "") - ("(a>b)>c" "") - ("(a>b)+c" "" - "") - ("z+(a>b)+c+k" "" - "" - "" - "") - ("(a)*2" "" - "") - ("((a)*2)" "" - "") - ("((a))*2" "" - "") - ("(a>b)*2" "" - "") - ("(a+b)*2" "" - "" - "" - "") - ;; Filter: comment - ("a.b|c" "" - "" - "") - ("#a>.b|c" "" - "
" - " " - "
" - "
" - " " - "
" - "") - ;; Filter: HAML - ("a|haml" "%a") - ("a#q.x.y.z|haml" "%a#q.x.y.z") - ("a#q.x x=y m=l|haml" "%a#q.x{:x => \"y\", :m => \"l\"}") - ("div|haml" "%div") - ("div.footer|haml" ".footer") - (".footer|haml" ".footer") - ("p>a href=#+br|haml" "%p" - " %a{:href => \"#\"}" - " %br") - ;; Filter: Hiccup - ("a|hic" "[:a]") - ("a#q.x.y.z|hic" "[:a#q.x.y.z]") - ("a#q.x x=y m=l|hic" "[:a#q.x {:x \"y\", :m \"l\"}]") - (".footer|hic" "[:div.footer]") - ("p>a href=#+br|hic" "[:p" - " [:a {:href \"#\"}]" - " [:br]]") - ("#q>(a*2>b)+p>b|hic" "[:div#q" - " [:a [:b]]" - " [:a [:b]]" - " [:p" - " [:b]]]") - ;; Filter: escape - ("script src="|e" "<script src=\"&quot;\">" - "</script>") - ))) - (mapc (lambda (input) - (let ((expected (mapconcat 'identity (cdr input) "\n")) - (actual (zencoding-transform (car (zencoding-expr (car input)))))) - (if (not (equal expected actual)) - (error (concat "Assertion " (car input) " failed:" - expected - " == " - actual))))) - tests) - (concat (number-to-string (length tests)) " tests performed. All OK."))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Zencoding minor mode - -(defgroup zencoding nil - "Customization group for zencoding-mode." - :group 'convenience) - -(defun zencoding-expr-on-line () - "Extract a zencoding expression and the corresponding bounds - for the current line." - (let* ((start (line-beginning-position)) - (end (line-end-position)) - (line (buffer-substring-no-properties start end)) - (expr (zencoding-regex "\\([ \t]*\\)\\([^\n]+\\)" line 2))) - (if (first expr) - (list (first expr) start end)))) - -(defcustom zencoding-indentation 4 - "Number of spaces used for indentation." - :type '(number :tag "Spaces") - :group 'zencoding) - -(defun zencoding-prettify (markup indent) - (let ((first-col (format (format "%%%ds" indent) "")) - (tab (format (format "%%%ds" zencoding-indentation) ""))) - (concat first-col - (replace-regexp-in-string "\n" (concat "\n" first-col) - (replace-regexp-in-string " " tab markup))))) - -;;;###autoload -(defun zencoding-expand-line (arg) - "Replace the current line's zencode expression with the corresponding expansion. -If prefix ARG is given or region is visible call `zencoding-preview' to start an -interactive preview. - -Otherwise expand line directly. - -For more information see `zencoding-mode'." - (interactive "P") - (let* ((here (point)) - (preview (if zencoding-preview-default (not arg) arg)) - (beg (if preview - (progn - (beginning-of-line) - (skip-chars-forward " \t") - (point)) - (when mark-active (region-beginning)))) - (end (if preview - (progn - (end-of-line) - (skip-chars-backward " \t") - (point)) - (when mark-active (region-end))))) - (if beg - (progn - (goto-char here) - (zencoding-preview beg end)) - (let ((expr (zencoding-expr-on-line))) - (if expr - (let* ((markup (zencoding-transform (car (zencoding-expr (first expr))))) - (pretty (zencoding-prettify markup (current-indentation)))) - (save-excursion - (delete-region (second expr) (third expr)) - (zencoding-insert-and-flash pretty)))))))) - -(defvar zencoding-mode-keymap nil - "Keymap for zencode minor mode.") - -(if zencoding-mode-keymap - nil - (progn - (setq zencoding-mode-keymap (make-sparse-keymap)) - (define-key zencoding-mode-keymap (kbd "C-j") 'zencoding-expand-line) - (define-key zencoding-mode-keymap (kbd "") 'zencoding-expand-line))) - -;;;###autoload -(define-minor-mode zencoding-mode - "Minor mode for writing HTML and CSS markup. -With zen coding for HTML and CSS you can write a line like - - ul#name>li.item*2 - -and have it expanded to - -
    -
  • -
  • -
- -This minor mode defines keys for quick access: - -\\{zencoding-mode-keymap} - -Home page URL `http://www.emacswiki.org/emacs/ZenCoding'. - -See also `zencoding-expand-line'." - :lighter " Zen" - :keymap zencoding-mode-keymap) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Zencoding yasnippet integration - -(defun zencoding-transform-yas (ast) - (let* ((leaf-count 0) - (zencoding-leaf-function - (lambda () - (format "$%d" (incf leaf-count))))) - (zencoding-transform ast))) - -;;;###autoload -(defun zencoding-expand-yas () - (interactive) - (let ((expr (zencoding-expr-on-line))) - (if expr - (let* ((markup (zencoding-transform-yas (car (zencoding-expr (first expr))))) - (filled (replace-regexp-in-string "><" ">\n<" markup))) - (delete-region (second expr) (third expr)) - (insert filled) - (indent-region (second expr) (point)) - (yas/expand-snippet - (buffer-substring (second expr) (point)) - (second expr) (point)))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Real-time preview -;; - -;;;;;;;;;; -;; Lennart's version - -(defvar zencoding-preview-input nil) -(make-local-variable 'zencoding-preview-input) -(defvar zencoding-preview-output nil) -(make-local-variable 'zencoding-preview-output) -(defvar zencoding-old-show-paren nil) -(make-local-variable 'zencoding-old-show-paren) - -(defface zencoding-preview-input - '((default :box t :inherit secondary-selection)) - "Face for preview input field." - :group 'zencoding) - -(defface zencoding-preview-output - '((default :inherit highlight)) - "Face for preview output field." - :group 'zencoding) - -(defvar zencoding-preview-keymap - (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'zencoding-preview-accept) - (define-key map (kbd "") 'zencoding-preview-accept) - (define-key map [(control ?g)] 'zencoding-preview-abort) - map)) - -(defun zencoding-preview-accept () - (interactive) - (let ((ovli zencoding-preview-input)) - (if (not (and (overlayp ovli) - (bufferp (overlay-buffer ovli)))) - (message "Preview is not active") - (let* ((indent (current-indentation)) - (markup (zencoding-preview-transformed indent))) - (when markup - (delete-region (line-beginning-position) (overlay-end ovli)) - (zencoding-insert-and-flash markup))))) - (zencoding-preview-abort)) - -(defvar zencoding-flash-ovl nil) -(make-variable-buffer-local 'zencoding-flash-ovl) - -(defun zencoding-remove-flash-ovl (buf) - (with-current-buffer buf - (when (overlayp zencoding-flash-ovl) - (delete-overlay zencoding-flash-ovl)) - (setq zencoding-flash-ovl nil))) - -(defcustom zencoding-preview-default t - "If non-nil then preview is the default action. -This determines how `zencoding-expand-line' works by default." - :type 'boolean - :group 'zencoding) - -(defcustom zencoding-insert-flash-time 0.5 - "Time to flash insertion. -Set this to a negative number if you do not want flashing the -expansion after insertion." - :type '(number :tag "Seconds") - :group 'zencoding) - -(defun zencoding-insert-and-flash (markup) - (zencoding-remove-flash-ovl (current-buffer)) - (let ((here (point))) - (insert markup) - (setq zencoding-flash-ovl (make-overlay here (point))) - (overlay-put zencoding-flash-ovl 'face 'zencoding-preview-output) - (when (< 0 zencoding-insert-flash-time) - (run-with-idle-timer zencoding-insert-flash-time - nil 'zencoding-remove-flash-ovl (current-buffer))))) - -;;;###autoload -(defun zencoding-preview (beg end) - "Expand zencode between BEG and END interactively. -This will show a preview of the expanded zen code and you can -accept it or skip it." - (interactive (if mark-active - (list (region-beginning) (region-end)) - (list nil nil))) - (zencoding-preview-abort) - (if (not beg) - (message "Region not active") - (setq zencoding-old-show-paren show-paren-mode) - (show-paren-mode -1) - (let ((here (point))) - (goto-char beg) - (forward-line 1) - (unless (= 0 (current-column)) - (insert "\n")) - (let* ((opos (point)) - (ovli (make-overlay beg end nil nil t)) - (ovlo (make-overlay opos opos)) - (info (propertize " Zen preview. Choose with RET. Cancel by stepping out. \n" - 'face 'tooltip))) - (overlay-put ovli 'face 'zencoding-preview-input) - (overlay-put ovli 'keymap zencoding-preview-keymap) - (overlay-put ovlo 'face 'zencoding-preview-output) - (overlay-put ovlo 'before-string info) - (setq zencoding-preview-input ovli) - (setq zencoding-preview-output ovlo) - (add-hook 'before-change-functions 'zencoding-preview-before-change t t) - (goto-char here) - (add-hook 'post-command-hook 'zencoding-preview-post-command t t))))) - -(defvar zencoding-preview-pending-abort nil) -(make-variable-buffer-local 'zencoding-preview-pending-abort) - -(defun zencoding-preview-before-change (beg end) - (when - (or (> beg (overlay-end zencoding-preview-input)) - (< beg (overlay-start zencoding-preview-input)) - (> end (overlay-end zencoding-preview-input)) - (< end (overlay-start zencoding-preview-input))) - (setq zencoding-preview-pending-abort t))) - -(defun zencoding-preview-abort () - "Abort zen code preview." - (interactive) - (setq zencoding-preview-pending-abort nil) - (remove-hook 'before-change-functions 'zencoding-preview-before-change t) - (when (overlayp zencoding-preview-input) - (delete-overlay zencoding-preview-input)) - (setq zencoding-preview-input nil) - (when (overlayp zencoding-preview-output) - (delete-overlay zencoding-preview-output)) - (setq zencoding-preview-output nil) - (remove-hook 'post-command-hook 'zencoding-preview-post-command t) - (when zencoding-old-show-paren (show-paren-mode 1))) - -(defun zencoding-preview-post-command () - (condition-case err - (zencoding-preview-post-command-1) - (error (message "zencoding-preview-post: %s" err)))) - -(defun zencoding-preview-post-command-1 () - (if (and (not zencoding-preview-pending-abort) - (<= (point) (overlay-end zencoding-preview-input)) - (>= (point) (overlay-start zencoding-preview-input))) - (zencoding-update-preview (current-indentation)) - (zencoding-preview-abort))) - -(defun zencoding-preview-transformed (indent) - (let* ((string (buffer-substring-no-properties - (overlay-start zencoding-preview-input) - (overlay-end zencoding-preview-input))) - (ast (car (zencoding-expr string)))) - (when (not (eq ast 'error)) - (let ((output (zencoding-transform ast))) - (when output - (zencoding-prettify output indent)))))) - -(defun zencoding-update-preview (indent) - (let* ((pretty (zencoding-preview-transformed indent)) - (show (when pretty - (propertize pretty 'face 'highlight)))) - (when show - (overlay-put zencoding-preview-output 'after-string - (concat show "\n"))))) - -(provide 'zencoding-mode) - -;;; zencoding-mode.el ends here