colorize-lisp-examples.lisp - clic - Clic is an command line interactive client… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
colorize-lisp-examples.lisp (44246B) | |
--- | |
1 ;;; This is code was taken from lisppaste2 and is a quick hack | |
2 ;;; to colorize lisp examples in the html generated by Texinfo. | |
3 ;;; It is not general-purpose utility, though it could easily be | |
4 ;;; turned into one. | |
5 | |
6 ;;;; colorize-package.lisp | |
7 | |
8 (defpackage :colorize | |
9 (:use :common-lisp) | |
10 (:export :scan-string :format-scan :html-colorization | |
11 :find-coloring-type :autodetect-coloring-type | |
12 :coloring-types :scan :scan-any :advance :call-parent-formatt… | |
13 :*coloring-css* :make-background-css :*css-background-class* | |
14 :colorize-file :colorize-file-to-stream :*version-token*)) | |
15 | |
16 ;;;; coloring-css.lisp | |
17 | |
18 (in-package :colorize) | |
19 | |
20 (defparameter *coloring-css* | |
21 ".symbol { color: #770055; background-color: transparent; border: 0px;… | |
22 a.symbol:link { color: #229955; background-color : transparent; text-dec… | |
23 a.symbol:active { color : #229955; background-color : transparent; text-… | |
24 a.symbol:visited { color : #229955; background-color : transparent; text… | |
25 a.symbol:hover { color : #229955; background-color : transparent; text-d… | |
26 .special { color : #FF5000; background-color : inherit; } | |
27 .keyword { color : #770000; background-color : inherit; } | |
28 .comment { color : #007777; background-color : inherit; } | |
29 .string { color : #777777; background-color : inherit; } | |
30 .character { color : #0055AA; background-color : inherit; } | |
31 .syntaxerror { color : #FF0000; background-color : inherit; } | |
32 span.paren1:hover { color : inherit; background-color : #BAFFFF; } | |
33 span.paren2:hover { color : inherit; background-color : #FFCACA; } | |
34 span.paren3:hover { color : inherit; background-color : #FFFFBA; } | |
35 span.paren4:hover { color : inherit; background-color : #CACAFF; } | |
36 span.paren5:hover { color : inherit; background-color : #CAFFCA; } | |
37 span.paren6:hover { color : inherit; background-color : #FFBAFF; } | |
38 ") | |
39 | |
40 (defvar *css-background-class* "lisp-bg") | |
41 | |
42 (defun for-css (thing) | |
43 (if (symbolp thing) (string-downcase (symbol-name thing)) | |
44 thing)) | |
45 | |
46 (defun make-background-css (color &key (class *css-background-class*) (e… | |
47 (format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*… | |
48 .~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%" | |
49 class color | |
50 (mapcar #'(lambda (extra) | |
51 (format nil "~A : ~{~A ~}" | |
52 (for-css (first extra)) | |
53 (mapcar #'for-css (cdr extra)))) | |
54 extra))) | |
55 | |
56 ;;;; colorize.lisp | |
57 | |
58 ;(in-package :colorize) | |
59 | |
60 (eval-when (:compile-toplevel :load-toplevel :execute) | |
61 (defparameter *coloring-types* nil) | |
62 (defparameter *version-token* (gensym))) | |
63 | |
64 (defclass coloring-type () | |
65 ((modes :initarg :modes :accessor coloring-type-modes) | |
66 (default-mode :initarg :default-mode :accessor coloring-type-default-… | |
67 (transition-functions :initarg :transition-functions :accessor colori… | |
68 (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name) | |
69 (term-formatter :initarg :term-formatter :accessor coloring-type-term… | |
70 (formatter-initial-values :initarg :formatter-initial-values :accesso… | |
71 (formatter-after-hook :initarg :formatter-after-hook :accessor colori… | |
72 (autodetect-function :initarg :autodetect-function :accessor coloring… | |
73 :initform (constantly nil)) | |
74 (parent-type :initarg :parent-type :accessor coloring-type-parent-type | |
75 :initform nil) | |
76 (visible :initarg :visible :accessor coloring-type-visible | |
77 :initform t))) | |
78 | |
79 (defun find-coloring-type (type) | |
80 (if (typep type 'coloring-type) | |
81 type | |
82 (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equ… | |
83 | |
84 (defun autodetect-coloring-type (name) | |
85 (car | |
86 (find name *coloring-types* | |
87 :key #'cdr | |
88 :test #'(lambda (name type) | |
89 (and (coloring-type-visible type) | |
90 (funcall (coloring-type-autodetect-function type… | |
91 | |
92 (defun coloring-types () | |
93 (loop for type-pair in *coloring-types* | |
94 if (coloring-type-visible (cdr type-pair)) | |
95 collect (cons (car type-pair) | |
96 (coloring-type-fancy-name (cdr type-pair))))) | |
97 | |
98 (defun (setf find-coloring-type) (new-value type) | |
99 (if new-value | |
100 (let ((found (assoc type *coloring-types*))) | |
101 (if found | |
102 (setf (cdr found) new-value) | |
103 (setf *coloring-types* | |
104 (nconc *coloring-types* | |
105 (list (cons type new-value)))))) | |
106 (setf *coloring-types* (remove type *coloring-types* :key #'car)))) | |
107 | |
108 (defvar *scan-calls* 0) | |
109 | |
110 (defvar *reset-position* nil) | |
111 | |
112 (defmacro with-gensyms ((&rest names) &body body) | |
113 `(let ,(mapcar #'(lambda (name) | |
114 (list name `(make-symbol ,(symbol-name name)))) nam… | |
115 ,@body)) | |
116 | |
117 (defmacro with-scanning-functions (string-param position-place mode-plac… | |
118 (with-gensyms (num items position not-preceded-by string item new-mode… | |
119 `(labels ((advance (,num) | |
120 (setf ,position-place (+ ,position-place ,num)) | |
121 t) | |
122 (peek-any (,items &key ,not-preceded-by) | |
123 (incf *scan-calls*) | |
124 (let* ((,items (if (stringp ,items) | |
125 (coerce ,items 'list) ,items)) | |
126 (,not-preceded-by (if (characterp ,not-preceded-by) | |
127 (string ,not-preceded-by) ,n… | |
128 (,position ,position-place) | |
129 (,string ,string-param)) | |
130 (let ((,item (and | |
131 (< ,position (length ,string)) | |
132 (find ,string ,items | |
133 :test #'(lambda (,string ,item) | |
134 #+nil | |
135 (format t "looking for ~S… | |
136 ,item ,string ,po… | |
137 (if (characterp ,item) | |
138 (char= (elt ,string ,… | |
139 ,item) | |
140 (search ,item ,string… | |
141 :end2 (min (l… | |
142 (+… | |
143 (if (characterp ,item) | |
144 (setf ,item (string ,item))) | |
145 (if | |
146 (if ,item | |
147 (if ,not-preceded-by | |
148 (if (>= (- ,position (length ,not-preceded-b… | |
149 (not (string= (subseq ,string | |
150 (- ,position (leng… | |
151 ,position) | |
152 ,not-preceded-by)) | |
153 t) | |
154 t) | |
155 nil) | |
156 ,item | |
157 (progn | |
158 (and *reset-position* | |
159 (setf ,position-place *reset-position*)) | |
160 nil))))) | |
161 (scan-any (,items &key ,not-preceded-by) | |
162 (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by))) | |
163 (and ,item (advance (length ,item))))) | |
164 (peek (,item &key ,not-preceded-by) | |
165 (peek-any (list ,item) :not-preceded-by ,not-preceded-by)) | |
166 (scan (,item &key ,not-preceded-by) | |
167 (scan-any (list ,item) :not-preceded-by ,not-preceded-by)… | |
168 (macrolet ((set-mode (,new-mode &key ,until (,advancing t)) | |
169 (list 'progn | |
170 (list 'setf ',mode-place ,new-mode) | |
171 (list 'setf ',mode-wait-place | |
172 (list 'lambda (list ',position) | |
173 (list 'let (list (list '*reset-posi… | |
174 (list 'values ,until ,advanci… | |
175 ,@body)))) | |
176 | |
177 (defvar *formatter-local-variables*) | |
178 | |
179 (defmacro define-coloring-type (name fancy-name &key modes default-mode … | |
180 autodetect parent formatter-variables (f… | |
181 invisible) | |
182 (with-gensyms (parent-type term type string current-mode position posi… | |
183 `(let ((,parent-type (or (find-coloring-type ,parent) | |
184 (and ,parent | |
185 (error "No such coloring type: ~S" ,pa… | |
186 (setf (find-coloring-type ,name) | |
187 (make-instance 'coloring-type | |
188 :fancy-name ',fancy-name | |
189 :modes (append ',modes (if ,parent-type (coloring-type-modes ,pa… | |
190 :default-mode (or ',default-mode | |
191 (if ,parent-type (coloring-type-default-mode ,… | |
192 ,@(if autodetect | |
193 `(:autodetect-function ,autodetect)) | |
194 :parent-type ,parent-type | |
195 :visible (not ,invisible) | |
196 :formatter-initial-values (lambda nil | |
197 (list* ,@(mapcar #'(lambda (e) | |
198 `(cons ',(car e… | |
199 formatter-variables) | |
200 (if ,parent-type | |
201 (funcall (coloring-type-f… | |
202 nil))) | |
203 :formatter-after-hook (lambda nil | |
204 (symbol-macrolet ,(mapcar #'(lambda (e) | |
205 `(,(car e)… | |
206 formatter-vari… | |
207 (concatenate 'string | |
208 (funcall ,formatter-aft… | |
209 (if ,parent-type | |
210 (funcall (coloring-… | |
211 "")))) | |
212 :term-formatter | |
213 (symbol-macrolet ,(mapcar #'(lambda (e) | |
214 `(,(car e) (cdr (assoc ',(car e) *… | |
215 formatter-variables) | |
216 (lambda (,term) | |
217 (labels ((call-parent-formatter (&optional (,type (car ,te… | |
218 (,string (cdr ,… | |
219 (if ,parent-type | |
220 (funcall (coloring-type-term-formatter ,par… | |
221 (cons ,type ,string)))) | |
222 (call-formatter (&optional (,type (car ,term)) | |
223 (,string (cdr ,term))) | |
224 (funcall | |
225 (case (first ,type) | |
226 ,@formatters | |
227 (t (lambda (,type text) | |
228 (call-parent-formatter ,type text)))) | |
229 ,type ,string))) | |
230 (call-formatter)))) | |
231 :transition-functions | |
232 (list | |
233 ,@(loop for transition in transitions | |
234 collect (destructuring-bind (mode &rest table) transiti… | |
235 `(cons ',mode | |
236 (lambda (,current-mode ,string ,position) | |
237 (let ((,mode-wait (constantly nil)) | |
238 (,position-foobage ,position)) | |
239 (with-scanning-functions ,string ,posit… | |
240 ,current-mode … | |
241 (let ((*reset-… | |
242 (cond ,@tabl… | |
243 (values ,posit… | |
244 (lambd… | |
245 (set… | |
246 (let… | |
247 (v… | |
248 ))))))))))) | |
249 | |
250 (defun full-transition-table (coloring-type-object) | |
251 (let ((parent (coloring-type-parent-type coloring-type-object))) | |
252 (if parent | |
253 (append (coloring-type-transition-functions coloring-type-object) | |
254 (full-transition-table parent)) | |
255 (coloring-type-transition-functions coloring-type-object)))) | |
256 | |
257 (defun scan-string (coloring-type string) | |
258 (let* ((coloring-type-object (or (find-coloring-type coloring-type) | |
259 (error "No such coloring type: ~S" co… | |
260 (transitions (full-transition-table coloring-type-object)) | |
261 (result nil) | |
262 (low-bound 0) | |
263 (current-mode (coloring-type-default-mode coloring-type-object)) | |
264 (mode-stack nil) | |
265 (current-wait (constantly nil)) | |
266 (wait-stack nil) | |
267 (current-position 0) | |
268 (*scan-calls* 0)) | |
269 (flet ((finish-current (new-position new-mode new-wait &key (extend … | |
270 (let ((to (if extend new-position current-position))) | |
271 (if (> to low-bound) | |
272 (setf result (nconc result | |
273 (list (cons (cons current-mode mo… | |
274 (subseq string low-bo… | |
275 to)))))) | |
276 (setf low-bound to) | |
277 (when pop | |
278 (pop mode-stack) | |
279 (pop wait-stack)) | |
280 (when push | |
281 (push current-mode mode-stack) | |
282 (push current-wait wait-stack)) | |
283 (setf current-mode new-mode | |
284 current-position new-position | |
285 current-wait new-wait)))) | |
286 (loop | |
287 (if (> current-position (length string)) | |
288 (return-from scan-string | |
289 (progn | |
290 (format *trace-output* "Scan was called ~S times.~%" | |
291 *scan-calls*) | |
292 (finish-current (length string) nil (constantly nil)) | |
293 result)) | |
294 (or | |
295 (loop for transition in | |
296 (mapcar #'cdr | |
297 (remove current-mode transitions | |
298 :key #'car | |
299 :test-not #'(lambda (a b) | |
300 (or (eql a b) | |
301 (if (listp b) | |
302 (member a b)))))) | |
303 if | |
304 (and transition | |
305 (multiple-value-bind | |
306 (new-position new-mode new-wait) | |
307 (funcall transition current-mode string curre… | |
308 (when (> new-position current-position) | |
309 (finish-current new-position new-mode new-wai… | |
310 t))) | |
311 return t) | |
312 (multiple-value-bind | |
313 (pos advance) | |
314 (funcall current-wait current-position) | |
315 #+nil | |
316 (format t "current-wait returns ~S ~S (mode is ~S, pos is … | |
317 (and pos | |
318 (when (> pos current-position) | |
319 (finish-current (if advance | |
320 pos | |
321 current-position) | |
322 (car mode-stack) | |
323 (car wait-stack) | |
324 :extend advance | |
325 :pop t) | |
326 t))) | |
327 (progn | |
328 (incf current-position))) | |
329 ))))) | |
330 | |
331 (defun format-scan (coloring-type scan) | |
332 (let* ((coloring-type-object (or (find-coloring-type coloring-type) | |
333 (error "No such coloring type: ~S" co… | |
334 (color-formatter (coloring-type-term-formatter coloring-type-ob… | |
335 (*formatter-local-variables* (funcall (coloring-type-formatter-… | |
336 (format nil "~{~A~}~A" | |
337 (mapcar color-formatter scan) | |
338 (funcall (coloring-type-formatter-after-hook coloring-type-o… | |
339 | |
340 (defun encode-for-pre (string) | |
341 (declare (simple-string string)) | |
342 (let ((output (make-array (truncate (length string) 2/3) | |
343 :element-type 'character | |
344 :adjustable t | |
345 :fill-pointer 0))) | |
346 (with-output-to-string (out output) | |
347 (loop for char across string | |
348 do (case char | |
349 ((#\&) (write-string "&" out)) | |
350 ((#\<) (write-string "<" out)) | |
351 ((#\>) (write-string ">" out)) | |
352 ((#\") (write-string """ out)) | |
353 ((#\RIGHTWARDS_DOUBLE_ARROW) (write-string "⇒" out… | |
354 (t (write-char char out))))) | |
355 (coerce output 'simple-string))) | |
356 | |
357 (defun string-substitute (string substring replacement-string) | |
358 "String substitute by Larry Hunter. Obtained from Google" | |
359 (let ((substring-length (length substring)) | |
360 (last-end 0) | |
361 (new-string "")) | |
362 (do ((next-start | |
363 (search substring string) | |
364 (search substring string :start2 last-end))) | |
365 ((null next-start) | |
366 (concatenate 'string new-string (subseq string last-end))) | |
367 (setq new-string | |
368 (concatenate 'string | |
369 new-string | |
370 (subseq string last-end next-start) | |
371 replacement-string)) | |
372 (setq last-end (+ next-start substring-length))))) | |
373 | |
374 (defun decode-from-tt (string) | |
375 (string-substitute | |
376 (string-substitute | |
377 (string-substitute | |
378 (string-substitute | |
379 (string-substitute string "&" "&") | |
380 "<" "<") | |
381 ">" ">") | |
382 "⇒" (string #\RIGHTWARDS_DOUBLE_ARROW)) | |
383 """ "\"")) | |
384 | |
385 (defun html-colorization (coloring-type string) | |
386 (format-scan coloring-type | |
387 (mapcar #'(lambda (p) | |
388 (cons (car p) | |
389 (let ((tt (encode-for-pre (cdr p)))) | |
390 (if (and (> (length tt) 0) | |
391 (char= (elt tt (1- (length t… | |
392 (format nil "~A~%" tt) tt)))) | |
393 (scan-string coloring-type string)))) | |
394 | |
395 (defun colorize-file-to-stream (coloring-type input-file-name s2 &key (w… | |
396 (let* ((input-file (if (pathname-type (merge-pathnames input-file-name… | |
397 (merge-pathnames input-file-name) | |
398 (make-pathname :type "lisp" | |
399 :defaults (merge-pathnames input… | |
400 (*css-background-class* css-background)) | |
401 (with-open-file (s input-file :direction :input) | |
402 (let ((lines nil) | |
403 (string nil)) | |
404 (block done | |
405 (loop (let ((line (read-line s nil nil))) | |
406 (if line | |
407 (push line lines) | |
408 (return-from done))))) | |
409 (setf string (format nil "~{~A~%~}" | |
410 (nreverse lines))) | |
411 (if wrap | |
412 (format s2 | |
413 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Trans… | |
414 <html><head><style type=\"text/css\">~A~%~A</style><body> | |
415 <table width=\"100%\"><tr><td class=\"~A\"> | |
416 <tt>~A</tt> | |
417 </tr></td></table></body></html>" | |
418 *coloring-css* | |
419 (make-background-css "white") | |
420 *css-background-class* | |
421 (html-colorization coloring-type string)) | |
422 (write-string (html-colorization coloring-type string) s2)))… | |
423 | |
424 (defun colorize-file (coloring-type input-file-name &optional output-fil… | |
425 (let* ((input-file (if (pathname-type (merge-pathnames input-file-name… | |
426 (merge-pathnames input-file-name) | |
427 (make-pathname :type "lisp" | |
428 :defaults (merge-pathnames input… | |
429 (output-file (or output-file-name | |
430 (make-pathname :type "html" | |
431 :defaults input-file)))) | |
432 (with-open-file (s2 output-file :direction :output :if-exists :super… | |
433 (colorize-file-to-stream coloring-type input-file-name s2)))) | |
434 | |
435 ;; coloring-types.lisp | |
436 | |
437 ;(in-package :colorize) | |
438 | |
439 (eval-when (:compile-toplevel :load-toplevel :execute) | |
440 (defparameter *version-token* (gensym))) | |
441 | |
442 (defparameter *symbol-characters* | |
443 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890… | |
444 | |
445 (defparameter *non-constituent* | |
446 '(#\space #\tab #\newline #\linefeed #\page #\return | |
447 #\" #\' #\( #\) #\, #\; #\` #\[ #\])) | |
448 | |
449 (defparameter *special-forms* | |
450 '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "fle… | |
451 "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "le… | |
452 "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "loc… | |
453 "return-from" "setq" "multiple-value-call")) | |
454 | |
455 (defparameter *common-macros* | |
456 '("loop" "cond" "lambda")) | |
457 | |
458 (defparameter *open-parens* '(#\()) | |
459 (defparameter *close-parens* '(#\))) | |
460 | |
461 (define-coloring-type :lisp "Basic Lisp" | |
462 :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :… | |
463 :multiline :character | |
464 :single-escaped :in-list :syntax-error) | |
465 :default-mode :first-char-on-line | |
466 :transitions | |
467 (((:in-list) | |
468 ((or | |
469 (scan-any *symbol-characters*) | |
470 (and (scan #\.) (scan-any *symbol-characters*)) | |
471 (and (scan #\\) (advance 1))) | |
472 (set-mode :symbol | |
473 :until (scan-any *non-constituent*) | |
474 :advancing nil)) | |
475 ((or (scan #\:) (scan "#:")) | |
476 (set-mode :keyword | |
477 :until (scan-any *non-constituent*) | |
478 :advancing nil)) | |
479 ((scan "#\\") | |
480 (let ((count 0)) | |
481 (set-mode :character | |
482 :until (progn | |
483 (incf count) | |
484 (if (> count 1) | |
485 (scan-any *non-constituent*))) | |
486 :advancing nil))) | |
487 ((scan #\") | |
488 (set-mode :string | |
489 :until (scan #\"))) | |
490 ((scan #\;) | |
491 (set-mode :comment | |
492 :until (scan #\newline))) | |
493 ((scan "#|") | |
494 (set-mode :multiline | |
495 :until (scan "|#"))) | |
496 ((scan #\() | |
497 (set-mode :in-list | |
498 :until (scan #\))))) | |
499 ((:normal :first-char-on-line) | |
500 ((scan #\() | |
501 (set-mode :in-list | |
502 :until (scan #\))))) | |
503 (:first-char-on-line | |
504 ((scan #\;) | |
505 (set-mode :comment | |
506 :until (scan #\newline))) | |
507 ((scan "#|") | |
508 (set-mode :multiline | |
509 :until (scan "|#"))) | |
510 ((advance 1) | |
511 (set-mode :normal | |
512 :until (scan #\newline)))) | |
513 (:multiline | |
514 ((scan "#|") | |
515 (set-mode :multiline | |
516 :until (scan "|#")))) | |
517 ((:symbol :keyword :escaped-symbol :string) | |
518 ((scan #\\) | |
519 (let ((count 0)) | |
520 (set-mode :single-escaped | |
521 :until (progn | |
522 (incf count) | |
523 (if (< count 2) | |
524 (advance 1)))))))) | |
525 :formatter-variables ((paren-counter 0)) | |
526 :formatter-after-hook (lambda nil | |
527 (format nil "~{~A~}" | |
528 (loop for i from paren-counter downto 1 | |
529 collect "</span></span>"))) | |
530 :formatters | |
531 (((:normal :first-char-on-line) | |
532 (lambda (type s) | |
533 (declare (ignore type)) | |
534 s)) | |
535 ((:in-list) | |
536 (lambda (type s) | |
537 (declare (ignore type)) | |
538 (labels ((color-parens (s) | |
539 (let ((paren-pos (find-if-not #'null | |
540 (mapcar #'(lambda (c) | |
541 (position c s… | |
542 (append *open-par… | |
543 *close-pa… | |
544 (if paren-pos | |
545 (let ((before-paren (subseq s 0 paren-pos)) | |
546 (after-paren (subseq s (1+ paren-pos))) | |
547 (paren (elt s paren-pos)) | |
548 (open nil) | |
549 (count 0)) | |
550 (when (member paren *open-parens* :test #'char=) | |
551 (setf count (mod paren-counter 6)) | |
552 (incf paren-counter) | |
553 (setf open t)) | |
554 (when (member paren *close-parens* :test #'char… | |
555 (decf paren-counter)) | |
556 (if open | |
557 (format nil "~A<span class=\"paren~A\">~C<s… | |
558 before-paren | |
559 (1+ count) | |
560 paren *css-background-class* | |
561 (color-parens after-paren)) | |
562 (format nil "~A</span>~C</span>~A" | |
563 before-paren | |
564 paren (color-parens after-paren)))) | |
565 s)))) | |
566 (color-parens s)))) | |
567 ((:symbol :escaped-symbol) | |
568 (lambda (type s) | |
569 (declare (ignore type)) | |
570 (let* ((colon (position #\: s :from-end t)) | |
571 (new-s (or (and colon (subseq s (1+ colon))) s))) | |
572 (cond | |
573 ((or | |
574 (member new-s *common-macros* :test #'string-equal) | |
575 (member new-s *special-forms* :test #'string-equal) | |
576 (some #'(lambda (e) | |
577 (and (> (length new-s) (length e)) | |
578 (string-equal e (subseq new-s 0 (length e))))) | |
579 '("WITH-" "DEF"))) | |
580 (format nil "<i><span class=\"symbol\">~A</span></i>" s)) | |
581 ((and (> (length new-s) 2) | |
582 (char= (elt new-s 0) #\*) | |
583 (char= (elt new-s (1- (length new-s))) #\*)) | |
584 (format nil "<span class=\"special\">~A</span>" s)) | |
585 (t s))))) | |
586 (:keyword (lambda (type s) | |
587 (declare (ignore type)) | |
588 (format nil "<span class=\"keyword\">~A</span>" | |
589 s))) | |
590 ((:comment :multiline) | |
591 (lambda (type s) | |
592 (declare (ignore type)) | |
593 (format nil "<span class=\"comment\">~A</span>" | |
594 s))) | |
595 ((:character) | |
596 (lambda (type s) | |
597 (declare (ignore type)) | |
598 (format nil "<span class=\"character\">~A</span>" | |
599 s))) | |
600 ((:string) | |
601 (lambda (type s) | |
602 (declare (ignore type)) | |
603 (format nil "<span class=\"string\">~A</span>" | |
604 s))) | |
605 ((:single-escaped) | |
606 (lambda (type s) | |
607 (call-formatter (cdr type) s))) | |
608 ((:syntax-error) | |
609 (lambda (type s) | |
610 (declare (ignore type)) | |
611 (format nil "<span class=\"syntaxerror\">~A</span>" | |
612 s))))) | |
613 | |
614 (define-coloring-type :scheme "Scheme" | |
615 :autodetect (lambda (text) | |
616 (or | |
617 (search "scheme" text :test #'char-equal) | |
618 (search "chicken" text :test #'char-equal))) | |
619 :parent :lisp | |
620 :transitions | |
621 (((:normal :in-list) | |
622 ((scan "...") | |
623 (set-mode :symbol | |
624 :until (scan-any *non-constituent*) | |
625 :advancing nil)) | |
626 ((scan #\[) | |
627 (set-mode :in-list | |
628 :until (scan #\]))))) | |
629 :formatters | |
630 (((:in-list) | |
631 (lambda (type s) | |
632 (declare (ignore type s)) | |
633 (let ((*open-parens* (cons #\[ *open-parens*)) | |
634 (*close-parens* (cons #\] *close-parens*))) | |
635 (call-parent-formatter)))) | |
636 ((:symbol :escaped-symbol) | |
637 (lambda (type s) | |
638 (declare (ignore type)) | |
639 (let ((result (if (find-package :r5rs-lookup) | |
640 (funcall (symbol-function (intern "SYMBOL-LOOKU… | |
641 s)))) | |
642 (if result | |
643 (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" | |
644 result (call-parent-formatter)) | |
645 (call-parent-formatter))))))) | |
646 | |
647 (define-coloring-type :elisp "Emacs Lisp" | |
648 :autodetect (lambda (name) | |
649 (member name '("emacs") | |
650 :test #'(lambda (name ext) | |
651 (search ext name :test #'char-equal)))) | |
652 :parent :lisp | |
653 :formatters | |
654 (((:symbol :escaped-symbol) | |
655 (lambda (type s) | |
656 (declare (ignore type)) | |
657 (let ((result (if (find-package :elisp-lookup) | |
658 (funcall (symbol-function (intern "SYMBOL-LOOKU… | |
659 s)))) | |
660 (if result | |
661 (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" | |
662 result (call-parent-formatter)) | |
663 (call-parent-formatter))))))) | |
664 | |
665 (define-coloring-type :common-lisp "Common Lisp" | |
666 :autodetect (lambda (text) | |
667 (search "lisp" text :test #'char-equal)) | |
668 :parent :lisp | |
669 :transitions | |
670 (((:normal :in-list) | |
671 ((scan #\|) | |
672 (set-mode :escaped-symbol | |
673 :until (scan #\|))))) | |
674 :formatters | |
675 (((:symbol :escaped-symbol) | |
676 (lambda (type s) | |
677 (declare (ignore type)) | |
678 (let* ((colon (position #\: s :from-end t :test #'char=)) | |
679 (to-lookup (if colon (subseq s (1+ colon)) s)) | |
680 (result (if (find-package :clhs-lookup) | |
681 (funcall (symbol-function (intern "SYMBOL-LOOKU… | |
682 to-lookup)))) | |
683 (if result | |
684 (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" | |
685 result (call-parent-formatter)) | |
686 (call-parent-formatter))))))) | |
687 | |
688 (define-coloring-type :common-lisp-file "Common Lisp File" | |
689 :parent :common-lisp | |
690 :default-mode :in-list | |
691 :invisible t) | |
692 | |
693 (defvar *c-open-parens* "([{") | |
694 (defvar *c-close-parens* ")]}") | |
695 | |
696 (defvar *c-reserved-words* | |
697 '("auto" "break" "case" "char" "const" | |
698 "continue" "default" "do" "double" "else" | |
699 "enum" "extern" "float" "for" "goto" | |
700 "if" "int" "long" "register" "return" | |
701 "short" "signed" "sizeof" "static" "struct" | |
702 "switch" "typedef" "union" "unsigned" "void" | |
703 "volatile" "while" "__restrict" "_Bool")) | |
704 | |
705 (defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOP… | |
706 (defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/… | |
707 | |
708 (define-coloring-type :basic-c "Basic C" | |
709 :modes (:normal :comment :word-ish :paren-ish :string :char :single-es… | |
710 :default-mode :normal | |
711 :invisible t | |
712 :transitions | |
713 ((:normal | |
714 ((scan-any *c-begin-word*) | |
715 (set-mode :word-ish | |
716 :until (scan-any *c-terminators*) | |
717 :advancing nil)) | |
718 ((scan "/*") | |
719 (set-mode :comment | |
720 :until (scan "*/"))) | |
721 ((or | |
722 (scan-any *c-open-parens*) | |
723 (scan-any *c-close-parens*)) | |
724 (set-mode :paren-ish | |
725 :until (advance 1) | |
726 :advancing nil)) | |
727 ((scan #\") | |
728 (set-mode :string | |
729 :until (scan #\"))) | |
730 ((or (scan "'\\") | |
731 (scan #\')) | |
732 (set-mode :character | |
733 :until (advance 2)))) | |
734 (:string | |
735 ((scan #\\) | |
736 (set-mode :single-escape | |
737 :until (advance 1))))) | |
738 :formatter-variables | |
739 ((paren-counter 0)) | |
740 :formatter-after-hook (lambda nil | |
741 (format nil "~{~A~}" | |
742 (loop for i from paren-counter downto 1 | |
743 collect "</span></span>"))) | |
744 :formatters | |
745 ((:normal | |
746 (lambda (type s) | |
747 (declare (ignore type)) | |
748 s)) | |
749 (:comment | |
750 (lambda (type s) | |
751 (declare (ignore type)) | |
752 (format nil "<span class=\"comment\">~A</span>" | |
753 s))) | |
754 (:string | |
755 (lambda (type s) | |
756 (declare (ignore type)) | |
757 (format nil "<span class=\"string\">~A</span>" | |
758 s))) | |
759 (:character | |
760 (lambda (type s) | |
761 (declare (ignore type)) | |
762 (format nil "<span class=\"character\">~A</span>" | |
763 s))) | |
764 (:single-escape | |
765 (lambda (type s) | |
766 (call-formatter (cdr type) s))) | |
767 (:paren-ish | |
768 (lambda (type s) | |
769 (declare (ignore type)) | |
770 (let ((open nil) | |
771 (count 0)) | |
772 (if (eql (length s) 1) | |
773 (progn | |
774 (when (member (elt s 0) (coerce *c-open-parens* 'list)) | |
775 (setf open t) | |
776 (setf count (mod paren-counter 6)) | |
777 (incf paren-counter)) | |
778 (when (member (elt s 0) (coerce *c-close-parens* 'list)) | |
779 (setf open nil) | |
780 (decf paren-counter) | |
781 (setf count (mod paren-counter 6))) | |
782 (if open | |
783 (format nil "<span class=\"paren~A\">~A<span class=\"~… | |
784 (1+ count) s *css-background-class*) | |
785 (format nil "</span>~A</span>" | |
786 s))) | |
787 s)))) | |
788 (:word-ish | |
789 (lambda (type s) | |
790 (declare (ignore type)) | |
791 (if (member s *c-reserved-words* :test #'string=) | |
792 (format nil "<span class=\"symbol\">~A</span>" s) | |
793 s))) | |
794 )) | |
795 | |
796 (define-coloring-type :c "C" | |
797 :parent :basic-c | |
798 :transitions | |
799 ((:normal | |
800 ((scan #\#) | |
801 (set-mode :preprocessor | |
802 :until (scan-any '(#\return #\newline)))))) | |
803 :formatters | |
804 ((:preprocessor | |
805 (lambda (type s) | |
806 (declare (ignore type)) | |
807 (format nil "<span class=\"special\">~A</span>" s))))) | |
808 | |
809 (defvar *c++-reserved-words* | |
810 '("asm" "auto" "bool" "break" "case" | |
811 "catch" "char" "class" "const" "const_cast" | |
812 "continue" "default" "delete" "do" "double" | |
813 "dynamic_cast" "else" "enum" "explicit" "export" | |
814 "extern" "false" "float" "for" "friend" | |
815 "goto" "if" "inline" "int" "long" | |
816 "mutable" "namespace" "new" "operator" "private" | |
817 "protected" "public" "register" "reinterpret_cast" "return" | |
818 "short" "signed" "sizeof" "static" "static_cas… | |
819 "struct" "switch" "template" "this" "throw" | |
820 "true" "try" "typedef" "typeid" "typename" | |
821 "union" "unsigned" "using" "virtual" "void" | |
822 "volatile" "wchar_t" "while")) | |
823 | |
824 (define-coloring-type :c++ "C++" | |
825 :parent :c | |
826 :transitions | |
827 ((:normal | |
828 ((scan "//") | |
829 (set-mode :comment | |
830 :until (scan-any '(#\return #\newline)))))) | |
831 :formatters | |
832 ((:word-ish | |
833 (lambda (type s) | |
834 (declare (ignore type)) | |
835 (if (member s *c++-reserved-words* :test #'string=) | |
836 (format nil "<span class=\"symbol\">~A</span>" | |
837 s) | |
838 s))))) | |
839 | |
840 (defvar *java-reserved-words* | |
841 '("abstract" "boolean" "break" "byte" "case" | |
842 "catch" "char" "class" "const" "continue" | |
843 "default" "do" "double" "else" "extends" | |
844 "final" "finally" "float" "for" "goto" | |
845 "if" "implements" "import" "instanceof" "int" | |
846 "interface" "long" "native" "new" "package" | |
847 "private" "protected" "public" "return" "short" | |
848 "static" "strictfp" "super" "switch" "synchronize… | |
849 "this" "throw" "throws" "transient" "try" | |
850 "void" "volatile" "while")) | |
851 | |
852 (define-coloring-type :java "Java" | |
853 :parent :c++ | |
854 :formatters | |
855 ((:word-ish | |
856 (lambda (type s) | |
857 (declare (ignore type)) | |
858 (if (member s *java-reserved-words* :test #'string=) | |
859 (format nil "<span class=\"symbol\">~A</span>" | |
860 s) | |
861 s))))) | |
862 | |
863 (let ((terminate-next nil)) | |
864 (define-coloring-type :objective-c "Objective C" | |
865 :autodetect (lambda (text) (search "mac" text :test #'char=)) | |
866 :modes (:begin-message-send :end-message-send) | |
867 :transitions | |
868 ((:normal | |
869 ((scan #\[) | |
870 (set-mode :begin-message-send | |
871 :until (advance 1) | |
872 :advancing nil)) | |
873 ((scan #\]) | |
874 (set-mode :end-message-send | |
875 :until (advance 1) | |
876 :advancing nil)) | |
877 ((scan-any *c-begin-word*) | |
878 (set-mode :word-ish | |
879 :until (or | |
880 (and (peek-any '(#\:)) | |
881 (setf terminate-next t)) | |
882 (and terminate-next (progn | |
883 (setf terminate-next nil) | |
884 (advance 1))) | |
885 (scan-any *c-terminators*)) | |
886 :advancing nil))) | |
887 (:word-ish | |
888 #+nil | |
889 ((scan #\:) | |
890 (format t "hi~%") | |
891 (set-mode :word-ish :until (advance 1) :advancing nil) | |
892 (setf terminate-next t)))) | |
893 :parent :c++ | |
894 :formatter-variables ((is-keyword nil) (in-message-send nil)) | |
895 :formatters | |
896 ((:begin-message-send | |
897 (lambda (type s) | |
898 (setf is-keyword nil) | |
899 (setf in-message-send t) | |
900 (call-formatter (cons :paren-ish type) s))) | |
901 (:end-message-send | |
902 (lambda (type s) | |
903 (setf is-keyword nil) | |
904 (setf in-message-send nil) | |
905 (call-formatter (cons :paren-ish type) s))) | |
906 (:word-ish | |
907 (lambda (type s) | |
908 (declare (ignore type)) | |
909 (prog1 | |
910 (let ((result (if (find-package :cocoa-lookup) | |
911 (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lo… | |
912 s)))) | |
913 (if result | |
914 (format nil "<a href=\"~A\" class=\"symbol\">~A</a>" | |
915 result s) | |
916 (if (member s *c-reserved-words* :test #'string=) | |
917 (format nil "<span class=\"symbol\">~A</span>" s) | |
918 (if in-message-send | |
919 (if is-keyword | |
920 (format nil "<span class=\"keyword\">~A</span>" s) | |
921 s) | |
922 s)))) | |
923 (setf is-keyword (not is-keyword)))))))) | |
924 | |
925 | |
926 ;#!/usr/bin/clisp | |
927 ;#+sbcl | |
928 ;(require :asdf) | |
929 ;(asdf:oos 'asdf:load-op :colorize) | |
930 | |
931 (defmacro with-each-stream-line ((var stream) &body body) | |
932 (let ((eof (gensym)) | |
933 (eof-value (gensym)) | |
934 (strm (gensym))) | |
935 `(let ((,strm ,stream) | |
936 (,eof ',eof-value)) | |
937 (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof))) | |
938 ((eql ,var ,eof)) | |
939 ,@body)))) | |
940 | |
941 (defun system (control-string &rest args) | |
942 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and | |
943 synchronously execute the result using a Bourne-compatible shell, with | |
944 output to *verbose-out*. Returns the shell's exit code." | |
945 (let ((command (apply #'format nil control-string args))) | |
946 (format t "; $ ~A~%" command) | |
947 #+sbcl | |
948 (sb-impl::process-exit-code | |
949 (sb-ext:run-program | |
950 "/bin/sh" | |
951 (list "-c" command) | |
952 :input nil :output *standard-output*)) | |
953 #+(or cmucl scl) | |
954 (ext:process-exit-code | |
955 (ext:run-program | |
956 "/bin/sh" | |
957 (list "-c" command) | |
958 :input nil :output *verbose-out*)) | |
959 #+clisp ;XXX not exactly *verbose-out*, I know | |
960 (ext:run-shell-command command :output :terminal :wait t) | |
961 )) | |
962 | |
963 (defun strcat (&rest strings) | |
964 (apply #'concatenate 'string strings)) | |
965 | |
966 (defun string-starts-with (start str) | |
967 (and (>= (length str) (length start)) | |
968 (string-equal start str :end2 (length start)))) | |
969 | |
970 (defmacro string-append (outputstr &rest args) | |
971 `(setq ,outputstr (concatenate 'string ,outputstr ,@args))) | |
972 | |
973 (defconstant +indent+ 0 | |
974 "Indentation used in the examples.") | |
975 | |
976 (defun texinfo->raw-lisp (code) | |
977 "Answer CODE with spurious Texinfo output removed. For use in | |
978 preprocessing output in a @lisp block before passing to colorize." | |
979 (decode-from-tt | |
980 (with-output-to-string (output) | |
981 (do* ((last-position 0) | |
982 (next-position | |
983 #0=(search #1="<span class=\"roman\">" code | |
984 :start2 last-position :test #'char-equal) | |
985 #0#)) | |
986 ((eq nil next-position) | |
987 (write-string code output :start last-position)) | |
988 (write-string code output :start last-position :end next-position) | |
989 (let ((end (search #2="</span>" code | |
990 :start2 (+ next-position (length #1#)) | |
991 :test #'char-equal))) | |
992 (assert (integerp end) () | |
993 "Missing ~A tag in HTML for @lisp block~%~ | |
994 HTML contents of block:~%~A" #2# code) | |
995 (write-string code output | |
996 :start (+ next-position (length #1#)) | |
997 :end end) | |
998 (setf last-position (+ end (length #2#)))))))) | |
999 | |
1000 (defun process-file (from to) | |
1001 (with-open-file (output to :direction :output :if-exists :error) | |
1002 (with-open-file (input from :direction :input) | |
1003 (let ((line-processor nil) | |
1004 (piece-of-code '())) | |
1005 (labels | |
1006 ((process-line-inside-pre (line) | |
1007 (cond ((string-starts-with "</pre>" line) | |
1008 (with-input-from-string | |
1009 (stream (colorize:html-colorization | |
1010 :common-lisp | |
1011 (texinfo->raw-lisp | |
1012 (apply #'concatenate 'string | |
1013 (nreverse piece-of-code))))) | |
1014 (with-each-stream-line (cline stream) | |
1015 (format output " ~A~%" cline))) | |
1016 (write-line line output) | |
1017 (setq piece-of-code '() | |
1018 line-processor #'process-regular-line)) | |
1019 (t (let ((to-append (subseq line +indent+))) | |
1020 (push (if (string= "" to-append) | |
1021 " " | |
1022 to-append) piece-of-code) | |
1023 (push (string #\Newline) piece-of-code))))) | |
1024 (process-regular-line (line) | |
1025 (let ((len (some (lambda (test-string) | |
1026 (when (string-starts-with test-string … | |
1027 (length test-string))) | |
1028 '("<pre class=\"lisp\">" | |
1029 "<pre class=\"smalllisp\">")))) | |
1030 (cond (len | |
1031 (setq line-processor #'process-line-inside-pre) | |
1032 (write-string "<pre class=\"lisp\">" output) | |
1033 (push (subseq line (+ len +indent+)) piece-of-c… | |
1034 (push (string #\Newline) piece-of-code)) | |
1035 (t (write-line line output)))))) | |
1036 (setf line-processor #'process-regular-line) | |
1037 (with-each-stream-line (line input) | |
1038 (funcall line-processor line))))))) | |
1039 | |
1040 (defun process-dir (dir) | |
1041 (dolist (html-file (directory dir)) | |
1042 (let* ((name (namestring html-file)) | |
1043 (temp-name (strcat name ".temp"))) | |
1044 (process-file name temp-name) | |
1045 (system "mv ~A ~A" temp-name name)))) | |
1046 | |
1047 ;; (go "/tmp/doc/manual/html_node/*.html") | |
1048 | |
1049 #+clisp | |
1050 (progn | |
1051 (assert (first ext:*args*)) | |
1052 (process-dir (first ext:*args*))) | |
1053 | |
1054 #+sbcl | |
1055 (progn | |
1056 (assert (second sb-ext:*posix-argv*)) | |
1057 (process-dir (second sb-ext:*posix-argv*)) | |
1058 (sb-ext:quit)) |