colorize.lisp

   1 ;;; This is code was taken from lisppaste2 and is a quick hack
   2 ;;; to colorize lisp examples in the html generated by Texinfo.
   3 ;;; It is not general-purpose utility, though it could easily be
   4 ;;; turned into one.
   5
   6 ;;;; colorize-package.lisp
   7
   8 (defpackage :colorize
   9   (:use :common-lisp)
  10   (:export :scan-string :format-scan :html-colorization
  11            :find-coloring-type :autodetect-coloring-type
  12            :coloring-types :scan :scan-any :advance :call-parent-formatter
  13            :*coloring-css* :make-background-css :*css-background-class*
  14            :colorize-file :colorize-file-to-stream :*version-token*))
  15
  16 ;;;; coloring-css.lisp
  17
  18 (in-package :colorize)
  19
  20 (defparameter *coloring-css*
  21   ".symbol { color: #770055; background-color: transparent; border: 0px; margin: 0px;}
  22 a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
  23 a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
  24 a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
  25 a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
  26 .special { color : #FF5000; background-color : inherit; }
  27 .keyword { color : #770000; background-color : inherit; }
  28 .comment { color : #007777; background-color : inherit; }
  29 .string { color : #777777; background-color : inherit; }
  30 .character { color : #0055AA; background-color : inherit; }
  31 .syntaxerror { color : #FF0000; background-color : inherit; }
  32 span.paren1:hover { color : inherit; background-color : #BAFFFF; }
  33 span.paren2:hover { color : inherit; background-color : #FFCACA; }
  34 span.paren3:hover { color : inherit; background-color : #FFFFBA; }
  35 span.paren4:hover { color : inherit; background-color : #CACAFF; }
  36 span.paren5:hover { color : inherit; background-color : #CAFFCA; }
  37 span.paren6:hover { color : inherit; background-color : #FFBAFF; }
  38 ")
  39
  40 (defvar *css-background-class* "lisp-bg")
  41
  42 (defun for-css (thing)
  43   (if (symbolp thing) (string-downcase (symbol-name thing))
  44       thing))
  45
  46 (defun make-background-css (color &key (class *css-background-class*) (extra nil))
  47   (format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*~:*
  48 .~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%"
  49           class color
  50           (mapcar #'(lambda (extra)
  51                       (format nil "~A : ~{~A ~}"
  52                               (for-css (first extra))
  53                               (mapcar #'for-css (cdr extra))))
  54                   extra)))
  55
  56 ;;;; colorize.lisp
  57
  58 ;(in-package :colorize)
  59
  60 (eval-when (:compile-toplevel :load-toplevel :execute)
  61   (defparameter *coloring-types* nil)
  62   (defparameter *version-token* (gensym)))
  63
  64 (defclass coloring-type ()
  65   ((modes :initarg :modes :accessor coloring-type-modes)
  66    (default-mode :initarg :default-mode :accessor coloring-type-default-mode)
  67    (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions)
  68    (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name)
  69    (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter)
  70    (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil)
  71    (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly ""))
  72    (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function
  73                         :initform (constantly nil))
  74    (parent-type :initarg :parent-type :accessor coloring-type-parent-type
  75                 :initform nil)
  76    (visible :initarg :visible :accessor coloring-type-visible
  77             :initform t)))
  78
  79 (defun find-coloring-type (type)
  80   (if (typep type 'coloring-type)
  81       type
  82       (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name))))
  83
  84 (defun autodetect-coloring-type (name)
  85   (car
  86    (find name *coloring-types*
  87          :key #'cdr
  88          :test #'(lambda (name type)
  89                    (and (coloring-type-visible type)
  90                         (funcall (coloring-type-autodetect-function type) name))))))
  91
  92 (defun coloring-types ()
  93   (loop for type-pair in *coloring-types*
  94         if (coloring-type-visible (cdr type-pair))
  95         collect (cons (car type-pair)
  96                       (coloring-type-fancy-name (cdr type-pair)))))
  97
  98 (defun (setf find-coloring-type) (new-value type)
  99   (if new-value
 100       (let ((found (assoc type *coloring-types*)))
 101         (if found
 102             (setf (cdr found) new-value)
 103             (setf *coloring-types*
 104                   (nconc *coloring-types*
 105                          (list (cons type new-value))))))
 106       (setf *coloring-types* (remove type *coloring-types* :key #'car))))
 107
 108 (defvar *scan-calls* 0)
 109
 110 (defvar *reset-position* nil)
 111
 112 (defmacro with-gensyms ((&rest names) &body body)
 113   `(let ,(mapcar #'(lambda (name)
 114                      (list name `(make-symbol ,(symbol-name name)))) names)
 115     ,@body))
 116
 117 (defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body)
 118   (with-gensyms (num items position not-preceded-by string item new-mode until advancing)
 119     `(labels ((advance (,num)
 120                (setf ,position-place (+ ,position-place ,num))
 121                t)
 122               (peek-any (,items &key ,not-preceded-by)
 123                (incf *scan-calls*)
 124                (let* ((,items (if (stringp ,items)
 125                                   (coerce ,items 'list) ,items))
 126                       (,not-preceded-by (if (characterp ,not-preceded-by)
 127                                             (string ,not-preceded-by) ,not-preceded-by))
 128                       (,position ,position-place)
 129                       (,string ,string-param))
 130                  (let ((,item (and
 131                                (< ,position (length ,string))
 132                                (find ,string ,items
 133                                      :test #'(lambda (,string ,item)
 134                                                #+nil
 135                                                (format t "looking for ~S in ~S starting at ~S~%"
 136                                                        ,item ,string ,position)
 137                                                (if (characterp ,item)
 138                                                    (char= (elt ,string ,position)
 139                                                           ,item)
 140                                                    (search ,item ,string :start2 ,position
 141                                                            :end2 (min (length ,string)
 142                                                                       (+ ,position (length ,item))))))))))
 143                    (if (characterp ,item)
 144                        (setf ,item (string ,item)))
 145                    (if
 146                     (if ,item
 147                         (if ,not-preceded-by
 148                             (if (>= (- ,position (length ,not-preceded-by)) 0)
 149                                 (not (string= (subseq ,string
 150                                                       (- ,position (length ,not-preceded-by))
 151                                                       ,position)
 152                                               ,not-preceded-by))
 153                                 t)
 154                             t)
 155                         nil)
 156           ,item
 157                     (progn
 158                       (and *reset-position*
 159                            (setf ,position-place *reset-position*))
 160                       nil)))))
 161          (scan-any (,items &key ,not-preceded-by)
 162       (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by)))
 163         (and ,item (advance (length ,item)))))
 164          (peek (,item &key ,not-preceded-by)
 165       (peek-any (list ,item) :not-preceded-by ,not-preceded-by))
 166               (scan (,item &key ,not-preceded-by)
 167                (scan-any (list ,item) :not-preceded-by ,not-preceded-by)))
 168       (macrolet ((set-mode (,new-mode &key ,until (,advancing t))
 169                    (list 'progn
 170                          (list 'setf ',mode-place ,new-mode)
 171                          (list 'setf ',mode-wait-place
 172                                (list 'lambda (list ',position)
 173                                      (list 'let (list (list '*reset-position* ',position))
 174                                            (list 'values ,until ,advancing)))))))
 175         ,@body))))
 176
 177 (defvar *formatter-local-variables*)
 178
 179 (defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters
 180                                 autodetect parent formatter-variables (formatter-after-hook '(constantly ""))
 181                                 invisible)
 182   (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance)
 183     `(let ((,parent-type (or (find-coloring-type ,parent)
 184                              (and ,parent
 185                                   (error "No such coloring type: ~S" ,parent)))))
 186       (setf (find-coloring-type ,name)
 187        (make-instance 'coloring-type
 188         :fancy-name ',fancy-name
 189         :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type)))
 190         :default-mode (or ',default-mode
 191                           (if ,parent-type (coloring-type-default-mode ,parent-type)))
 192         ,@(if autodetect
 193               `(:autodetect-function ,autodetect))
 194         :parent-type ,parent-type
 195         :visible (not ,invisible)
 196         :formatter-initial-values (lambda nil
 197                                     (list* ,@(mapcar #'(lambda (e)
 198                                                          `(cons ',(car e) ,(second e)))
 199                                                      formatter-variables)
 200                                            (if ,parent-type
 201                                                (funcall (coloring-type-formatter-initial-values ,parent-type))
 202                                                nil)))
 203         :formatter-after-hook (lambda nil
 204                                 (symbol-macrolet ,(mapcar #'(lambda (e)
 205                                                               `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
 206                                                           formatter-variables)
 207                                     (concatenate 'string
 208                                                  (funcall ,formatter-after-hook)
 209                                                  (if ,parent-type
 210                                                      (funcall (coloring-type-formatter-after-hook ,parent-type))
 211                                                      ""))))
 212         :term-formatter
 213         (symbol-macrolet ,(mapcar #'(lambda (e)
 214                                       `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
 215                                   formatter-variables)
 216             (lambda (,term)
 217               (labels ((call-parent-formatter (&optional (,type (car ,term))
 218                                                          (,string (cdr ,term)))
 219                          (if ,parent-type
 220                              (funcall (coloring-type-term-formatter ,parent-type)
 221                                       (cons ,type ,string))))
 222                        (call-formatter (&optional (,type (car ,term))
 223                                                   (,string (cdr ,term)))
 224                          (funcall
 225                           (case (first ,type)
 226                             ,@formatters
 227                             (t (lambda (,type text)
 228                                  (call-parent-formatter ,type text))))
 229                           ,type ,string)))
 230                 (call-formatter))))
 231         :transition-functions
 232         (list
 233          ,@(loop for transition in transitions
 234                  collect (destructuring-bind (mode &rest table) transition
 235                            `(cons ',mode
 236                              (lambda (,current-mode ,string ,position)
 237                                (let ((,mode-wait (constantly nil))
 238                                      (,position-foobage ,position))
 239                                  (with-scanning-functions ,string ,position-foobage
 240                                                           ,current-mode ,mode-wait
 241                                                           (let ((*reset-position* ,position))
 242                                                             (cond ,@table))
 243                                                           (values ,position-foobage ,current-mode
 244                                                                   (lambda (,new-position)
 245                                                                     (setf ,position-foobage ,new-position)
 246                                                                     (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage))))
 247                                                                       (values ,position-foobage ,advance)))))
 248                                  )))))))))))
 249
 250 (defun full-transition-table (coloring-type-object)
 251   (let ((parent (coloring-type-parent-type coloring-type-object)))
 252     (if parent
 253         (append (coloring-type-transition-functions coloring-type-object)
 254                 (full-transition-table parent))
 255         (coloring-type-transition-functions coloring-type-object))))
 256
 257 (defun scan-string (coloring-type string)
 258   (let* ((coloring-type-object (or (find-coloring-type coloring-type)
 259                                    (error "No such coloring type: ~S" coloring-type)))
 260          (transitions (full-transition-table coloring-type-object))
 261          (result nil)
 262          (low-bound 0)
 263          (current-mode (coloring-type-default-mode coloring-type-object))
 264          (mode-stack nil)
 265          (current-wait (constantly nil))
 266          (wait-stack nil)
 267          (current-position 0)
 268          (*scan-calls* 0))
 269     (flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop)
 270              (let ((to (if extend new-position current-position)))
 271                (if (> to low-bound)
 272                    (setf result (nconc result
 273                                        (list (cons (cons current-mode mode-stack)
 274                                                    (subseq string low-bound
 275                                                            to))))))
 276                (setf low-bound to)
 277                (when pop
 278                  (pop mode-stack)
 279                  (pop wait-stack))
 280                (when push
 281                  (push current-mode mode-stack)
 282                  (push current-wait wait-stack))
 283                (setf current-mode new-mode
 284                      current-position new-position
 285                      current-wait new-wait))))
 286       (loop
 287        (if (> current-position (length string))
 288            (return-from scan-string
 289              (progn
 290                (format *trace-output* "Scan was called ~S times.~%"
 291                        *scan-calls*)
 292                (finish-current (length string) nil (constantly nil))
 293                result))
 294            (or
 295             (loop for transition in
 296                   (mapcar #'cdr
 297                           (remove current-mode transitions
 298                                   :key #'car
 299                                   :test-not #'(lambda (a b)
 300                                                 (or (eql a b)
 301                                                     (if (listp b)
 302                                                         (member a b))))))
 303                   if
 304                   (and transition
 305                        (multiple-value-bind
 306                              (new-position new-mode new-wait)
 307                            (funcall transition current-mode string current-position)
 308                          (when (> new-position current-position)
 309                            (finish-current new-position new-mode new-wait :extend nil :push t)
 310                            t)))
 311                   return t)
 312             (multiple-value-bind
 313                   (pos advance)
 314                 (funcall current-wait current-position)
 315               #+nil
 316               (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position)
 317               (and pos
 318                    (when (> pos current-position)
 319                      (finish-current (if advance
 320                                          pos
 321                                          current-position)
 322                                      (car mode-stack)
 323                                      (car wait-stack)
 324                                      :extend advance
 325                                      :pop t)
 326                      t)))
 327             (progn
 328               (incf current-position)))
 329            )))))
 330
 331 (defun format-scan (coloring-type scan)
 332   (let* ((coloring-type-object (or (find-coloring-type coloring-type)
 333                                    (error "No such coloring type: ~S" coloring-type)))
 334          (color-formatter (coloring-type-term-formatter coloring-type-object))
 335          (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object))))
 336     (format nil "~{~A~}~A"
 337             (mapcar color-formatter scan)
 338             (funcall (coloring-type-formatter-after-hook coloring-type-object)))))
 339
 340 (defun encode-for-pre (string)
 341   (declare (simple-string string))
 342   (let ((output (make-array (truncate (length string) 2/3)
 343                             :element-type 'character
 344                             :adjustable t
 345                             :fill-pointer 0)))
 346     (with-output-to-string (out output)
 347       (loop for char across string
 348             do (case char
 349                  ((#\&) (write-string "&amp;" out))
 350                  ((#\<) (write-string "&lt;" out))
 351                  ((#\>) (write-string "&gt;" out))
 352                  (t (write-char char out)))))
 353     (coerce output 'simple-string)))
 354
 355 (defun string-substitute (string substring replacement-string)
 356   "String substitute by Larry Hunter. Obtained from Google"
 357   (let ((substring-length (length substring))
 358     (last-end 0)
 359     (new-string ""))
 360     (do ((next-start
 361       (search substring string)
 362       (search substring string :start2 last-end)))
 363     ((null next-start)
 364      (concatenate 'string new-string (subseq string last-end)))
 365       (setq new-string
 366     (concatenate 'string
 367       new-string
 368       (subseq string last-end next-start)
 369       replacement-string))
 370       (setq last-end (+ next-start substring-length)))))
 371
 372 (defun decode-from-tt (string)
 373   (string-substitute (string-substitute (string-substitute string "&amp;" "&")
 374                                         "&lt;" "<")
 375                     "&gt;" ">"))
 376
 377 (defun html-colorization (coloring-type string)
 378   (format-scan coloring-type
 379                (mapcar #'(lambda (p)
 380                            (cons (car p)
 381                                  (let ((tt (encode-for-pre (cdr p))))
 382                                    (if (and (> (length tt) 0)
 383                                             (char= (elt tt (1- (length tt))) #\>))
 384                                        (format nil "~A~%" tt) tt))))
 385                        (scan-string coloring-type string))))
 386
 387 (defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default"))
 388   (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
 389                          (merge-pathnames input-file-name)
 390                          (make-pathname :type "lisp"
 391                                         :defaults (merge-pathnames input-file-name))))
 392          (*css-background-class* css-background))
 393     (with-open-file (s input-file :direction :input)
 394       (let ((lines nil)
 395             (string nil))
 396         (block done
 397           (loop (let ((line (read-line s nil nil)))
 398                   (if line
 399                       (push line lines)
 400                       (return-from done)))))
 401         (setf string (format nil "~{~A~%~}"
 402                              (nreverse lines)))
 403         (if wrap
 404             (format s2
 405                     "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">
 406 <html><head><style type=\"text/css\">~A~%~A</style><body>
 407 <table width=\"100%\"><tr><td class=\"~A\">
 408 <tt>~A</tt>
 409 </tr></td></table></body></html>"
 410                     *coloring-css*
 411                     (make-background-css "white")
 412                     *css-background-class*
 413                     (html-colorization coloring-type string))
 414             (write-string (html-colorization coloring-type string) s2))))))
 415
 416 (defun colorize-file (coloring-type input-file-name &optional output-file-name)
 417   (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
 418                          (merge-pathnames input-file-name)
 419                          (make-pathname :type "lisp"
 420                                         :defaults (merge-pathnames input-file-name))))
 421          (output-file (or output-file-name
 422                           (make-pathname :type "html"
 423                                          :defaults input-file))))
 424     (with-open-file (s2 output-file :direction :output :if-exists :supersede)
 425       (colorize-file-to-stream coloring-type input-file-name s2))))
 426
 427 ;; coloring-types.lisp
 428
 429 ;(in-package :colorize)
 430
 431 (eval-when (:compile-toplevel :load-toplevel :execute)
 432   (defparameter *version-token* (gensym)))
 433
 434 (defparameter *symbol-characters*
 435   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890")
 436
 437 (defparameter *non-constituent*
 438   '(#\space #\tab #\newline #\linefeed #\page #\return
 439     #\" #\' #\( #\) #\, #\; #\` #\[ #\]))
 440
 441 (defparameter *special-forms*
 442   '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the"
 443     "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*"
 444     "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally"
 445     "return-from" "setq" "multiple-value-call"))
 446
 447 (defparameter *common-macros*
 448   '("loop" "cond" "lambda"))
 449
 450 (defparameter *open-parens* '(#\())
 451 (defparameter *close-parens* '(#\)))
 452
 453 (define-coloring-type :lisp "Basic Lisp"
 454   :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment
 455                   :multiline :character
 456                   :single-escaped :in-list :syntax-error)
 457   :default-mode :first-char-on-line
 458   :transitions
 459   (((:in-list)
 460     ((or
 461       (scan-any *symbol-characters*)
 462       (and (scan #\.) (scan-any *symbol-characters*))
 463       (and (scan #\\) (advance 1)))
 464      (set-mode :symbol
 465                :until (scan-any *non-constituent*)
 466                :advancing nil))
 467     ((or (scan #\:) (scan "#:"))
 468      (set-mode :keyword
 469                :until (scan-any *non-constituent*)
 470                :advancing nil))
 471     ((scan "#\\")
 472      (let ((count 0))
 473        (set-mode :character
 474                  :until (progn
 475                           (incf count)
 476                           (if (> count 1)
 477                               (scan-any *non-constituent*)))
 478                  :advancing nil)))
 479     ((scan #\")
 480      (set-mode :string
 481                :until (scan #\")))
 482     ((scan #\;)
 483      (set-mode :comment
 484                :until (scan #\newline)))
 485     ((scan "#|")
 486      (set-mode :multiline
 487                :until (scan "|#")))
 488     ((scan #\()
 489      (set-mode :in-list
 490                :until (scan #\)))))
 491    ((:normal :first-char-on-line)
 492     ((scan #\()
 493      (set-mode :in-list
 494                :until (scan #\)))))
 495    (:first-char-on-line
 496     ((scan #\;)
 497      (set-mode :comment
 498                :until (scan #\newline)))
 499     ((scan "#|")
 500      (set-mode :multiline
 501                :until (scan "|#")))
 502     ((advance 1)
 503      (set-mode :normal
 504                :until (scan #\newline))))
 505    (:multiline
 506     ((scan "#|")
 507      (set-mode :multiline
 508                :until (scan "|#"))))
 509    ((:symbol :keyword :escaped-symbol :string)
 510     ((scan #\\)
 511      (let ((count 0))
 512        (set-mode :single-escaped
 513                  :until (progn
 514                           (incf count)
 515                           (if (< count 2)
 516                               (advance 1))))))))
 517   :formatter-variables ((paren-counter 0))
 518   :formatter-after-hook (lambda nil
 519                           (format nil "~{~A~}"
 520                                   (loop for i from paren-counter downto 1
 521                                         collect "</span></span>")))
 522   :formatters
 523   (((:normal :first-char-on-line)
 524     (lambda (type s)
 525       (declare (ignore type))
 526       s))
 527    ((:in-list)
 528     (lambda (type s)
 529       (declare (ignore type))
 530       (labels ((color-parens (s)
 531                  (let ((paren-pos (find-if-not #'null
 532                                                (mapcar #'(lambda (c)
 533                                                            (position c s))
 534                                                        (append *open-parens*
 535                                                                *close-parens*)))))
 536                    (if paren-pos
 537                        (let ((before-paren (subseq s 0 paren-pos))
 538                              (after-paren (subseq s (1+ paren-pos)))
 539                              (paren (elt s paren-pos))
 540                              (open nil)
 541                              (count 0))
 542                          (when (member paren *open-parens* :test #'char=)
 543                            (setf count (mod paren-counter 6))
 544                            (incf paren-counter)
 545                            (setf open t))
 546                          (when (member paren *close-parens* :test #'char=)
 547                            (decf paren-counter))
 548                          (if open
 549                              (format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
 550                                      before-paren
 551                                      (1+ count)
 552                                      paren *css-background-class*
 553                                      (color-parens after-paren))
 554                              (format nil "~A</span>~C</span>~A"
 555                                      before-paren
 556                                      paren (color-parens after-paren))))
 557                        s))))
 558         (color-parens s))))
 559    ((:symbol :escaped-symbol)
 560     (lambda (type s)
 561       (declare (ignore type))
 562       (let* ((colon (position #\: s :from-end t))
 563              (new-s (or (and colon (subseq s (1+ colon))) s)))
 564         (cond
 565           ((or
 566             (member new-s *common-macros* :test #'string-equal)
 567             (member new-s *special-forms* :test #'string-equal)
 568             (some #'(lambda (e)
 569                       (and (> (length new-s) (length e))
 570                            (string-equal e (subseq new-s 0 (length e)))))
 571                   '("WITH-" "DEF")))
 572            (format nil "<i><span class=\"symbol\">~A</span></i>" s))
 573           ((and (> (length new-s) 2)
 574                 (char= (elt new-s 0) #\*)
 575                 (char= (elt new-s (1- (length new-s))) #\*))
 576            (format nil "<span class=\"special\">~A</span>" s))
 577           (t s)))))
 578    (:keyword (lambda (type s)
 579       (declare (ignore type))
 580                (format nil "<span class=\"keyword\">~A</span>"
 581                        s)))
 582    ((:comment :multiline)
 583     (lambda (type s)
 584       (declare (ignore type))
 585       (format nil "<span class=\"comment\">~A</span>"
 586               s)))
 587    ((:character)
 588     (lambda (type s)
 589       (declare (ignore type))
 590       (format nil "<span class=\"character\">~A</span>"
 591               s)))
 592    ((:string)
 593     (lambda (type s)
 594       (declare (ignore type))
 595       (format nil "<span class=\"string\">~A</span>"
 596               s)))
 597    ((:single-escaped)
 598     (lambda (type s)
 599       (call-formatter (cdr type) s)))
 600    ((:syntax-error)
 601     (lambda (type s)
 602       (declare (ignore type))
 603       (format nil "<span class=\"syntaxerror\">~A</span>"
 604               s)))))
 605
 606 (define-coloring-type :scheme "Scheme"
 607   :autodetect (lambda (text)
 608                 (or
 609                  (search "scheme" text :test #'char-equal)
 610                  (search "chicken" text :test #'char-equal)))
 611   :parent :lisp
 612   :transitions
 613   (((:normal :in-list)
 614     ((scan "...")
 615      (set-mode :symbol
 616                :until (scan-any *non-constituent*)
 617                :advancing nil))
 618     ((scan #\[)
 619      (set-mode :in-list
 620                :until (scan #\])))))
 621   :formatters
 622   (((:in-list)
 623     (lambda (type s)
 624       (declare (ignore type s))
 625       (let ((*open-parens* (cons #\[ *open-parens*))
 626             (*close-parens* (cons #\] *close-parens*)))
 627         (call-parent-formatter))))
 628    ((:symbol :escaped-symbol)
 629     (lambda (type s)
 630       (declare (ignore type))
 631       (let ((result (if (find-package :r5rs-lookup)
 632                          (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup))
 633                                   s))))
 634         (if result
 635             (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
 636                     result (call-parent-formatter))
 637             (call-parent-formatter)))))))
 638
 639 (define-coloring-type :elisp "Emacs Lisp"
 640   :autodetect (lambda (name)
 641                 (member name '("emacs")
 642                         :test #'(lambda (name ext)
 643                                   (search ext name :test #'char-equal))))
 644   :parent :lisp
 645   :formatters
 646   (((:symbol :escaped-symbol)
 647     (lambda (type s)
 648       (declare (ignore type))
 649       (let ((result (if (find-package :elisp-lookup)
 650                          (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup))
 651                                   s))))
 652         (if result
 653             (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
 654                     result (call-parent-formatter))
 655             (call-parent-formatter)))))))
 656
 657 (define-coloring-type :common-lisp "Common Lisp"
 658   :autodetect (lambda (text)
 659                 (search "lisp" text :test #'char-equal))
 660   :parent :lisp
 661   :transitions
 662   (((:normal :in-list)
 663     ((scan #\|)
 664      (set-mode :escaped-symbol
 665                :until (scan #\|)))))
 666   :formatters
 667   (((:symbol :escaped-symbol)
 668     (lambda (type s)
 669       (declare (ignore type))
 670       (let* ((colon (position #\: s :from-end t :test #'char=))
 671              (to-lookup (if colon (subseq s (1+ colon)) s))
 672              (result (if (find-package :clhs-lookup)
 673                          (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup))
 674                                   to-lookup))))
 675         (if result
 676             (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
 677                     result (call-parent-formatter))
 678             (call-parent-formatter)))))))
 679
 680 (define-coloring-type :common-lisp-file "Common Lisp File"
 681   :parent :common-lisp
 682   :default-mode :in-list
 683   :invisible t)
 684
 685 (defvar *c-open-parens* "([{")
 686 (defvar *c-close-parens* ")]}")
 687
 688 (defvar *c-reserved-words*
 689   '("auto"   "break"  "case"   "char"   "const"
 690     "continue" "default" "do"     "double" "else"
 691     "enum"   "extern" "float"  "for"    "goto"
 692     "if"     "int"    "long"   "register" "return"
 693     "short"  "signed" "sizeof" "static" "struct"
 694     "switch" "typedef" "union"  "unsigned" "void"
 695     "volatile" "while"  "__restrict" "_Bool"))
 696
 697 (defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
 698 (defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#))
 699
 700 (define-coloring-type :basic-c "Basic C"
 701   :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor)
 702   :default-mode :normal
 703   :invisible t
 704   :transitions
 705   ((:normal
 706     ((scan-any *c-begin-word*)
 707      (set-mode :word-ish
 708                :until (scan-any *c-terminators*)
 709                :advancing nil))
 710     ((scan "/*")
 711      (set-mode :comment
 712                :until (scan "*/")))
 713
 714     ((or
 715       (scan-any *c-open-parens*)
 716       (scan-any *c-close-parens*))
 717      (set-mode :paren-ish
 718                :until (advance 1)
 719                :advancing nil))
 720     ((scan #\")
 721      (set-mode :string
 722                :until (scan #\")))
 723     ((or (scan "'\\")
 724          (scan #\'))
 725      (set-mode :character
 726                :until (advance 2))))
 727    (:string
 728     ((scan #\\)
 729      (set-mode :single-escape
 730                :until (advance 1)))))
 731   :formatter-variables
 732   ((paren-counter 0))
 733   :formatter-after-hook (lambda nil
 734                           (format nil "~{~A~}"
 735                                   (loop for i from paren-counter downto 1
 736                                         collect "</span></span>")))
 737   :formatters
 738   ((:normal
 739     (lambda (type s)
 740       (declare (ignore type))
 741       s))
 742    (:comment
 743     (lambda (type s)
 744       (declare (ignore type))
 745       (format nil "<span class=\"comment\">~A</span>"
 746               s)))
 747    (:string
 748     (lambda (type s)
 749       (declare (ignore type))
 750       (format nil "<span class=\"string\">~A</span>"
 751               s)))
 752    (:character
 753     (lambda (type s)
 754       (declare (ignore type))
 755       (format nil "<span class=\"character\">~A</span>"
 756               s)))
 757    (:single-escape
 758     (lambda (type s)
 759       (call-formatter (cdr type) s)))
 760    (:paren-ish
 761     (lambda (type s)
 762       (declare (ignore type))
 763       (let ((open nil)
 764             (count 0))
 765         (if (eql (length s) 1)
 766             (progn
 767               (when (member (elt s 0) (coerce *c-open-parens* 'list))
 768                 (setf open t)
 769                 (setf count (mod paren-counter 6))
 770                 (incf paren-counter))
 771               (when (member (elt s 0) (coerce *c-close-parens* 'list))
 772                 (setf open nil)
 773                 (decf paren-counter)
 774                 (setf count (mod paren-counter 6)))
 775               (if open
 776                   (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
 777                           (1+ count) s *css-background-class*)
 778                   (format nil "</span>~A</span>"
 779                           s)))
 780             s))))
 781    (:word-ish
 782     (lambda (type s)
 783       (declare (ignore type))
 784       (if (member s *c-reserved-words* :test #'string=)
 785           (format nil "<span class=\"symbol\">~A</span>" s)
 786           s)))
 787    ))
 788
 789 (define-coloring-type :c "C"
 790   :parent :basic-c
 791   :transitions
 792   ((:normal
 793     ((scan #\#)
 794      (set-mode :preprocessor
 795                :until (scan-any '(#\return #\newline))))))
 796   :formatters
 797   ((:preprocessor
 798     (lambda (type s)
 799       (declare (ignore type))
 800       (format nil "<span class=\"special\">~A</span>" s)))))
 801
 802 (defvar *c++-reserved-words*
 803   '("asm"          "auto"      "bool"     "break"            "case"
 804     "catch"        "char"      "class"    "const"            "const_cast"
 805     "continue"     "default"   "delete"   "do"               "double"
 806     "dynamic_cast" "else"      "enum"     "explicit"         "export"
 807     "extern"       "false"     "float"    "for"              "friend"
 808     "goto"         "if"        "inline"   "int"              "long"
 809     "mutable"      "namespace" "new"      "operator"         "private"
 810     "protected"    "public"    "register" "reinterpret_cast" "return"
 811     "short"        "signed"    "sizeof"   "static"           "static_cast"
 812     "struct"       "switch"    "template" "this"             "throw"
 813     "true"         "try"       "typedef"  "typeid"           "typename"
 814     "union"        "unsigned"  "using"    "virtual"          "void"
 815     "volatile"     "wchar_t"   "while"))
 816
 817 (define-coloring-type :c++ "C++"
 818   :parent :c
 819   :transitions
 820   ((:normal
 821     ((scan "//")
 822      (set-mode :comment
 823                :until (scan-any '(#\return #\newline))))))
 824   :formatters
 825   ((:word-ish
 826     (lambda (type s)
 827       (declare (ignore type))
 828       (if (member s *c++-reserved-words* :test #'string=)
 829           (format nil "<span class=\"symbol\">~A</span>"
 830                   s)
 831           s)))))
 832
 833 (defvar *java-reserved-words*
 834   '("abstract"     "boolean"      "break"    "byte"         "case"
 835     "catch"        "char"         "class"   "const"        "continue"
 836     "default"      "do"           "double"   "else"         "extends"
 837     "final"        "finally"      "float"    "for"          "goto"
 838     "if"           "implements"   "import"   "instanceof"   "int"
 839     "interface"    "long"         "native"   "new"          "package"
 840     "private"      "protected"    "public"   "return"       "short"
 841     "static"       "strictfp"     "super"    "switch"       "synchronized"
 842     "this"         "throw"        "throws"   "transient"    "try"
 843     "void"         "volatile"     "while"))
 844
 845 (define-coloring-type :java "Java"
 846   :parent :c++
 847   :formatters
 848   ((:word-ish
 849     (lambda (type s)
 850       (declare (ignore type))
 851       (if (member s *java-reserved-words* :test #'string=)
 852           (format nil "<span class=\"symbol\">~A</span>"
 853                   s)
 854           s)))))
 855
 856 (let ((terminate-next nil))
 857   (define-coloring-type :objective-c "Objective C"
 858     :autodetect (lambda (text) (search "mac" text :test #'char=))
 859     :modes (:begin-message-send :end-message-send)
 860     :transitions
 861     ((:normal
 862       ((scan #\[)
 863        (set-mode :begin-message-send
 864        :until (advance 1)
 865        :advancing nil))
 866       ((scan #\])
 867        (set-mode :end-message-send
 868        :until (advance 1)
 869        :advancing nil))
 870       ((scan-any *c-begin-word*)
 871        (set-mode :word-ish
 872        :until (or
 873           (and (peek-any '(#\:))
 874                (setf terminate-next t))
 875           (and terminate-next (progn
 876                       (setf terminate-next nil)
 877                       (advance 1)))
 878           (scan-any *c-terminators*))
 879        :advancing nil)))
 880      (:word-ish
 881       #+nil
 882       ((scan #\:)
 883        (format t "hi~%")
 884        (set-mode :word-ish :until (advance 1) :advancing nil)
 885        (setf terminate-next t))))
 886   :parent :c++
 887   :formatter-variables ((is-keyword nil) (in-message-send nil))
 888   :formatters
 889   ((:begin-message-send
 890     (lambda (type s)
 891       (setf is-keyword nil)
 892       (setf in-message-send t)
 893       (call-formatter (cons :paren-ish type) s)))
 894    (:end-message-send
 895     (lambda (type s)
 896       (setf is-keyword nil)
 897       (setf in-message-send nil)
 898       (call-formatter (cons :paren-ish type) s)))
 899    (:word-ish
 900     (lambda (type s)
 901       (declare (ignore type))
 902       (prog1
 903      (let ((result (if (find-package :cocoa-lookup)
 904              (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
 905                  s))))
 906        (if result
 907       (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
 908          result s)
 909       (if (member s *c-reserved-words* :test #'string=)
 910           (format nil "<span class=\"symbol\">~A</span>" s)
 911           (if in-message-send
 912          (if is-keyword
 913              (format nil "<span class=\"keyword\">~A</span>" s)
 914              s)
 915          s))))
 916    (setf is-keyword (not is-keyword))))))))
 917
 918
 919 ;#!/usr/bin/clisp
 920 ;#+sbcl
 921 ;(require :asdf)
 922 ;(asdf:oos 'asdf:load-op :colorize)
 923
 924 (defmacro with-each-stream-line ((var stream) &body body)
 925   (let ((eof (gensym))
 926     (eof-value (gensym))
 927     (strm (gensym)))
 928     `(let ((,strm ,stream)
 929        (,eof ',eof-value))
 930       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
 931       ((eql ,var ,eof))
 932     ,@body))))
 933
 934 (defun system (control-string &rest args)
 935   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 936 synchronously execute the result using a Bourne-compatible shell, with
 937 output to *verbose-out*.  Returns the shell's exit code."
 938   (let ((command (apply #'format nil control-string args)))
 939     (format t "; $ ~A~%" command)
 940     #+sbcl
 941     (sb-impl::process-exit-code
 942      (sb-ext:run-program
 943       "/bin/sh"
 944       (list  "-c" command)
 945       :input nil :output *standard-output*))
 946     #+(or cmu scl)
 947     (ext:process-exit-code
 948      (ext:run-program
 949       "/bin/sh"
 950       (list  "-c" command)
 951       :input nil :output *verbose-out*))
 952     #+clisp             ;XXX not exactly *verbose-out*, I know
 953     (ext:run-shell-command  command :output :terminal :wait t)
 954     ))
 955
 956 (defun strcat (&rest strings)
 957   (apply #'concatenate 'string strings))
 958
 959 (defun string-starts-with (start str)
 960   (and (>= (length str) (length start))
 961        (string-equal start str :end2 (length start))))
 962
 963 (defmacro string-append (outputstr &rest args)
 964   `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
 965
 966 (defconstant +indent+ 2
 967   "Indentation used in the examples.")
 968
 969 (defun texinfo->raw-lisp (code)
 970   "Answer CODE with spurious Texinfo output removed.  For use in
 971 preprocessing output in a @lisp block before passing to colorize."
 972   (decode-from-tt
 973    (with-output-to-string (output)
 974      (do* ((last-position 0)
 975            (next-position
 976             #0=(search #1="<span class=\"roman\">" code
 977                        :start2 last-position :test #'char-equal)
 978             #0#))
 979           ((eq nil next-position)
 980            (write-string code output :start last-position))
 981        (write-string code output :start last-position :end next-position)
 982        (let ((end (search #2="</span>" code
 983                           :start2 (+ next-position (length #1#))
 984                           :test #'char-equal)))
 985          (assert (integerp end) ()
 986                  "Missing ~A tag in HTML for @lisp block~%~
 987                   HTML contents of block:~%~A" #2# code)
 988          (write-string code output
 989                        :start (+ next-position (length #1#))
 990                        :end end)
 991          (setf last-position (+ end (length #2#))))))))
 992
 993 (defun process-file (from to)
 994   (with-open-file (output to :direction :output :if-exists :error)
 995     (with-open-file (input from :direction :input)
 996       (let ((line-processor nil)
 997             (piece-of-code '()))
 998         (labels
 999             ((process-line-inside-pre (line)
1000                (cond ((string-starts-with "</pre>" line)
1001                        (with-input-from-string
1002                            (stream (colorize:html-colorization
1003                                     :common-lisp
1004                                     (texinfo->raw-lisp
1005                                      (apply #'concatenate 'string
1006                                             (nreverse piece-of-code)))))
1007                          (with-each-stream-line (cline stream)
1008                            (format output "  ~A~%" cline)))
1009                        (write-line line output)
1010                        (setq piece-of-code '()
1011                              line-processor #'process-regular-line))
1012                      (t (let ((to-append (subseq line +indent+)))
1013                           (push (if (string= "" to-append)
1014                                   " "
1015                                   to-append) piece-of-code)
1016                           (push (string #\Newline) piece-of-code)))))
1017              (process-regular-line (line)
1018                (let ((len (some (lambda (test-string)
1019                                   (when (string-starts-with test-string line)
1020                                     (length test-string)))
1021                                '("<pre class=\"lisp\">"
1022                                  "<pre class=\"smalllisp\">"))))
1023                  (cond (len
1024                          (setq line-processor #'process-line-inside-pre)
1025                          (write-string "<pre class=\"lisp\">" output)
1026                          (push (subseq line (+ len +indent+)) piece-of-code)
1027                          (push (string #\Newline) piece-of-code))
1028                        (t (write-line line output))))))
1029           (setf line-processor #'process-regular-line)
1030           (with-each-stream-line (line input)
1031             (funcall line-processor line)))))))
1032
1033 (defun process-dir (dir)
1034   (dolist (html-file (directory dir))
1035     (let* ((name (namestring html-file))
1036            (temp-name (strcat name ".temp")))
1037       (process-file name temp-name)
1038       (system "mv ~A ~A" temp-name name))))
1039
1040 ;; (go "/tmp/doc/manual/html_node/*.html")
1041
1042 #+clisp
1043 (progn
1044   (assert (first ext:*args*))
1045   (process-dir (first ext:*args*)))
1046
1047 #+sbcl
1048 (progn
1049   (assert (second sb-ext:*posix-argv*))
1050   (process-dir (second sb-ext:*posix-argv*))
1051   (sb-ext:quit))