Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 344 lines (324 sloc) 18.126 kb
d471483 Initial import of colorize.
chandler authored
1 ;;;; colorize.lisp
2
3 (in-package :colorize)
4
5 (eval-when (:compile-toplevel :load-toplevel :execute)
6 (defparameter *coloring-types* nil)
7 (defparameter *version-token* (gensym)))
8
9 (defclass coloring-type ()
499e33e @redline6561 Backport changes from lisppaste 2.3. (i.e. haskell, erlang, python, etc)
authored
10 ((default-mode :initarg :default-mode :accessor coloring-type-default-mode)
d471483 Initial import of colorize.
chandler authored
11 (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions)
12 (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name)
13 (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter)
14 (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil)
15 (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly ""))
16 (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function
17 :initform (constantly nil))
18 (parent-type :initarg :parent-type :accessor coloring-type-parent-type
19 :initform nil)
20 (visible :initarg :visible :accessor coloring-type-visible
21 :initform t)))
22
23 (defun find-coloring-type (type)
24 (if (typep type 'coloring-type)
25 type
26 (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name))))
27
28 (defun autodetect-coloring-type (name)
29 (car
30 (find name *coloring-types*
31 :key #'cdr
32 :test #'(lambda (name type)
33 (and (coloring-type-visible type)
34 (funcall (coloring-type-autodetect-function type) name))))))
35
36 (defun coloring-types ()
341e34f @redline6561 Add docs and README, minor code cleanup.
authored
37 "Return the supported coloring types as a list of dotted pairs of the form,
38 (:keyword . \"coloring-type\")."
d471483 Initial import of colorize.
chandler authored
39 (loop for type-pair in *coloring-types*
40 if (coloring-type-visible (cdr type-pair))
41 collect (cons (car type-pair)
42 (coloring-type-fancy-name (cdr type-pair)))))
43
44 (defun (setf find-coloring-type) (new-value type)
45 (if new-value
46 (let ((found (assoc type *coloring-types*)))
47 (if found
48 (setf (cdr found) new-value)
49 (setf *coloring-types*
50 (nconc *coloring-types*
51 (list (cons type new-value))))))
52 (setf *coloring-types* (remove type *coloring-types* :key #'car))))
53
54 (defvar *scan-calls* 0)
55
56 (defvar *reset-position* nil)
57
58 (defmacro with-gensyms ((&rest names) &body body)
59 `(let ,(mapcar #'(lambda (name)
60 (list name `(make-symbol ,(symbol-name name)))) names)
61 ,@body))
62
63 (defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body)
64 (with-gensyms (num items position not-preceded-by string item new-mode until advancing)
65 `(labels ((advance (,num)
66 (setf ,position-place (+ ,position-place ,num))
67 t)
499e33e @redline6561 Backport changes from lisppaste 2.3. (i.e. haskell, erlang, python, etc)
authored
68 (peek-any (,items &key ,not-preceded-by)
d471483 Initial import of colorize.
chandler authored
69 (incf *scan-calls*)
70 (let* ((,items (if (stringp ,items)
71 (coerce ,items 'list) ,items))
72 (,not-preceded-by (if (characterp ,not-preceded-by)
73 (string ,not-preceded-by) ,not-preceded-by))
74 (,position ,position-place)
75 (,string ,string-param))
76 (let ((,item (and
77 (< ,position (length ,string))
78 (find ,string ,items
79 :test #'(lambda (,string ,item)
80 #+nil
81 (format t "looking for ~S in ~S starting at ~S~%"
82 ,item ,string ,position)
83 (if (characterp ,item)
84 (char= (elt ,string ,position)
85 ,item)
86 (search ,item ,string :start2 ,position
87 :end2 (min (length ,string)
88 (+ ,position (length ,item))))))))))
89 (if (characterp ,item)
90 (setf ,item (string ,item)))
91 (if
92 (if ,item
93 (if ,not-preceded-by
94 (if (>= (- ,position (length ,not-preceded-by)) 0)
95 (not (string= (subseq ,string
96 (- ,position (length ,not-preceded-by))
97 ,position)
98 ,not-preceded-by))
99 t)
100 t)
101 nil)
499e33e @redline6561 Backport changes from lisppaste 2.3. (i.e. haskell, erlang, python, etc)
authored
102 ,item
d471483 Initial import of colorize.
chandler authored
103 (progn
104 (and *reset-position*
105 (setf ,position-place *reset-position*))
106 nil)))))
499e33e @redline6561 Backport changes from lisppaste 2.3. (i.e. haskell, erlang, python, etc)
authored
107 (scan-any (,items &key ,not-preceded-by)
108 (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by)))
109 (and ,item (advance (length ,item)))))
110 (peek (,item &key ,not-preceded-by)
111 (peek-any (list ,item) :not-preceded-by ,not-preceded-by))
d471483 Initial import of colorize.
chandler authored
112 (scan (,item &key ,not-preceded-by)
113 (scan-any (list ,item) :not-preceded-by ,not-preceded-by)))
114 (macrolet ((set-mode (,new-mode &key ,until (,advancing t))
115 (list 'progn
116 (list 'setf ',mode-place ,new-mode)
117 (list 'setf ',mode-wait-place
118 (list 'lambda (list ',position)
119 (list 'let (list (list '*reset-position* ',position))
120 (list 'values ,until ,advancing)))))))
121 ,@body))))
122
123 (defvar *formatter-local-variables*)
124
499e33e @redline6561 Backport changes from lisppaste 2.3. (i.e. haskell, erlang, python, etc)
authored
125 (defmacro define-coloring-type (name fancy-name &key default-mode transitions formatters
d471483 Initial import of colorize.
chandler authored
126 autodetect parent formatter-variables (formatter-after-hook '(constantly ""))
127 invisible)
128 (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance)
129 `(let ((,parent-type (or (find-coloring-type ,parent)
130 (and ,parent
131 (error "No such coloring type: ~S" ,parent)))))
132 (setf (find-coloring-type ,name)
133 (make-instance 'coloring-type
134 :fancy-name ',fancy-name
135 :default-mode (or ',default-mode
136 (if ,parent-type (coloring-type-default-mode ,parent-type)))
137 ,@(if autodetect
138 `(:autodetect-function ,autodetect))
139 :parent-type ,parent-type
140 :visible (not ,invisible)
141 :formatter-initial-values (lambda nil
142 (list* ,@(mapcar #'(lambda (e)
143 `(cons ',(car e) ,(second e)))
144 formatter-variables)
145 (if ,parent-type
146 (funcall (coloring-type-formatter-initial-values ,parent-type))
147 nil)))
148 :formatter-after-hook (lambda nil
149 (symbol-macrolet ,(mapcar #'(lambda (e)
150 `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
151 formatter-variables)
152 (concatenate 'string
153 (funcall ,formatter-after-hook)
154 (if ,parent-type
155 (funcall (coloring-type-formatter-after-hook ,parent-type))
156 ""))))
157 :term-formatter
158 (symbol-macrolet ,(mapcar #'(lambda (e)
159 `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
160 formatter-variables)
161 (lambda (,term)
162 (labels ((call-parent-formatter (&optional (,type (car ,term))
163 (,string (cdr ,term)))
164 (if ,parent-type
165 (funcall (coloring-type-term-formatter ,parent-type)
166 (cons ,type ,string))))
167 (call-formatter (&optional (,type (car ,term))
168 (,string (cdr ,term)))
169 (funcall
170 (case (first ,type)
171 ,@formatters
172 (t (lambda (,type text)
173 (call-parent-formatter ,type text))))
174 ,type ,string)))
175 (call-formatter))))
176 :transition-functions
177 (list
178 ,@(loop for transition in transitions
179 collect (destructuring-bind (mode &rest table) transition
180 `(cons ',mode
181 (lambda (,current-mode ,string ,position)
182 (let ((,mode-wait (constantly nil))
183 (,position-foobage ,position))
184 (with-scanning-functions ,string ,position-foobage
185 ,current-mode ,mode-wait
186 (let ((*reset-position* ,position))
187 (cond ,@table))
188 (values ,position-foobage ,current-mode
189 (lambda (,new-position)
190 (setf ,position-foobage ,new-position)
191 (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage))))
192 (values ,position-foobage ,advance)))))
193 )))))))))))
194
195 (defun full-transition-table (coloring-type-object)
196 (let ((parent (coloring-type-parent-type coloring-type-object)))
197 (if parent
198 (append (coloring-type-transition-functions coloring-type-object)
199 (full-transition-table parent))
200 (coloring-type-transition-functions coloring-type-object))))
201
202 (defun scan-string (coloring-type string)
203 (let* ((coloring-type-object (or (find-coloring-type coloring-type)
204 (error "No such coloring type: ~S" coloring-type)))
205 (transitions (full-transition-table coloring-type-object))
206 (result nil)
207 (low-bound 0)
208 (current-mode (coloring-type-default-mode coloring-type-object))
209 (mode-stack nil)
210 (current-wait (constantly nil))
211 (wait-stack nil)
212 (current-position 0)
213 (*scan-calls* 0))
214 (flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop)
215 (let ((to (if extend new-position current-position)))
216 (if (> to low-bound)
217 (setf result (nconc result
218 (list (cons (cons current-mode mode-stack)
219 (subseq string low-bound
220 to))))))
221 (setf low-bound to)
222 (when pop
223 (pop mode-stack)
224 (pop wait-stack))
225 (when push
226 (push current-mode mode-stack)
227 (push current-wait wait-stack))
228 (setf current-mode new-mode
229 current-position new-position
230 current-wait new-wait))))
231 (loop
232 (if (> current-position (length string))
233 (return-from scan-string
234 (progn
235 (format *trace-output* "Scan was called ~S times.~%"
236 *scan-calls*)
237 (finish-current (length string) nil (constantly nil))
238 result))
239 (or
240 (loop for transition in
241 (mapcar #'cdr
242 (remove current-mode transitions
243 :key #'car
244 :test-not #'(lambda (a b)
245 (or (eql a b)
246 (if (listp b)
247 (member a b))))))
248 if
249 (and transition
250 (multiple-value-bind
251 (new-position new-mode new-wait)
252 (funcall transition current-mode string current-position)
253 (when (> new-position current-position)
254 (finish-current new-position new-mode new-wait :extend nil :push t)
255 t)))
256 return t)
257 (multiple-value-bind
258 (pos advance)
259 (funcall current-wait current-position)
260 #+nil
261 (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position)
262 (and pos
263 (when (> pos current-position)
264 (finish-current (if advance
265 pos
266 current-position)
267 (car mode-stack)
268 (car wait-stack)
269 :extend advance
270 :pop t)
271 t)))
272 (progn
273 (incf current-position)))
274 )))))
275
276 (defun format-scan (coloring-type scan)
277 (let* ((coloring-type-object (or (find-coloring-type coloring-type)
278 (error "No such coloring type: ~S" coloring-type)))
279 (color-formatter (coloring-type-term-formatter coloring-type-object))
280 (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object))))
499e33e @redline6561 Backport changes from lisppaste 2.3. (i.e. haskell, erlang, python, etc)
authored
281 (format nil "<span class=\"~A\">~{~A~}~A</span>"
282 *css-background-class*
d471483 Initial import of colorize.
chandler authored
283 (mapcar color-formatter scan)
284 (funcall (coloring-type-formatter-after-hook coloring-type-object)))))
285
572afce @redline6561 Allow encoding with encode-for-tt. Resolves Issue #1.
authored
286 (defun html-colorization (coloring-type string &optional (encoder 'encode-for-pre))
341e34f @redline6561 Add docs and README, minor code cleanup.
authored
287 "Given a COLORING-TYPE and STRING, return the colorized HTML."
da7e292 @redline6561 Fix package-name thinko. Resolves Issue #2.
authored
288 (let* ((encoder-fn (find-symbol (princ-to-string encoder) :html-encode))
572afce @redline6561 Allow encoding with encode-for-tt. Resolves Issue #1.
authored
289 (parse-tree (loop for (meta . token) in (scan-string coloring-type string)
290 for encoded = (funcall encoder-fn token)
291 if (and (plusp (length encoded))
292 (char= (elt encoded (1- (length encoded))) #\>))
293 collect (cons meta (format nil "~A~%" encoded))
294 else collect (cons meta encoded))))
295 (format-scan coloring-type parse-tree)))
d471483 Initial import of colorize.
chandler authored
296
341e34f @redline6561 Add docs and README, minor code cleanup.
authored
297 (defun colorize-file-to-stream (coloring-type input-file-name stream
572afce @redline6561 Allow encoding with encode-for-tt. Resolves Issue #1.
authored
298 &key (wrap t) (css-background "default")
299 (encoder 'encode-for-pre))
341e34f @redline6561 Add docs and README, minor code cleanup.
authored
300 "Given a COLORING-TYPE, INPUT-FILE-NAME, and a STREAM to write to, output the
301 colorized code to the given STREAM. If WRAP is nil, write only the HTML for the
572afce @redline6561 Allow encoding with encode-for-tt. Resolves Issue #1.
authored
302 code snippet. To wrap in a <tt> element rather than <pre>, pass 'encode-for-tt
303 as the ENCODER."
d471483 Initial import of colorize.
chandler authored
304 (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
305 (merge-pathnames input-file-name)
306 (make-pathname :type "lisp"
307 :defaults (merge-pathnames input-file-name))))
308 (*css-background-class* css-background))
309 (with-open-file (s input-file :direction :input)
310 (let ((lines nil)
311 (string nil))
312 (block done
313 (loop (let ((line (read-line s nil nil)))
314 (if line
315 (push line lines)
316 (return-from done)))))
317 (setf string (format nil "~{~A~%~}"
318 (nreverse lines)))
319 (if wrap
341e34f @redline6561 Add docs and README, minor code cleanup.
authored
320 (format stream
d471483 Initial import of colorize.
chandler authored
321 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">
322 <html><head><style type=\"text/css\">~A~%~A</style><body>
323 <table width=\"100%\"><tr><td class=\"~A\">
324 <tt>~A</tt>
325 </tr></td></table></body></html>"
326 *coloring-css*
327 (make-background-css "white")
328 *css-background-class*
572afce @redline6561 Allow encoding with encode-for-tt. Resolves Issue #1.
authored
329 (html-colorization coloring-type string encoder))
330 (write-string (html-colorization coloring-type string encoder) stream))))))
d471483 Initial import of colorize.
chandler authored
331
332 (defun colorize-file (coloring-type input-file-name &optional output-file-name)
341e34f @redline6561 Add docs and README, minor code cleanup.
authored
333 "Given a COLORING-TYPE (keyword) and an INPUT-FILE-NAME, write colorized code to
334 INPUT-FILE-NAME.html or OUTPUT-FILE-NAME, if provided."
d471483 Initial import of colorize.
chandler authored
335 (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
336 (merge-pathnames input-file-name)
337 (make-pathname :type "lisp"
338 :defaults (merge-pathnames input-file-name))))
339 (output-file (or output-file-name
340 (make-pathname :type "html"
341 :defaults input-file))))
341e34f @redline6561 Add docs and README, minor code cleanup.
authored
342 (with-open-file (stream output-file :direction :output :if-exists :supersede)
343 (colorize-file-to-stream coloring-type input-file-name stream))))
Something went wrong with that request. Please try again.