[Lisppaste-cvs] CVS update: lisppaste2/colorize.lisp lisppaste2/coloring-types.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Thu Jun 3 14:17:04 UTC 2004
Update of /project/lisppaste/cvsroot/lisppaste2
In directory common-lisp.net:/home/bmastenbrook/lisppaste2
Modified Files:
colorize.lisp coloring-types.lisp
Log Message:
MORE ANGRY FRUITS! (paren colorization with CSS :hover)
Date: Thu Jun 3 07:17:04 2004
Author: bmastenbrook
Index: lisppaste2/colorize.lisp
diff -u lisppaste2/colorize.lisp:1.1 lisppaste2/colorize.lisp:1.2
--- lisppaste2/colorize.lisp:1.1 Tue Jun 1 06:17:50 2004
+++ lisppaste2/colorize.lisp Thu Jun 3 07:17:04 2004
@@ -1,10 +1,5 @@
;;;; colorize.lisp
-(defpackage :colorize (:use :common-lisp)
- (:export :scan-string :format-scan
- :find-coloring-type :autodetect-coloring-type
- :coloring-types :scan :scan-any :advance :call-parent-formatter :colorize-file
- :*coloring-css*))
(in-package :colorize)
(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -16,6 +11,8 @@
(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
@@ -61,9 +58,8 @@
(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)
- (when (> (length ,string-param) (+ ,position-place ,num))
- (setf ,position-place (+ ,position-place ,num))
- t))
+ (setf ,position-place (+ ,position-place ,num))
+ t)
(scan-any (,items &key ,not-preceded-by)
(incf *scan-calls*)
(let* ((,items (if (stringp ,items)
@@ -116,38 +112,59 @@
(list 'values ,until ,advancing)))))))
, at body))))
+(defvar *formatter-local-variables*)
+
(defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters
- autodetect parent)
+ autodetect parent formatter-variables (formatter-after-hook '(constantly "")))
(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
- :term-formatter
- (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)
- , at formatters
- (t (lambda (,type text)
- (call-parent-formatter ,type text))))
- ,type ,string)))
- (call-formatter)))
- :transition-functions
+ :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
+ :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)
+ , at 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
@@ -202,7 +219,7 @@
current-position new-position
current-wait new-wait))))
(loop
- (if (>= current-position (length string))
+ (if (> current-position (length string))
(return-from scan-string
(progn
(format t "Scan was called ~S times.~%"
@@ -230,6 +247,8 @@
(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
@@ -247,9 +266,11 @@
(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)))
- (format nil "~{~A~}"
- (mapcar color-formatter scan))))
+ (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 colorize-file (coloring-type input-file-name &optional output-file-name)
(let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
@@ -258,7 +279,8 @@
:defaults (merge-pathnames input-file-name))))
(output-file (or output-file-name
(make-pathname :type "html"
- :defaults input-file))))
+ :defaults input-file)))
+ (*css-background-class* "default"))
(with-open-file (s input-file :direction :input)
(let ((lines nil)
(string nil))
@@ -271,11 +293,21 @@
(nreverse lines)))
(with-open-file (s2 output-file :direction :output :if-exists :supersede)
(format s2
- "<html><head><style type=\"text/css\">~A</style><body><tt>~A</tt></body></html>"
+ "<!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*
(format-scan coloring-type
(mapcar #'(lambda (p)
(cons (car p)
- (html-encode:encode-for-tt (cdr p))))
+ (let ((tt
+ (html-encode:encode-for-tt (cdr p))))
+ (if (and (> (length tt) 0)
+ (char= (elt tt (1- (length tt))) #\>))
+ (format nil "~A~%" tt) tt))))
(scan-string coloring-type
- string)))))))))
\ No newline at end of file
+ string)))))))))
Index: lisppaste2/coloring-types.lisp
diff -u lisppaste2/coloring-types.lisp:1.2 lisppaste2/coloring-types.lisp:1.3
--- lisppaste2/coloring-types.lisp:1.2 Tue Jun 1 06:41:27 2004
+++ lisppaste2/coloring-types.lisp Thu Jun 3 07:17:04 2004
@@ -2,26 +2,12 @@
(in-package :colorize)
-(defparameter *coloring-css*
- ".symbol { color : #770055; background-color : inherit; }
-a.symbol:link { color : #229955; background-color : inherit; text-decoration: underline; }
-a.symbol:active { color : #229955; background-color : inherit; text-decoration: underline; }
-a.symbol:visited { color : #229955; background-color : inherit; text-decoration: underline; }
-a.symbol:hover { color : #229955; background-color : inherit; text-decoration: underline; }
-.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; }
-")
-
(defparameter *symbol-characters*
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&")
(defparameter *non-constituent*
'(#\space #\tab #\newline #\linefeed #\page #\return
- #\" #\' #\( #\) #\, #\; #\`))
+ #\" #\' #\( #\) #\, #\; #\` #\[ #\]))
(defparameter *special-forms*
'("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the"
@@ -32,6 +18,9 @@
(defparameter *common-macros*
'("loop" "cond" "lambda"))
+(defparameter *open-parens* '(#\())
+(defparameter *close-parens* '(#\)))
+
(define-coloring-type :lisp "Basic Lisp"
:autodetect (lambda (name)
(member name '("emacs")
@@ -39,21 +28,10 @@
(search ext name :test #'char-equal))))
:modes (:normal :symbol :escaped-symbol :keyword :string :comment
:multiline :character
- :single-escaped :in-list :dotted-list-tail :syntax-error)
+ :single-escaped :in-list :syntax-error)
:default-mode :normal
:transitions
- (#|
- ((:in-list)
- ((scan #\.)
- (set-mode :dotted-list-tail
- :until (scan #\))
- :advancing nil)))
- ((:dotted-list-tail)
- ((scan #\.)
- (set-mode :syntax-error
- :until (scan #\))
- :advancing nil)))|#
- ((:normal :in-list :dotted-list-tail)
+ (((:normal :in-list)
((or
(scan-any *symbol-characters*)
(and (scan "+") (scan-any *symbol-characters*))
@@ -68,9 +46,6 @@
(set-mode :keyword
:until (scan-any *non-constituent*)
:advancing nil))
- ((scan #\|)
- (set-mode :escaped-symbol
- :until (scan #\|)))
((scan "#\\")
(let ((count 0))
(set-mode :character
@@ -103,14 +78,47 @@
(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 (lambda (type s)
(declare (ignore type))
s))
- ((:in-list :dotted-list-tail)
+ ((:in-list)
(lambda (type s)
(declare (ignore type))
- s))
+ (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))
@@ -163,16 +171,41 @@
(search "scheme" text :test #'char-equal))
:parent :lisp
:transitions
- (((:normal :in-list :dotted-list-tail)
+ (((:normal :in-list)
((scan "...")
(set-mode :symbol
:until (scan-any *non-constituent*)
- :advancing nil)))))
+ :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 :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)
More information about the Lisppaste-cvs
mailing list