Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

1051 lines (982 sloc) 44.042 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))
(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 "&amp;" "&")
"&lt;" "<")
"&gt;" ">"))
(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 cmu 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+ 2
"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))
Jump to Line
Something went wrong with that request. Please try again.