git.fiddlerwoaroof.com
Browse code

Initial commit

Paulo Madeira authored on 22/10/2013 22:45:00
Showing 1 changed files
editor-color-theme.lisp
History View file @ 461c094
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,240 @@
1 
+;;;; Interface
2 
+
3 
+(cl:in-package #:cl-user)
4 
+
5 
+(defpackage #:editor-color-theme
6 
+  (:use #:cl)
7 
+  (:export #:*foreground-color*
8 
+	   #:*background-color*
9 
+	   #:all-color-themes
10 
+	   #:color-theme-args
11 
+	   #:color-theme
12 
+	   #:define-color-theme
13 
+	   #:remove-color-theme
14 
+	   ))
15 
+
16 
+(in-package #:editor-color-theme)
17 
+
18 
+
19 
+;;;; Configuration
20 
+
21 
+(defvar *foreground-color* nil)
22 
+
23 
+(defvar *background-color* nil)
24 
+
25 
+
26 
+;;;; Implementation
27 
+
28 
+(defvar *all-color-themes* (make-hash-table :test 'string=))
29 
+
30 
+(defun all-color-themes ()
31 
+  (maphash #'(lambda (key value)
32 
+	       (declare (ignore value))
33 
+	       key)
34 
+	   *all-color-themes*))
35 
+
36 
+(defun color-theme-data (theme-name)
37 
+  (multiple-value-bind (color-theme-data found?)
38 
+      (gethash theme-name *all-color-themes*)
39 
+    (if found?
40 
+	color-theme-data
41 
+	(error "No color theme named ~s found." theme-name))))
42 
+
43 
+(defun color-theme-super-theme-names (theme-name)
44 
+  (first (color-theme-data theme-name)))
45 
+
46 
+(defun color-theme-args (theme-name)
47 
+  (rest (color-theme-data theme-name)))
48 
+
49 
+(defvar *all-editor-panes* (make-hash-table :test 'eq
50 
+					    :weak-kind :key))
51 
+
52 
+(defun update-editor-pane (pane)
53 
+  (setf (capi:simple-pane-foreground pane) (or *foreground-color* :color_windowtext))
54 
+  (setf (capi:simple-pane-background pane) (or *background-color* :color_window))
55 
+
56 
+  (let ((recolorize-p (editor::buffer-font-lock-mode-p (capi:editor-pane-buffer pane))))
57 
+    (when recolorize-p
58 
+      (gp:invalidate-rectangle pane)))
59 
+  (values))
60 
+
61 
+(defun update-editor-panes ()
62 
+  (maphash #'(lambda (pane value)
63 
+	       (declare (ignore value))
64 
+	       (update-editor-pane pane))
65 
+	   *all-editor-panes*)
66 
+  (values))
67 
+
68 
+(defvar *editor-face-names*
69 
+  '(:region
70 
+    :show-point-face
71 
+    :interactive-input-face
72 
+    :highlight
73 
+    :non-focus-complete-face
74 
+    :font-lock-function-name-face
75 
+    :font-lock-comment-face
76 
+    :font-lock-type-face
77 
+    :font-lock-variable-name-face
78 
+    :font-lock-string-face
79 
+    :font-lock-keyword-face
80 
+    :font-lock-builtin-face
81 
+    :compiler-note-highlight
82 
+    :compiler-warning-highlight
83 
+    :compiler-error-highlight
84 
+    ))
85 
+
86 
+(defun set-color-theme (theme-name)
87 
+  (destructuring-bind (&rest color-theme-args
88 
+		       &key foreground background &allow-other-keys)
89 
+      (color-theme-args theme-name)
90 
+
91 
+    (setf *foreground-color* (or foreground :color_windowtext))
92 
+    (setf *background-color* (or background :color_window))
93 
+
94 
+    (dolist (name *editor-face-names*)
95 
+      (let* ((color-theme-args-for-face (getf color-theme-args name))
96 
+	     (face-name (intern (string name) '#:editor))
97 
+	     (face (editor:make-face face-name :if-exists t)))
98 
+	(apply 'editor:make-face face-name :if-exists :overwrite
99 
+	       :documentation (or (getf color-theme-args-for-face :documentation)
100 
+				  (slot-value face 'documentation))
101 
+	       color-theme-args-for-face))))
102 
+
103 
+  theme-name)
104 
+
105 
+(defun color-theme (theme-name)
106 
+  (mapc 'set-color-theme (color-theme-super-theme-names theme-name))
107 
+  (set-color-theme theme-name)
108 
+
109 
+  (update-editor-panes)
110 
+
111 
+  theme-name)
112 
+
113 
+(defun define-color-theme (theme-name super-theme-names
114 
+			   &rest color-theme-args &key &allow-other-keys)
115 
+  (dolist (super-theme-name super-theme-names)
116 
+    (multiple-value-bind (color-theme-data found?)
117 
+	(gethash super-theme-name *all-color-themes*)
118 
+      (declare (ignore color-theme-data))
119 
+      (unless found?
120 
+	(warn "Inherited color theme ~s not defined." super-theme-name))))
121 
+
122 
+  (setf (gethash theme-name *all-color-themes*) (list* super-theme-names color-theme-args))
123 
+
124 
+  theme-name)
125 
+
126 
+(defun remove-color-theme (theme-name)
127 
+  (remhash theme-name *all-color-themes*))
128 
+
129 
+(sys::without-warning-on-redefinition
130 
+  (defmethod initialize-instance :around ((pane capi:editor-pane) &key &allow-other-keys)
131 
+    (multiple-value-prog1
132 
+	(call-next-method)
133 
+
134 
+      (setf (gethash pane *all-editor-panes*) pane)
135 
+
136 
+      (when *foreground-color*
137 
+	(setf (capi:simple-pane-foreground pane) *foreground-color*))
138 
+      (when *background-color*
139 
+	(setf (capi:simple-pane-background pane) *background-color*))))
140 
+  )
141 
+
142 
+;; This makes it "work" after the podium is launched
143 
+(defun is-editor-pane-p (obj)
144 
+  (and (typep obj 'capi:editor-pane)
145 
+       (not (eq obj (hcl:class-prototype (class-of obj))))))
146 
+
147 
+(defun cache-existing-pane (pane)
148 
+  (setf (gethash pane *all-editor-panes*) pane))
149 
+
150 
+(defun cache-if-pane (obj)
151 
+  (when (is-editor-pane-p obj)
152 
+    (cache-existing-pane obj)))
153 
+
154 
+#+:lispworks-personal-edition
155 
+(hcl:sweep-all-objects #'cache-if-pane)
156 
+
157 
+
158 
+;;; Initial color themes
159 
+
160 
+(define-color-theme "default" ()
161 
+  :foreground nil :background nil
162 
+  :region '(:foreground :color_highlighttext
163 
+	    :background :color_highlight)
164 
+  :show-point-face '(:background :green)
165 
+  :interactive-input-face '(:foreground :red3)
166 
+  :highlight '(:bold-p t)
167 
+  :non-focus-complete-face '(:background :tweak_background)
168 
+  :font-lock-function-name-face '(:foreground :blue)
169 
+  :font-lock-comment-face '(:foreground :firebrick)
170 
+  :font-lock-type-face '(:foreground :forestgreen)
171 
+  :font-lock-variable-name-face '(:foreground :darkgoldenrod)
172 
+  :font-lock-string-face '(:foreground :rosybrown)
173 
+  :font-lock-keyword-face '(:foreground :purple)
174 
+  :font-lock-builtin-face '(:foreground :orchid)
175 
+  :compiler-note-highlight '(:foreground :magenta)
176 
+  :compiler-warning-highlight '(:foreground :orange3)
177 
+  :compiler-error-highlight '(:foreground :red))
178 
+
179 
+(define-color-theme "plain" ()
180 
+  :foreground nil :background nil
181 
+  :region '(:foreground :color_highlighttext
182 
+	    :background :color_highlight)
183 
+  :show-point-face '()
184 
+  :interactive-input-face '()
185 
+  :highlight '(:bold-p t)
186 
+  :non-focus-complete-face '(:background :tweak_background)
187 
+  :font-lock-function-name-face '()
188 
+  :font-lock-comment-face '()
189 
+  :font-lock-type-face '()
190 
+  :font-lock-variable-name-face '()
191 
+  :font-lock-string-face '()
192 
+  :font-lock-keyword-face '()
193 
+  :font-lock-builtin-face '()
194 
+  :compiler-note-highlight '()
195 
+  :compiler-warning-highlight '()
196 
+  :compiler-error-highlight '())
197 
+
198 
+(define-color-theme "emacs" ()
199 
+  :foreground nil :background nil
200 
+  :region '(:foreground :color_highlighttext
201 
+	    :background :color_highlight)
202 
+  :show-point-face '(:background :green)
203 
+  :interactive-input-face '(:foreground :red3)
204 
+  :highlight '(:bold-p t)
205 
+  :non-focus-complete-face '(:background :tweak_background)
206 
+  :font-lock-function-name-face '(:foreground :blue)
207 
+  :font-lock-comment-face '(:foreground :gray40)
208 
+  :font-lock-type-face '(:foreground :forestgreen)
209 
+  :font-lock-variable-name-face '(:foreground :darkgoldenrod)
210 
+  :font-lock-string-face '(:foreground :rosybrown)
211 
+  :font-lock-keyword-face '(:foreground :purple)
212 
+  :font-lock-builtin-face '(:foreground :orchid)
213 
+  :compiler-note-highlight '(:foreground :magenta)
214 
+  :compiler-warning-highlight '(:foreground :orange3)
215 
+  :compiler-error-highlight '(:foreground :red))
216 
+
217 
+(define-color-theme "torte" ()
218 
+  :foreground (color:make-rgb 0.8s0 0.8s0 0.8s0)
219 
+  :background (color:make-rgb 0.0s0 0.0s0 0.0s0)
220 
+  :region '(:foreground :color_highlighttext
221 
+	    :background :color_highlight)
222 
+  :show-point-face `(:background ,(color:make-rgb 0.6275s0 0.1255s0 0.9412s0))
223 
+  :interactive-input-face '(:foreground :pink)
224 
+  :highlight '(:bold-p t)
225 
+  :non-focus-complete-face '(:background :tweak_background)
226 
+  :font-lock-function-name-face `(:foreground ,(color:make-rgb 0.0s0 1.0s0 1.0s0))
227 
+  :font-lock-comment-face `(:foreground ,(color:make-rgb 0.5s0 0.6275s0 1.0s0))
228 
+  :font-lock-type-face `(:foreground ,(color:make-rgb 0.5s0 1.0s0 0.5s0))
229 
+  :font-lock-variable-name-face `(:foreground ,(color:make-rgb 1.0s0 1.0s0 1.0s0))
230 
+  :font-lock-string-face `(:foreground ,(color:make-rgb 1.0s0 0.6275s0 0.6275s0))
231 
+  :font-lock-keyword-face `(:foreground ,(color:make-rgb 1.0s0 1.0s0 0.0s0))
232 
+  :font-lock-builtin-face `(:foreground ,(color:make-rgb 1.0s0 1.0s0 0.0s0))
233 
+  :compiler-note-highlight '(:foreground :magenta)
234 
+  :compiler-warning-highlight '(:foreground :orange)
235 
+  :compiler-error-highlight '(:foreground :red))
236 
+
237 
+
238 
+;;; Show presence when loaded
239 
+(pushnew :lw-editor-color-theme *features*)
240 
+