Permalink
Fetching contributors…
Cannot retrieve contributors at this time
1059 lines (990 sloc) 43.2 KB
;;; This is code was taken from lisppaste2 and is a quick hack
;;; to colorize lisp examples in the html generated by Texinfo.
;;; It is not general-purpose utility, though it could easily be
;;; turned into one.
;;;; colorize-package.lisp
(defpackage :colorize
(:use :common-lisp)
(:export :scan-string :format-scan :html-colorization
:find-coloring-type :autodetect-coloring-type
:coloring-types :scan :scan-any :advance :call-parent-formatter
:*coloring-css* :make-background-css :*css-background-class*
:colorize-file :colorize-file-to-stream :*version-token*))
;;;; coloring-css.lisp
(in-package :colorize)
(defparameter *coloring-css*
".symbol { color: #770055; background-color: transparent; border: 0px; margin: 0px;}
a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
.special { color : #FF5000; background-color : inherit; }
.keyword { color : #770000; background-color : inherit; }
.comment { color : #007777; background-color : inherit; }
.string { color : #777777; background-color : inherit; }
.character { color : #0055AA; background-color : inherit; }
.syntaxerror { color : #FF0000; background-color : inherit; }
span.paren1:hover { color : inherit; background-color : #BAFFFF; }
span.paren2:hover { color : inherit; background-color : #FFCACA; }
span.paren3:hover { color : inherit; background-color : #FFFFBA; }
span.paren4:hover { color : inherit; background-color : #CACAFF; }
span.paren5:hover { color : inherit; background-color : #CAFFCA; }
span.paren6:hover { color : inherit; background-color : #FFBAFF; }
")
(defvar *css-background-class* "lisp-bg")
(defun for-css (thing)
(if (symbolp thing) (string-downcase (symbol-name thing))
thing))
(defun make-background-css (color &key (class *css-background-class*) (extra nil))
(format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*~:*
.~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%"
class color
(mapcar #'(lambda (extra)
(format nil "~A : ~{~A ~}"
(for-css (first extra))
(mapcar #'for-css (cdr extra))))
extra)))
;;;; colorize.lisp
;(in-package :colorize)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *coloring-types* nil)
(defparameter *version-token* (gensym)))
(defclass coloring-type ()
((modes :initarg :modes :accessor coloring-type-modes)
(default-mode :initarg :default-mode :accessor coloring-type-default-mode)
(transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions)
(fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name)
(term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter)
(formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil)
(formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly ""))
(autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function
:initform (constantly nil))
(parent-type :initarg :parent-type :accessor coloring-type-parent-type
:initform nil)
(visible :initarg :visible :accessor coloring-type-visible
:initform t)))
(defun find-coloring-type (type)
(if (typep type 'coloring-type)
type
(cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name))))
(defun autodetect-coloring-type (name)
(car
(find name *coloring-types*
:key #'cdr
:test #'(lambda (name type)
(and (coloring-type-visible type)
(funcall (coloring-type-autodetect-function type) name))))))
(defun coloring-types ()
(loop for type-pair in *coloring-types*
if (coloring-type-visible (cdr type-pair))
collect (cons (car type-pair)
(coloring-type-fancy-name (cdr type-pair)))))
(defun (setf find-coloring-type) (new-value type)
(if new-value
(let ((found (assoc type *coloring-types*)))
(if found
(setf (cdr found) new-value)
(setf *coloring-types*
(nconc *coloring-types*
(list (cons type new-value))))))
(setf *coloring-types* (remove type *coloring-types* :key #'car))))
(defvar *scan-calls* 0)
(defvar *reset-position* nil)
(defmacro with-gensyms ((&rest names) &body body)
`(let ,(mapcar #'(lambda (name)
(list name `(make-symbol ,(symbol-name name)))) names)
,@body))
(defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body)
(with-gensyms (num items position not-preceded-by string item new-mode until advancing)
`(labels ((advance (,num)
(setf ,position-place (+ ,position-place ,num))
t)
(peek-any (,items &key ,not-preceded-by)
(incf *scan-calls*)
(let* ((,items (if (stringp ,items)
(coerce ,items 'list) ,items))
(,not-preceded-by (if (characterp ,not-preceded-by)
(string ,not-preceded-by) ,not-preceded-by))
(,position ,position-place)
(,string ,string-param))
(let ((,item (and
(< ,position (length ,string))
(find ,string ,items
:test #'(lambda (,string ,item)
#+nil
(format t "looking for ~S in ~S starting at ~S~%"
,item ,string ,position)
(if (characterp ,item)
(char= (elt ,string ,position)
,item)
(search ,item ,string :start2 ,position
:end2 (min (length ,string)
(+ ,position (length ,item))))))))))
(if (characterp ,item)
(setf ,item (string ,item)))
(if
(if ,item
(if ,not-preceded-by
(if (>= (- ,position (length ,not-preceded-by)) 0)
(not (string= (subseq ,string
(- ,position (length ,not-preceded-by))
,position)
,not-preceded-by))
t)
t)
nil)
,item
(progn
(and *reset-position*
(setf ,position-place *reset-position*))
nil)))))
(scan-any (,items &key ,not-preceded-by)
(let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by)))
(and ,item (advance (length ,item)))))
(peek (,item &key ,not-preceded-by)
(peek-any (list ,item) :not-preceded-by ,not-preceded-by))
(scan (,item &key ,not-preceded-by)
(scan-any (list ,item) :not-preceded-by ,not-preceded-by)))
(macrolet ((set-mode (,new-mode &key ,until (,advancing t))
(list 'progn
(list 'setf ',mode-place ,new-mode)
(list 'setf ',mode-wait-place
(list 'lambda (list ',position)
(list 'let (list (list '*reset-position* ',position))
(list 'values ,until ,advancing)))))))
,@body))))
(defvar *formatter-local-variables*)
(defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters
autodetect parent formatter-variables (formatter-after-hook '(constantly ""))
invisible)
(with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance)
`(let ((,parent-type (or (find-coloring-type ,parent)
(and ,parent
(error "No such coloring type: ~S" ,parent)))))
(setf (find-coloring-type ,name)
(make-instance 'coloring-type
:fancy-name ',fancy-name
:modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type)))
:default-mode (or ',default-mode
(if ,parent-type (coloring-type-default-mode ,parent-type)))
,@(if autodetect
`(:autodetect-function ,autodetect))
:parent-type ,parent-type
:visible (not ,invisible)
:formatter-initial-values (lambda nil
(list* ,@(mapcar #'(lambda (e)
`(cons ',(car e) ,(second e)))
formatter-variables)
(if ,parent-type
(funcall (coloring-type-formatter-initial-values ,parent-type))
nil)))
:formatter-after-hook (lambda nil
(symbol-macrolet ,(mapcar #'(lambda (e)
`(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
formatter-variables)
(concatenate 'string
(funcall ,formatter-after-hook)
(if ,parent-type
(funcall (coloring-type-formatter-after-hook ,parent-type))
""))))
:term-formatter
(symbol-macrolet ,(mapcar #'(lambda (e)
`(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
formatter-variables)
(lambda (,term)
(labels ((call-parent-formatter (&optional (,type (car ,term))
(,string (cdr ,term)))
(if ,parent-type
(funcall (coloring-type-term-formatter ,parent-type)
(cons ,type ,string))))
(call-formatter (&optional (,type (car ,term))
(,string (cdr ,term)))
(funcall
(case (first ,type)
,@formatters
(t (lambda (,type text)
(call-parent-formatter ,type text))))
,type ,string)))
(call-formatter))))
:transition-functions
(list
,@(loop for transition in transitions
collect (destructuring-bind (mode &rest table) transition
`(cons ',mode
(lambda (,current-mode ,string ,position)
(let ((,mode-wait (constantly nil))
(,position-foobage ,position))
(with-scanning-functions ,string ,position-foobage
,current-mode ,mode-wait
(let ((*reset-position* ,position))
(cond ,@table))
(values ,position-foobage ,current-mode
(lambda (,new-position)
(setf ,position-foobage ,new-position)
(let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage))))
(values ,position-foobage ,advance)))))
)))))))))))
(defun full-transition-table (coloring-type-object)
(let ((parent (coloring-type-parent-type coloring-type-object)))
(if parent
(append (coloring-type-transition-functions coloring-type-object)
(full-transition-table parent))
(coloring-type-transition-functions coloring-type-object))))
(defun scan-string (coloring-type string)
(let* ((coloring-type-object (or (find-coloring-type coloring-type)
(error "No such coloring type: ~S" coloring-type)))
(transitions (full-transition-table coloring-type-object))
(result nil)
(low-bound 0)
(current-mode (coloring-type-default-mode coloring-type-object))
(mode-stack nil)
(current-wait (constantly nil))
(wait-stack nil)
(current-position 0)
(*scan-calls* 0))
(flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop)
(let ((to (if extend new-position current-position)))
(if (> to low-bound)
(setf result (nconc result
(list (cons (cons current-mode mode-stack)
(subseq string low-bound
to))))))
(setf low-bound to)
(when pop
(pop mode-stack)
(pop wait-stack))
(when push
(push current-mode mode-stack)
(push current-wait wait-stack))
(setf current-mode new-mode
current-position new-position
current-wait new-wait))))
(loop
(if (> current-position (length string))
(return-from scan-string
(progn
(format *trace-output* "Scan was called ~S times.~%"
*scan-calls*)
(finish-current (length string) nil (constantly nil))
result))
(or
(loop for transition in
(mapcar #'cdr
(remove current-mode transitions
:key #'car
:test-not #'(lambda (a b)
(or (eql a b)
(if (listp b)
(member a b))))))
if
(and transition
(multiple-value-bind
(new-position new-mode new-wait)
(funcall transition current-mode string current-position)
(when (> new-position current-position)
(finish-current new-position new-mode new-wait :extend nil :push t)
t)))
return t)
(multiple-value-bind
(pos advance)
(funcall current-wait current-position)
#+nil
(format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position)
(and pos
(when (> pos current-position)
(finish-current (if advance
pos
current-position)
(car mode-stack)
(car wait-stack)
:extend advance
:pop t)
t)))
(progn
(incf current-position)))
)))))
(defun format-scan (coloring-type scan)
(let* ((coloring-type-object (or (find-coloring-type coloring-type)
(error "No such coloring type: ~S" coloring-type)))
(color-formatter (coloring-type-term-formatter coloring-type-object))
(*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object))))
(format nil "~{~A~}~A"
(mapcar color-formatter scan)
(funcall (coloring-type-formatter-after-hook coloring-type-object)))))
(defun encode-for-pre (string)
(declare (simple-string string))
(let ((output (make-array (truncate (length string) 2/3)
:element-type 'character
:adjustable t
:fill-pointer 0)))
(with-output-to-string (out output)
(loop for char across string
do (case char
((#\&) (write-string "&amp;" out))
((#\<) (write-string "&lt;" out))
((#\>) (write-string "&gt;" out))
((#\") (write-string "&quot;" out))
((#\RIGHTWARDS_DOUBLE_ARROW) (write-string "&rArr;" out))
(t (write-char char out)))))
(coerce output 'simple-string)))
(defun string-substitute (string substring replacement-string)
"String substitute by Larry Hunter. Obtained from Google"
(let ((substring-length (length substring))
(last-end 0)
(new-string ""))
(do ((next-start
(search substring string)
(search substring string :start2 last-end)))
((null next-start)
(concatenate 'string new-string (subseq string last-end)))
(setq new-string
(concatenate 'string
new-string
(subseq string last-end next-start)
replacement-string))
(setq last-end (+ next-start substring-length)))))
(defun decode-from-tt (string)
(string-substitute
(string-substitute
(string-substitute
(string-substitute
(string-substitute string "&amp;" "&")
"&lt;" "<")
"&gt;" ">")
"&rArr;" (string #\RIGHTWARDS_DOUBLE_ARROW))
"&quot;" "\""))
(defun html-colorization (coloring-type string)
(format-scan coloring-type
(mapcar #'(lambda (p)
(cons (car p)
(let ((tt (encode-for-pre (cdr p))))
(if (and (> (length tt) 0)
(char= (elt tt (1- (length tt))) #\>))
(format nil "~A~%" tt) tt))))
(scan-string coloring-type string))))
(defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default"))
(let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
(merge-pathnames input-file-name)
(make-pathname :type "lisp"
:defaults (merge-pathnames input-file-name))))
(*css-background-class* css-background))
(with-open-file (s input-file :direction :input)
(let ((lines nil)
(string nil))
(block done
(loop (let ((line (read-line s nil nil)))
(if line
(push line lines)
(return-from done)))))
(setf string (format nil "~{~A~%~}"
(nreverse lines)))
(if wrap
(format s2
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">
<html><head><style type=\"text/css\">~A~%~A</style><body>
<table width=\"100%\"><tr><td class=\"~A\">
<tt>~A</tt>
</tr></td></table></body></html>"
*coloring-css*
(make-background-css "white")
*css-background-class*
(html-colorization coloring-type string))
(write-string (html-colorization coloring-type string) s2))))))
(defun colorize-file (coloring-type input-file-name &optional output-file-name)
(let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
(merge-pathnames input-file-name)
(make-pathname :type "lisp"
:defaults (merge-pathnames input-file-name))))
(output-file (or output-file-name
(make-pathname :type "html"
:defaults input-file))))
(with-open-file (s2 output-file :direction :output :if-exists :supersede)
(colorize-file-to-stream coloring-type input-file-name s2))))
;; coloring-types.lisp
;(in-package :colorize)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *version-token* (gensym)))
(defparameter *symbol-characters*
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890")
(defparameter *non-constituent*
'(#\space #\tab #\newline #\linefeed #\page #\return
#\" #\' #\( #\) #\, #\; #\` #\[ #\]))
(defparameter *special-forms*
'("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the"
"if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*"
"labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally"
"return-from" "setq" "multiple-value-call"))
(defparameter *common-macros*
'("loop" "cond" "lambda"))
(defparameter *open-parens* '(#\())
(defparameter *close-parens* '(#\)))
(define-coloring-type :lisp "Basic Lisp"
:modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment
:multiline :character
:single-escaped :in-list :syntax-error)
:default-mode :first-char-on-line
:transitions
(((:in-list)
((or
(scan-any *symbol-characters*)
(and (scan #\.) (scan-any *symbol-characters*))
(and (scan #\\) (advance 1)))
(set-mode :symbol
:until (scan-any *non-constituent*)
:advancing nil))
((or (scan #\:) (scan "#:"))
(set-mode :keyword
:until (scan-any *non-constituent*)
:advancing nil))
((scan "#\\")
(let ((count 0))
(set-mode :character
:until (progn
(incf count)
(if (> count 1)
(scan-any *non-constituent*)))
:advancing nil)))
((scan #\")
(set-mode :string
:until (scan #\")))
((scan #\;)
(set-mode :comment
:until (scan #\newline)))
((scan "#|")
(set-mode :multiline
:until (scan "|#")))
((scan #\()
(set-mode :in-list
:until (scan #\)))))
((:normal :first-char-on-line)
((scan #\()
(set-mode :in-list
:until (scan #\)))))
(:first-char-on-line
((scan #\;)
(set-mode :comment
:until (scan #\newline)))
((scan "#|")
(set-mode :multiline
:until (scan "|#")))
((advance 1)
(set-mode :normal
:until (scan #\newline))))
(:multiline
((scan "#|")
(set-mode :multiline
:until (scan "|#"))))
((:symbol :keyword :escaped-symbol :string)
((scan #\\)
(let ((count 0))
(set-mode :single-escaped
:until (progn
(incf count)
(if (< count 2)
(advance 1))))))))
:formatter-variables ((paren-counter 0))
:formatter-after-hook (lambda nil
(format nil "~{~A~}"
(loop for i from paren-counter downto 1
collect "</span></span>")))
:formatters
(((:normal :first-char-on-line)
(lambda (type s)
(declare (ignore type))
s))
((:in-list)
(lambda (type s)
(declare (ignore type))
(labels ((color-parens (s)
(let ((paren-pos (find-if-not #'null
(mapcar #'(lambda (c)
(position c s))
(append *open-parens*
*close-parens*)))))
(if paren-pos
(let ((before-paren (subseq s 0 paren-pos))
(after-paren (subseq s (1+ paren-pos)))
(paren (elt s paren-pos))
(open nil)
(count 0))
(when (member paren *open-parens* :test #'char=)
(setf count (mod paren-counter 6))
(incf paren-counter)
(setf open t))
(when (member paren *close-parens* :test #'char=)
(decf paren-counter))
(if open
(format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
before-paren
(1+ count)
paren *css-background-class*
(color-parens after-paren))
(format nil "~A</span>~C</span>~A"
before-paren
paren (color-parens after-paren))))
s))))
(color-parens s))))
((:symbol :escaped-symbol)
(lambda (type s)
(declare (ignore type))
(let* ((colon (position #\: s :from-end t))
(new-s (or (and colon (subseq s (1+ colon))) s)))
(cond
((or
(member new-s *common-macros* :test #'string-equal)
(member new-s *special-forms* :test #'string-equal)
(some #'(lambda (e)
(and (> (length new-s) (length e))
(string-equal e (subseq new-s 0 (length e)))))
'("WITH-" "DEF")))
(format nil "<i><span class=\"symbol\">~A</span></i>" s))
((and (> (length new-s) 2)
(char= (elt new-s 0) #\*)
(char= (elt new-s (1- (length new-s))) #\*))
(format nil "<span class=\"special\">~A</span>" s))
(t s)))))
(:keyword (lambda (type s)
(declare (ignore type))
(format nil "<span class=\"keyword\">~A</span>"
s)))
((:comment :multiline)
(lambda (type s)
(declare (ignore type))
(format nil "<span class=\"comment\">~A</span>"
s)))
((:character)
(lambda (type s)
(declare (ignore type))
(format nil "<span class=\"character\">~A</span>"
s)))
((:string)
(lambda (type s)
(declare (ignore type))
(format nil "<span class=\"string\">~A</span>"
s)))
((:single-escaped)
(lambda (type s)
(call-formatter (cdr type) s)))
((:syntax-error)
(lambda (type s)
(declare (ignore type))
(format nil "<span class=\"syntaxerror\">~A</span>"
s)))))
(define-coloring-type :scheme "Scheme"
:autodetect (lambda (text)
(or
(search "scheme" text :test #'char-equal)
(search "chicken" text :test #'char-equal)))
:parent :lisp
:transitions
(((:normal :in-list)
((scan "...")
(set-mode :symbol
:until (scan-any *non-constituent*)
:advancing nil))
((scan #\[)
(set-mode :in-list
:until (scan #\])))))
:formatters
(((:in-list)
(lambda (type s)
(declare (ignore type s))
(let ((*open-parens* (cons #\[ *open-parens*))
(*close-parens* (cons #\] *close-parens*)))
(call-parent-formatter))))
((:symbol :escaped-symbol)
(lambda (type s)
(declare (ignore type))
(let ((result (if (find-package :r5rs-lookup)
(funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup))
s))))
(if result
(format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
result (call-parent-formatter))
(call-parent-formatter)))))))
(define-coloring-type :elisp "Emacs Lisp"
:autodetect (lambda (name)
(member name '("emacs")
:test #'(lambda (name ext)
(search ext name :test #'char-equal))))
:parent :lisp
:formatters
(((:symbol :escaped-symbol)
(lambda (type s)
(declare (ignore type))
(let ((result (if (find-package :elisp-lookup)
(funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup))
s))))
(if result
(format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
result (call-parent-formatter))
(call-parent-formatter)))))))
(define-coloring-type :common-lisp "Common Lisp"
:autodetect (lambda (text)
(search "lisp" text :test #'char-equal))
:parent :lisp
:transitions
(((:normal :in-list)
((scan #\|)
(set-mode :escaped-symbol
:until (scan #\|)))))
:formatters
(((:symbol :escaped-symbol)
(lambda (type s)
(declare (ignore type))
(let* ((colon (position #\: s :from-end t :test #'char=))
(to-lookup (if colon (subseq s (1+ colon)) s))
(result (if (find-package :clhs-lookup)
(funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup))
to-lookup))))
(if result
(format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
result (call-parent-formatter))
(call-parent-formatter)))))))
(define-coloring-type :common-lisp-file "Common Lisp File"
:parent :common-lisp
:default-mode :in-list
:invisible t)
(defvar *c-open-parens* "([{")
(defvar *c-close-parens* ")]}")
(defvar *c-reserved-words*
'("auto" "break" "case" "char" "const"
"continue" "default" "do" "double" "else"
"enum" "extern" "float" "for" "goto"
"if" "int" "long" "register" "return"
"short" "signed" "sizeof" "static" "struct"
"switch" "typedef" "union" "unsigned" "void"
"volatile" "while" "__restrict" "_Bool"))
(defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
(defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#))
(define-coloring-type :basic-c "Basic C"
:modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor)
:default-mode :normal
:invisible t
:transitions
((:normal
((scan-any *c-begin-word*)
(set-mode :word-ish
:until (scan-any *c-terminators*)
:advancing nil))
((scan "/*")
(set-mode :comment
:until (scan "*/")))
((or
(scan-any *c-open-parens*)
(scan-any *c-close-parens*))
(set-mode :paren-ish
:until (advance 1)
:advancing nil))
((scan #\")
(set-mode :string
:until (scan #\")))
((or (scan "'\\")
(scan #\'))
(set-mode :character
:until (advance 2))))
(:string
((scan #\\)
(set-mode :single-escape
:until (advance 1)))))
:formatter-variables
((paren-counter 0))
:formatter-after-hook (lambda nil
(format nil "~{~A~}"
(loop for i from paren-counter downto 1
collect "</span></span>")))
:formatters
((:normal
(lambda (type s)
(declare (ignore type))
s))
(:comment
(lambda (type s)
(declare (ignore type))
(format nil "<span class=\"comment\">~A</span>"
s)))
(:string
(lambda (type s)
(declare (ignore type))
(format nil "<span class=\"string\">~A</span>"
s)))
(:character
(lambda (type s)
(declare (ignore type))
(format nil "<span class=\"character\">~A</span>"
s)))
(:single-escape
(lambda (type s)
(call-formatter (cdr type) s)))
(:paren-ish
(lambda (type s)
(declare (ignore type))
(let ((open nil)
(count 0))
(if (eql (length s) 1)
(progn
(when (member (elt s 0) (coerce *c-open-parens* 'list))
(setf open t)
(setf count (mod paren-counter 6))
(incf paren-counter))
(when (member (elt s 0) (coerce *c-close-parens* 'list))
(setf open nil)
(decf paren-counter)
(setf count (mod paren-counter 6)))
(if open
(format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
(1+ count) s *css-background-class*)
(format nil "</span>~A</span>"
s)))
s))))
(:word-ish
(lambda (type s)
(declare (ignore type))
(if (member s *c-reserved-words* :test #'string=)
(format nil "<span class=\"symbol\">~A</span>" s)
s)))
))
(define-coloring-type :c "C"
:parent :basic-c
:transitions
((:normal
((scan #\#)
(set-mode :preprocessor
:until (scan-any '(#\return #\newline))))))
:formatters
((:preprocessor
(lambda (type s)
(declare (ignore type))
(format nil "<span class=\"special\">~A</span>" s)))))
(defvar *c++-reserved-words*
'("asm" "auto" "bool" "break" "case"
"catch" "char" "class" "const" "const_cast"
"continue" "default" "delete" "do" "double"
"dynamic_cast" "else" "enum" "explicit" "export"
"extern" "false" "float" "for" "friend"
"goto" "if" "inline" "int" "long"
"mutable" "namespace" "new" "operator" "private"
"protected" "public" "register" "reinterpret_cast" "return"
"short" "signed" "sizeof" "static" "static_cast"
"struct" "switch" "template" "this" "throw"
"true" "try" "typedef" "typeid" "typename"
"union" "unsigned" "using" "virtual" "void"
"volatile" "wchar_t" "while"))
(define-coloring-type :c++ "C++"
:parent :c
:transitions
((:normal
((scan "//")
(set-mode :comment
:until (scan-any '(#\return #\newline))))))
:formatters
((:word-ish
(lambda (type s)
(declare (ignore type))
(if (member s *c++-reserved-words* :test #'string=)
(format nil "<span class=\"symbol\">~A</span>"
s)
s)))))
(defvar *java-reserved-words*
'("abstract" "boolean" "break" "byte" "case"
"catch" "char" "class" "const" "continue"
"default" "do" "double" "else" "extends"
"final" "finally" "float" "for" "goto"
"if" "implements" "import" "instanceof" "int"
"interface" "long" "native" "new" "package"
"private" "protected" "public" "return" "short"
"static" "strictfp" "super" "switch" "synchronized"
"this" "throw" "throws" "transient" "try"
"void" "volatile" "while"))
(define-coloring-type :java "Java"
:parent :c++
:formatters
((:word-ish
(lambda (type s)
(declare (ignore type))
(if (member s *java-reserved-words* :test #'string=)
(format nil "<span class=\"symbol\">~A</span>"
s)
s)))))
(let ((terminate-next nil))
(define-coloring-type :objective-c "Objective C"
:autodetect (lambda (text) (search "mac" text :test #'char=))
:modes (:begin-message-send :end-message-send)
:transitions
((:normal
((scan #\[)
(set-mode :begin-message-send
:until (advance 1)
:advancing nil))
((scan #\])
(set-mode :end-message-send
:until (advance 1)
:advancing nil))
((scan-any *c-begin-word*)
(set-mode :word-ish
:until (or
(and (peek-any '(#\:))
(setf terminate-next t))
(and terminate-next (progn
(setf terminate-next nil)
(advance 1)))
(scan-any *c-terminators*))
:advancing nil)))
(:word-ish
#+nil
((scan #\:)
(format t "hi~%")
(set-mode :word-ish :until (advance 1) :advancing nil)
(setf terminate-next t))))
:parent :c++
:formatter-variables ((is-keyword nil) (in-message-send nil))
:formatters
((:begin-message-send
(lambda (type s)
(setf is-keyword nil)
(setf in-message-send t)
(call-formatter (cons :paren-ish type) s)))
(:end-message-send
(lambda (type s)
(setf is-keyword nil)
(setf in-message-send nil)
(call-formatter (cons :paren-ish type) s)))
(:word-ish
(lambda (type s)
(declare (ignore type))
(prog1
(let ((result (if (find-package :cocoa-lookup)
(funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
s))))
(if result
(format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
result s)
(if (member s *c-reserved-words* :test #'string=)
(format nil "<span class=\"symbol\">~A</span>" s)
(if in-message-send
(if is-keyword
(format nil "<span class=\"keyword\">~A</span>" s)
s)
s))))
(setf is-keyword (not is-keyword))))))))
;#!/usr/bin/clisp
;#+sbcl
;(require :asdf)
;(asdf:oos 'asdf:load-op :colorize)
(defmacro with-each-stream-line ((var stream) &body body)
(let ((eof (gensym))
(eof-value (gensym))
(strm (gensym)))
`(let ((,strm ,stream)
(,eof ',eof-value))
(do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
((eql ,var ,eof))
,@body))))
(defun system (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
output to *verbose-out*. Returns the shell's exit code."
(let ((command (apply #'format nil control-string args)))
(format t "; $ ~A~%" command)
#+sbcl
(sb-impl::process-exit-code
(sb-ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output *standard-output*))
#+(or cmucl scl)
(ext:process-exit-code
(ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*))
#+clisp ;XXX not exactly *verbose-out*, I know
(ext:run-shell-command command :output :terminal :wait t)
))
(defun strcat (&rest strings)
(apply #'concatenate 'string strings))
(defun string-starts-with (start str)
(and (>= (length str) (length start))
(string-equal start str :end2 (length start))))
(defmacro string-append (outputstr &rest args)
`(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
(defconstant +indent+ 0
"Indentation used in the examples.")
(defun texinfo->raw-lisp (code)
"Answer CODE with spurious Texinfo output removed. For use in
preprocessing output in a @lisp block before passing to colorize."
(decode-from-tt
(with-output-to-string (output)
(do* ((last-position 0)
(next-position
#0=(search #1="<span class=\"roman\">" code
:start2 last-position :test #'char-equal)
#0#))
((eq nil next-position)
(write-string code output :start last-position))
(write-string code output :start last-position :end next-position)
(let ((end (search #2="</span>" code
:start2 (+ next-position (length #1#))
:test #'char-equal)))
(assert (integerp end) ()
"Missing ~A tag in HTML for @lisp block~%~
HTML contents of block:~%~A" #2# code)
(write-string code output
:start (+ next-position (length #1#))
:end end)
(setf last-position (+ end (length #2#))))))))
(defun process-file (from to)
(with-open-file (output to :direction :output :if-exists :error)
(with-open-file (input from :direction :input)
(let ((line-processor nil)
(piece-of-code '()))
(labels
((process-line-inside-pre (line)
(cond ((string-starts-with "</pre>" line)
(with-input-from-string
(stream (colorize:html-colorization
:common-lisp
(texinfo->raw-lisp
(apply #'concatenate 'string
(nreverse piece-of-code)))))
(with-each-stream-line (cline stream)
(format output " ~A~%" cline)))
(write-line line output)
(setq piece-of-code '()
line-processor #'process-regular-line))
(t (let ((to-append (subseq line +indent+)))
(push (if (string= "" to-append)
" "
to-append) piece-of-code)
(push (string #\Newline) piece-of-code)))))
(process-regular-line (line)
(let ((len (some (lambda (test-string)
(when (string-starts-with test-string line)
(length test-string)))
'("<pre class=\"lisp\">"
"<pre class=\"smalllisp\">"))))
(cond (len
(setq line-processor #'process-line-inside-pre)
(write-string "<pre class=\"lisp\">" output)
(push (subseq line (+ len +indent+)) piece-of-code)
(push (string #\Newline) piece-of-code))
(t (write-line line output))))))
(setf line-processor #'process-regular-line)
(with-each-stream-line (line input)
(funcall line-processor line)))))))
(defun process-dir (dir)
(dolist (html-file (directory dir))
(let* ((name (namestring html-file))
(temp-name (strcat name ".temp")))
(process-file name temp-name)
(system "mv ~A ~A" temp-name name))))
;; (go "/tmp/doc/manual/html_node/*.html")
#+clisp
(progn
(assert (first ext:*args*))
(process-dir (first ext:*args*)))
#+sbcl
(progn
(assert (second sb-ext:*posix-argv*))
(process-dir (second sb-ext:*posix-argv*))
(sb-ext:quit))