[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