doc/colorize-lisp-examples.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                #+nil(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     ((or
 714       (scan-any *c-open-parens*)
 715       (scan-any *c-close-parens*))
 716      (set-mode :paren-ish
 717                :until (advance 1)
 718                :advancing nil))
 719     ((scan #\")
 720      (set-mode :string
 721                :until (scan #\")))
 722     ((or (scan "'\\")
 723          (scan #\'))
 724      (set-mode :character
 725                :until (advance 2))))
 726    (:string
 727     ((scan #\\)
 728      (set-mode :single-escape
 729                :until (advance 1)))))
 730   :formatter-variables
 731   ((paren-counter 0))
 732   :formatter-after-hook (lambda nil
 733                           (format nil "~{~A~}"
 734                                   (loop for i from paren-counter downto 1
 735                                         collect "</span></span>")))
 736   :formatters
 737   ((:normal
 738     (lambda (type s)
 739       (declare (ignore type))
 740       s))
 741    (:comment
 742     (lambda (type s)
 743       (declare (ignore type))
 744       (format nil "<span class=\"comment\">~A</span>"
 745               s)))
 746    (:string
 747     (lambda (type s)
 748       (declare (ignore type))
 749       (format nil "<span class=\"string\">~A</span>"
 750               s)))
 751    (:character
 752     (lambda (type s)
 753       (declare (ignore type))
 754       (format nil "<span class=\"character\">~A</span>"
 755               s)))
 756    (:single-escape
 757     (lambda (type s)
 758       (call-formatter (cdr type) s)))
 759    (:paren-ish
 760     (lambda (type s)
 761       (declare (ignore type))
 762       (let ((open nil)
 763             (count 0))
 764         (if (eql (length s) 1)
 765             (progn
 766               (when (member (elt s 0) (coerce *c-open-parens* 'list))
 767                 (setf open t)
 768                 (setf count (mod paren-counter 6))
 769                 (incf paren-counter))
 770               (when (member (elt s 0) (coerce *c-close-parens* 'list))
 771                 (setf open nil)
 772                 (decf paren-counter)
 773                 (setf count (mod paren-counter 6)))
 774               (if open
 775                   (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
 776                           (1+ count) s *css-background-class*)
 777                   (format nil "</span>~A</span>"
 778                           s)))
 779             s))))
 780    (:word-ish
 781     (lambda (type s)
 782       (declare (ignore type))
 783       (if (member s *c-reserved-words* :test #'string=)
 784           (format nil "<span class=\"symbol\">~A</span>" s)
 785           s)))
 786    ))
 787
 788 (define-coloring-type :c "C"
 789   :parent :basic-c
 790   :transitions
 791   ((:normal
 792     ((scan #\#)
 793      (set-mode :preprocessor
 794                :until (scan-any '(#\return #\newline))))))
 795   :formatters
 796   ((:preprocessor
 797     (lambda (type s)
 798       (declare (ignore type))
 799       (format nil "<span class=\"special\">~A</span>" s)))))
 800
 801 (defvar *c++-reserved-words*
 802   '("asm"          "auto"      "bool"     "break"            "case"
 803     "catch"        "char"      "class"    "const"            "const_cast"
 804     "continue"     "default"   "delete"   "do"               "double"
 805     "dynamic_cast" "else"      "enum"     "explicit"         "export"
 806     "extern"       "false"     "float"    "for"              "friend"
 807     "goto"         "if"        "inline"   "int"              "long"
 808     "mutable"      "namespace" "new"      "operator"         "private"
 809     "protected"    "public"    "register" "reinterpret_cast" "return"
 810     "short"        "signed"    "sizeof"   "static"           "static_cast"
 811     "struct"       "switch"    "template" "this"             "throw"
 812     "true"         "try"       "typedef"  "typeid"           "typename"
 813     "union"        "unsigned"  "using"    "virtual"          "void"
 814     "volatile"     "wchar_t"   "while"))
 815
 816 (define-coloring-type :c++ "C++"
 817   :parent :c
 818   :transitions
 819   ((:normal
 820     ((scan "//")
 821      (set-mode :comment
 822                :until (scan-any '(#\return #\newline))))))
 823   :formatters
 824   ((:word-ish
 825     (lambda (type s)
 826       (declare (ignore type))
 827       (if (member s *c++-reserved-words* :test #'string=)
 828           (format nil "<span class=\"symbol\">~A</span>"
 829                   s)
 830           s)))))
 831
 832 (defvar *java-reserved-words*
 833   '("abstract"     "boolean"      "break"    "byte"         "case"
 834     "catch"        "char"         "class"    "const"        "continue"
 835     "default"      "do"           "double"   "else"         "extends"
 836     "final"        "finally"      "float"    "for"          "goto"
 837     "if"           "implements"   "import"   "instanceof"   "int"
 838     "interface"    "long"         "native"   "new"          "package"
 839     "private"      "protected"    "public"   "return"       "short"
 840     "static"       "strictfp"     "super"    "switch"       "synchronized"
 841     "this"         "throw"        "throws"   "transient"    "try"
 842     "void"         "volatile"     "while"))
 843
 844 (define-coloring-type :java "Java"
 845   :parent :c++
 846   :formatters
 847   ((:word-ish
 848     (lambda (type s)
 849       (declare (ignore type))
 850       (if (member s *java-reserved-words* :test #'string=)
 851           (format nil "<span class=\"symbol\">~A</span>"
 852                   s)
 853           s)))))
 854
 855 (let ((terminate-next nil))
 856   (define-coloring-type :objective-c "Objective C"
 857     :autodetect (lambda (text) (search "mac" text :test #'char=))
 858     :modes (:begin-message-send :end-message-send)
 859     :transitions
 860     ((:normal
 861       ((scan #\[)
 862        (set-mode :begin-message-send
 863        :until (advance 1)
 864        :advancing nil))
 865       ((scan #\])
 866        (set-mode :end-message-send
 867        :until (advance 1)
 868        :advancing nil))
 869       ((scan-any *c-begin-word*)
 870        (set-mode :word-ish
 871        :until (or
 872           (and (peek-any '(#\:))
 873                (setf terminate-next t))
 874           (and terminate-next (progn
 875                       (setf terminate-next nil)
 876                       (advance 1)))
 877           (scan-any *c-terminators*))
 878        :advancing nil)))
 879      (:word-ish
 880       #+nil
 881       ((scan #\:)
 882        (format t "hi~%")
 883        (set-mode :word-ish :until (advance 1) :advancing nil)
 884        (setf terminate-next t))))
 885   :parent :c++
 886   :formatter-variables ((is-keyword nil) (in-message-send nil))
 887   :formatters
 888   ((:begin-message-send
 889     (lambda (type s)
 890       (setf is-keyword nil)
 891       (setf in-message-send t)
 892       (call-formatter (cons :paren-ish type) s)))
 893    (:end-message-send
 894     (lambda (type s)
 895       (setf is-keyword nil)
 896       (setf in-message-send nil)
 897       (call-formatter (cons :paren-ish type) s)))
 898    (:word-ish
 899     (lambda (type s)
 900       (declare (ignore type))
 901       (prog1
 902      (let ((result (if (find-package :cocoa-lookup)
 903              (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
 904                  s))))
 905        (if result
 906       (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
 907          result s)
 908       (if (member s *c-reserved-words* :test #'string=)
 909           (format nil "<span class=\"symbol\">~A</span>" s)
 910           (if in-message-send
 911          (if is-keyword
 912              (format nil "<span class=\"keyword\">~A</span>" s)
 913              s)
 914          s))))
 915    (setf is-keyword (not is-keyword))))))))
 916
 917
 918 ;#!/usr/bin/clisp
 919 ;#+sbcl
 920 ;(require :asdf)
 921 ;(asdf:oos 'asdf:load-op :colorize)
 922
 923 (defmacro with-each-stream-line ((var stream) &body body)
 924   (let ((eof (gensym))
 925     (eof-value (gensym))
 926     (strm (gensym)))
 927     `(let ((,strm ,stream)
 928        (,eof ',eof-value))
 929       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
 930       ((eql ,var ,eof))
 931     ,@body))))
 932
 933 (defun system (control-string &rest args)
 934   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 935 synchronously execute the result using a Bourne-compatible shell, with
 936 output to *verbose-out*.  Returns the shell's exit code."
 937   (let ((command (apply #'format nil control-string args)))
 938     (format t "; $ ~A~%" command)
 939     #+sbcl
 940     (sb-impl::process-exit-code
 941      (sb-ext:run-program
 942       "/bin/sh"
 943       (list  "-c" command)
 944       :input nil :output *standard-output*))
 945     #+(or cmu scl)
 946     (ext:process-exit-code
 947      (ext:run-program
 948       "/bin/sh"
 949       (list  "-c" command)
 950       :input nil :output *verbose-out*))
 951     #+clisp             ;XXX not exactly *verbose-out*, I know
 952     (ext:run-shell-command  command :output :terminal :wait t)
 953     ))
 954
 955 (defun strcat (&rest strings)
 956   (apply #'concatenate 'string strings))
 957
 958 (defun string-starts-with (start str)
 959   (and (>= (length str) (length start))
 960        (string-equal start str :end2 (length start))))
 961
 962 (defmacro string-append (outputstr &rest args)
 963   `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
 964
 965 (defconstant +indent+ 2
 966   "Indentation used in the examples.")
 967
 968 (defun texinfo->raw-lisp (code)
 969   "Answer CODE with spurious Texinfo output removed.  For use in
 970 preprocessing output in a @lisp block before passing to colorize."
 971   (decode-from-tt
 972    (with-output-to-string (output)
 973      (do* ((last-position 0)
 974            (next-position
 975             #0=(search #1="<span class=\"roman\">" code
 976                        :start2 last-position :test #'char-equal)
 977             #0#))
 978           ((eq nil next-position)
 979            (write-string code output :start last-position))
 980        (write-string code output :start last-position :end next-position)
 981        (let ((end (search #2="</span>" code
 982                           :start2 (+ next-position (length #1#))
 983                           :test #'char-equal)))
 984          (assert (integerp end) ()
 985                  "Missing ~A tag in HTML for @lisp block~%~
 986                   HTML contents of block:~%~A" #2# code)
 987          (write-string code output
 988                        :start (+ next-position (length #1#))
 989                        :end end)
 990          (setf last-position (+ end (length #2#))))))))
 991
 992 (defun process-file (from to)
 993   (with-open-file (output to :direction :output :if-exists :supersede)
 994     (with-open-file (input from :direction :input)
 995       (let ((line-processor nil)
 996             (piece-of-code '()))
 997         (labels
 998             ((process-line-inside-pre (line)
 999                (cond ((string-starts-with "</pre>" line)
1000                        (with-input-from-string
1001                            (stream (colorize:html-colorization
1002                                     :common-lisp
1003                                     (texinfo->raw-lisp
1004                                      (apply #'concatenate 'string
1005                                             (nreverse piece-of-code)))))
1006                          (with-each-stream-line (cline stream)
1007                            (format output "  ~A~%" cline)))
1008                        (write-line line output)
1009                        (setq piece-of-code '()
1010                              line-processor #'process-regular-line))
1011                      (t (let ((to-append (subseq line +indent+)))
1012                           (push (if (string= "" to-append)
1013                                   " "
1014                                   to-append) piece-of-code)
1015                           (push (string #\Newline) piece-of-code)))))
1016              (process-regular-line (line)
1017                (let ((len (some (lambda (test-string)
1018                                   (when (string-starts-with test-string line)
1019                                     (length test-string)))
1020                                '("<pre class=\"lisp\">"
1021                                  "<pre class=\"smalllisp\">"))))
1022                  (cond (len
1023                          #+nil(format t "processing ~A~%" line)
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 (make-pathname :directory (pathname-directory dir)
1035                                                :type "html"
1036                                                :name :wild)))
1037     (let* ((name (namestring html-file))
1038            (temp-name (strcat name ".temp")))
1039       (format t "processing ~A~%" name)
1040       (process-file name temp-name)
1041       (system "mv ~A ~A" temp-name name))))
1042
1043 ;; (go "/tmp/doc/manual/html_node/*.html")
1044
1045 #+clisp
1046 (progn
1047   (assert (first ext:*args*))
1048   (process-dir (first ext:*args*)))
1049
1050 #+sbcl
1051 (progn
1052   (assert (second sb-ext:*posix-argv*))
1053   (process-dir (second sb-ext:*posix-argv*))
1054   (sb-ext:quit))