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))))))) ,@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) - ,@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) + ,@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)