colorize-lisp-examples.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) 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-formatter
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; margin: 0px;}
22 a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
23 a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
24 a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
25 a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
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*) (extra nil))
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-mode)
67 (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions)
68 (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name)
69 (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter)
70 (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil)
71 (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly ""))
72 (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function
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-equal :key #'symbol-name))))
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) name))))))
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)))) names)
115 ,@body))
116
117 (defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body)
118 (with-gensyms (num items position not-preceded-by string item new-mode until advancing)
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) ,not-preceded-by))
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 in ~S starting at ~S~%"
136 ,item ,string ,position)
137 (if (characterp ,item)
138 (char= (elt ,string ,position)
139 ,item)
140 (search ,item ,string :start2 ,position
141 :end2 (min (length ,string)
142 (+ ,position (length ,item))))))))))
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-by)) 0)
149 (not (string= (subseq ,string
150 (- ,position (length ,not-preceded-by))
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-position* ',position))
174 (list 'values ,until ,advancing)))))))
175 ,@body))))
176
177 (defvar *formatter-local-variables*)
178
179 (defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters
180 autodetect parent formatter-variables (formatter-after-hook '(constantly ""))
181 invisible)
182 (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance)
183 `(let ((,parent-type (or (find-coloring-type ,parent)
184 (and ,parent
185 (error "No such coloring type: ~S" ,parent)))))
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 ,parent-type)))
190 :default-mode (or ',default-mode
191 (if ,parent-type (coloring-type-default-mode ,parent-type)))
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) ,(second e)))
199 formatter-variables)
200 (if ,parent-type
201 (funcall (coloring-type-formatter-initial-values ,parent-type))
202 nil)))
203 :formatter-after-hook (lambda nil
204 (symbol-macrolet ,(mapcar #'(lambda (e)
205 `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
206 formatter-variables)
207 (concatenate 'string
208 (funcall ,formatter-after-hook)
209 (if ,parent-type
210 (funcall (coloring-type-formatter-after-hook ,parent-type))
211 ""))))
212 :term-formatter
213 (symbol-macrolet ,(mapcar #'(lambda (e)
214 `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
215 formatter-variables)
216 (lambda (,term)
217 (labels ((call-parent-formatter (&optional (,type (car ,term))
218 (,string (cdr ,term)))
219 (if ,parent-type
220 (funcall (coloring-type-term-formatter ,parent-type)
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) transition
235 `(cons ',mode
236 (lambda (,current-mode ,string ,position)
237 (let ((,mode-wait (constantly nil))
238 (,position-foobage ,position))
239 (with-scanning-functions ,string ,position-foobage
240 ,current-mode ,mode-wait
241 (let ((*reset-position* ,position))
242 (cond ,@table))
243 (values ,position-foobage ,current-mode
244 (lambda (,new-position)
245 (setf ,position-foobage ,new-position)
246 (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage))))
247 (values ,position-foobage ,advance)))))
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" coloring-type)))
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 t) push pop)
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 mode-stack)
274 (subseq string low-bound
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 current-position)
308 (when (> new-position current-position)
309 (finish-current new-position new-mode new-wait :extend nil :push t)
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 ~S)~%" pos advance current-mode current-position)
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" coloring-type)))
334 (color-formatter (coloring-type-term-formatter coloring-type-object))
335 (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object))))
336 (format nil "~{~A~}~A"
337 (mapcar color-formatter scan)
338 (funcall (coloring-type-formatter-after-hook coloring-type-object)))))
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 tt))) #\>))
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 (wrap t) (css-background "default"))
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-file-name))))
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 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">
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-file-name)
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-file-name))))
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 :supersede)
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" "flet" "the"
451 "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*"
452 "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally"
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 :string :comment
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-parens*
543 *close-parens*)))))
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<span class=\"~A\">~A"
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-LOOKUP" :r5rs-lookup))
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-LOOKUP" :elisp-lookup))
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-LOOKUP" :clhs-lookup))
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* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
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-escape :preprocessor)
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=\"~A\">"
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_cast"
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" "synchronized"
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-lookup))
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 line)
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-code)
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))