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                (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                  ((#\") (write-string "&quot;" out))
 353                  ((#\RIGHTWARDS_DOUBLE_ARROW) (write-string "&rArr;" out))
 354                  (t (write-char char out)))))
 355     (coerce output 'simple-string)))
 356
 357 (defun string-substitute (string substring replacement-string)
 358   "String substitute by Larry Hunter. Obtained from Google"
 359   (let ((substring-length (length substring))
 360     (last-end 0)
 361     (new-string ""))
 362     (do ((next-start
 363       (search substring string)
 364       (search substring string :start2 last-end)))
 365     ((null next-start)
 366      (concatenate 'string new-string (subseq string last-end)))
 367       (setq new-string
 368     (concatenate 'string
 369       new-string
 370       (subseq string last-end next-start)
 371       replacement-string))
 372       (setq last-end (+ next-start substring-length)))))
 373
 374 (defun decode-from-tt (string)
 375   (string-substitute
 376    (string-substitute
 377     (string-substitute
 378      (string-substitute
 379       (string-substitute string "&amp;" "&")
 380       "&lt;" "<")
 381      "&gt;" ">")
 382     "&rArr;" (string #\RIGHTWARDS_DOUBLE_ARROW))
 383    "&quot;" "\""))
 384
 385 (defun html-colorization (coloring-type string)
 386   (format-scan coloring-type
 387                (mapcar #'(lambda (p)
 388                            (cons (car p)
 389                                  (let ((tt (encode-for-pre (cdr p))))
 390                                    (if (and (> (length tt) 0)
 391                                             (char= (elt tt (1- (length tt))) #\>))
 392                                        (format nil "~A~%" tt) tt))))
 393                        (scan-string coloring-type string))))
 394
 395 (defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default"))
 396   (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
 397                          (merge-pathnames input-file-name)
 398                          (make-pathname :type "lisp"
 399                                         :defaults (merge-pathnames input-file-name))))
 400          (*css-background-class* css-background))
 401     (with-open-file (s input-file :direction :input)
 402       (let ((lines nil)
 403             (string nil))
 404         (block done
 405           (loop (let ((line (read-line s nil nil)))
 406                   (if line
 407                       (push line lines)
 408                       (return-from done)))))
 409         (setf string (format nil "~{~A~%~}"
 410                              (nreverse lines)))
 411         (if wrap
 412             (format s2
 413                     "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">
 414 <html><head><style type=\"text/css\">~A~%~A</style><body>
 415 <table width=\"100%\"><tr><td class=\"~A\">
 416 <tt>~A</tt>
 417 </tr></td></table></body></html>"
 418                     *coloring-css*
 419                     (make-background-css "white")
 420                     *css-background-class*
 421                     (html-colorization coloring-type string))
 422             (write-string (html-colorization coloring-type string) s2))))))
 423
 424 (defun colorize-file (coloring-type input-file-name &optional output-file-name)
 425   (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
 426                          (merge-pathnames input-file-name)
 427                          (make-pathname :type "lisp"
 428                                         :defaults (merge-pathnames input-file-name))))
 429          (output-file (or output-file-name
 430                           (make-pathname :type "html"
 431                                          :defaults input-file))))
 432     (with-open-file (s2 output-file :direction :output :if-exists :supersede)
 433       (colorize-file-to-stream coloring-type input-file-name s2))))
 434
 435 ;; coloring-types.lisp
 436
 437 ;(in-package :colorize)
 438
 439 (eval-when (:compile-toplevel :load-toplevel :execute)
 440   (defparameter *version-token* (gensym)))
 441
 442 (defparameter *symbol-characters*
 443   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890")
 444
 445 (defparameter *non-constituent*
 446   '(#\space #\tab #\newline #\linefeed #\page #\return
 447     #\" #\' #\( #\) #\, #\; #\` #\[ #\]))
 448
 449 (defparameter *special-forms*
 450   '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the"
 451     "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*"
 452     "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally"
 453     "return-from" "setq" "multiple-value-call"))
 454
 455 (defparameter *common-macros*
 456   '("loop" "cond" "lambda"))
 457
 458 (defparameter *open-parens* '(#\())
 459 (defparameter *close-parens* '(#\)))
 460
 461 (define-coloring-type :lisp "Basic Lisp"
 462   :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment
 463                   :multiline :character
 464                   :single-escaped :in-list :syntax-error)
 465   :default-mode :first-char-on-line
 466   :transitions
 467   (((:in-list)
 468     ((or
 469       (scan-any *symbol-characters*)
 470       (and (scan #\.) (scan-any *symbol-characters*))
 471       (and (scan #\\) (advance 1)))
 472      (set-mode :symbol
 473                :until (scan-any *non-constituent*)
 474                :advancing nil))
 475     ((or (scan #\:) (scan "#:"))
 476      (set-mode :keyword
 477                :until (scan-any *non-constituent*)
 478                :advancing nil))
 479     ((scan "#\\")
 480      (let ((count 0))
 481        (set-mode :character
 482                  :until (progn
 483                           (incf count)
 484                           (if (> count 1)
 485                               (scan-any *non-constituent*)))
 486                  :advancing nil)))
 487     ((scan #\")
 488      (set-mode :string
 489                :until (scan #\")))
 490     ((scan #\;)
 491      (set-mode :comment
 492                :until (scan #\newline)))
 493     ((scan "#|")
 494      (set-mode :multiline
 495                :until (scan "|#")))
 496     ((scan #\()
 497      (set-mode :in-list
 498                :until (scan #\)))))
 499    ((:normal :first-char-on-line)
 500     ((scan #\()
 501      (set-mode :in-list
 502                :until (scan #\)))))
 503    (:first-char-on-line
 504     ((scan #\;)
 505      (set-mode :comment
 506                :until (scan #\newline)))
 507     ((scan "#|")
 508      (set-mode :multiline
 509                :until (scan "|#")))
 510     ((advance 1)
 511      (set-mode :normal
 512                :until (scan #\newline))))
 513    (:multiline
 514     ((scan "#|")
 515      (set-mode :multiline
 516                :until (scan "|#"))))
 517    ((:symbol :keyword :escaped-symbol :string)
 518     ((scan #\\)
 519      (let ((count 0))
 520        (set-mode :single-escaped
 521                  :until (progn
 522                           (incf count)
 523                           (if (< count 2)
 524                               (advance 1))))))))
 525   :formatter-variables ((paren-counter 0))
 526   :formatter-after-hook (lambda nil
 527                           (format nil "~{~A~}"
 528                                   (loop for i from paren-counter downto 1
 529                                         collect "</span></span>")))
 530   :formatters
 531   (((:normal :first-char-on-line)
 532     (lambda (type s)
 533       (declare (ignore type))
 534       s))
 535    ((:in-list)
 536     (lambda (type s)
 537       (declare (ignore type))
 538       (labels ((color-parens (s)
 539                  (let ((paren-pos (find-if-not #'null
 540                                                (mapcar #'(lambda (c)
 541                                                            (position c s))
 542                                                        (append *open-parens*
 543                                                                *close-parens*)))))
 544                    (if paren-pos
 545                        (let ((before-paren (subseq s 0 paren-pos))
 546                              (after-paren (subseq s (1+ paren-pos)))
 547                              (paren (elt s paren-pos))
 548                              (open nil)
 549                              (count 0))
 550                          (when (member paren *open-parens* :test #'char=)
 551                            (setf count (mod paren-counter 6))
 552                            (incf paren-counter)
 553                            (setf open t))
 554                          (when (member paren *close-parens* :test #'char=)
 555                            (decf paren-counter))
 556                          (if open
 557                              (format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
 558                                      before-paren
 559                                      (1+ count)
 560                                      paren *css-background-class*
 561                                      (color-parens after-paren))
 562                              (format nil "~A</span>~C</span>~A"
 563                                      before-paren
 564                                      paren (color-parens after-paren))))
 565                        s))))
 566         (color-parens s))))
 567    ((:symbol :escaped-symbol)
 568     (lambda (type s)
 569       (declare (ignore type))
 570       (let* ((colon (position #\: s :from-end t))
 571              (new-s (or (and colon (subseq s (1+ colon))) s)))
 572         (cond
 573           ((or
 574             (member new-s *common-macros* :test #'string-equal)
 575             (member new-s *special-forms* :test #'string-equal)
 576             (some #'(lambda (e)
 577                       (and (> (length new-s) (length e))
 578                            (string-equal e (subseq new-s 0 (length e)))))
 579                   '("WITH-" "DEF")))
 580            (format nil "<i><span class=\"symbol\">~A</span></i>" s))
 581           ((and (> (length new-s) 2)
 582                 (char= (elt new-s 0) #\*)
 583                 (char= (elt new-s (1- (length new-s))) #\*))
 584            (format nil "<span class=\"special\">~A</span>" s))
 585           (t s)))))
 586    (:keyword (lambda (type s)
 587       (declare (ignore type))
 588                (format nil "<span class=\"keyword\">~A</span>"
 589                        s)))
 590    ((:comment :multiline)
 591     (lambda (type s)
 592       (declare (ignore type))
 593       (format nil "<span class=\"comment\">~A</span>"
 594               s)))
 595    ((:character)
 596     (lambda (type s)
 597       (declare (ignore type))
 598       (format nil "<span class=\"character\">~A</span>"
 599               s)))
 600    ((:string)
 601     (lambda (type s)
 602       (declare (ignore type))
 603       (format nil "<span class=\"string\">~A</span>"
 604               s)))
 605    ((:single-escaped)
 606     (lambda (type s)
 607       (call-formatter (cdr type) s)))
 608    ((:syntax-error)
 609     (lambda (type s)
 610       (declare (ignore type))
 611       (format nil "<span class=\"syntaxerror\">~A</span>"
 612               s)))))
 613
 614 (define-coloring-type :scheme "Scheme"
 615   :autodetect (lambda (text)
 616                 (or
 617                  (search "scheme" text :test #'char-equal)
 618                  (search "chicken" text :test #'char-equal)))
 619   :parent :lisp
 620   :transitions
 621   (((:normal :in-list)
 622     ((scan "...")
 623      (set-mode :symbol
 624                :until (scan-any *non-constituent*)
 625                :advancing nil))
 626     ((scan #\[)
 627      (set-mode :in-list
 628                :until (scan #\])))))
 629   :formatters
 630   (((:in-list)
 631     (lambda (type s)
 632       (declare (ignore type s))
 633       (let ((*open-parens* (cons #\[ *open-parens*))
 634             (*close-parens* (cons #\] *close-parens*)))
 635         (call-parent-formatter))))
 636    ((:symbol :escaped-symbol)
 637     (lambda (type s)
 638       (declare (ignore type))
 639       (let ((result (if (find-package :r5rs-lookup)
 640                          (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup))
 641                                   s))))
 642         (if result
 643             (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
 644                     result (call-parent-formatter))
 645             (call-parent-formatter)))))))
 646
 647 (define-coloring-type :elisp "Emacs Lisp"
 648   :autodetect (lambda (name)
 649                 (member name '("emacs")
 650                         :test #'(lambda (name ext)
 651                                   (search ext name :test #'char-equal))))
 652   :parent :lisp
 653   :formatters
 654   (((:symbol :escaped-symbol)
 655     (lambda (type s)
 656       (declare (ignore type))
 657       (let ((result (if (find-package :elisp-lookup)
 658                          (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup))
 659                                   s))))
 660         (if result
 661             (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
 662                     result (call-parent-formatter))
 663             (call-parent-formatter)))))))
 664
 665 (define-coloring-type :common-lisp "Common Lisp"
 666   :autodetect (lambda (text)
 667                 (search "lisp" text :test #'char-equal))
 668   :parent :lisp
 669   :transitions
 670   (((:normal :in-list)
 671     ((scan #\|)
 672      (set-mode :escaped-symbol
 673                :until (scan #\|)))))
 674   :formatters
 675   (((:symbol :escaped-symbol)
 676     (lambda (type s)
 677       (declare (ignore type))
 678       (let* ((colon (position #\: s :from-end t :test #'char=))
 679              (to-lookup (if colon (subseq s (1+ colon)) s))
 680              (result (if (find-package :clhs-lookup)
 681                          (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup))
 682                                   to-lookup))))
 683         (if result
 684             (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
 685                     result (call-parent-formatter))
 686             (call-parent-formatter)))))))
 687
 688 (define-coloring-type :common-lisp-file "Common Lisp File"
 689   :parent :common-lisp
 690   :default-mode :in-list
 691   :invisible t)
 692
 693 (defvar *c-open-parens* "([{")
 694 (defvar *c-close-parens* ")]}")
 695
 696 (defvar *c-reserved-words*
 697   '("auto"   "break"  "case"   "char"   "const"
 698     "continue" "default" "do"     "double" "else"
 699     "enum"   "extern" "float"  "for"    "goto"
 700     "if"     "int"    "long"   "register" "return"
 701     "short"  "signed" "sizeof" "static" "struct"
 702     "switch" "typedef" "union"  "unsigned" "void"
 703     "volatile" "while"  "__restrict" "_Bool"))
 704
 705 (defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
 706 (defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#))
 707
 708 (define-coloring-type :basic-c "Basic C"
 709   :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor)
 710   :default-mode :normal
 711   :invisible t
 712   :transitions
 713   ((:normal
 714     ((scan-any *c-begin-word*)
 715      (set-mode :word-ish
 716                :until (scan-any *c-terminators*)
 717                :advancing nil))
 718     ((scan "/*")
 719      (set-mode :comment
 720                :until (scan "*/")))
 721     ((or
 722       (scan-any *c-open-parens*)
 723       (scan-any *c-close-parens*))
 724      (set-mode :paren-ish
 725                :until (advance 1)
 726                :advancing nil))
 727     ((scan #\")
 728      (set-mode :string
 729                :until (scan #\")))
 730     ((or (scan "'\\")
 731          (scan #\'))
 732      (set-mode :character
 733                :until (advance 2))))
 734    (:string
 735     ((scan #\\)
 736      (set-mode :single-escape
 737                :until (advance 1)))))
 738   :formatter-variables
 739   ((paren-counter 0))
 740   :formatter-after-hook (lambda nil
 741                           (format nil "~{~A~}"
 742                                   (loop for i from paren-counter downto 1
 743                                         collect "</span></span>")))
 744   :formatters
 745   ((:normal
 746     (lambda (type s)
 747       (declare (ignore type))
 748       s))
 749    (:comment
 750     (lambda (type s)
 751       (declare (ignore type))
 752       (format nil "<span class=\"comment\">~A</span>"
 753               s)))
 754    (:string
 755     (lambda (type s)
 756       (declare (ignore type))
 757       (format nil "<span class=\"string\">~A</span>"
 758               s)))
 759    (:character
 760     (lambda (type s)
 761       (declare (ignore type))
 762       (format nil "<span class=\"character\">~A</span>"
 763               s)))
 764    (:single-escape
 765     (lambda (type s)
 766       (call-formatter (cdr type) s)))
 767    (:paren-ish
 768     (lambda (type s)
 769       (declare (ignore type))
 770       (let ((open nil)
 771             (count 0))
 772         (if (eql (length s) 1)
 773             (progn
 774               (when (member (elt s 0) (coerce *c-open-parens* 'list))
 775                 (setf open t)
 776                 (setf count (mod paren-counter 6))
 777                 (incf paren-counter))
 778               (when (member (elt s 0) (coerce *c-close-parens* 'list))
 779                 (setf open nil)
 780                 (decf paren-counter)
 781                 (setf count (mod paren-counter 6)))
 782               (if open
 783                   (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
 784                           (1+ count) s *css-background-class*)
 785                   (format nil "</span>~A</span>"
 786                           s)))
 787             s))))
 788    (:word-ish
 789     (lambda (type s)
 790       (declare (ignore type))
 791       (if (member s *c-reserved-words* :test #'string=)
 792           (format nil "<span class=\"symbol\">~A</span>" s)
 793           s)))
 794    ))
 795
 796 (define-coloring-type :c "C"
 797   :parent :basic-c
 798   :transitions
 799   ((:normal
 800     ((scan #\#)
 801      (set-mode :preprocessor
 802                :until (scan-any '(#\return #\newline))))))
 803   :formatters
 804   ((:preprocessor
 805     (lambda (type s)
 806       (declare (ignore type))
 807       (format nil "<span class=\"special\">~A</span>" s)))))
 808
 809 (defvar *c++-reserved-words*
 810   '("asm"          "auto"      "bool"     "break"            "case"
 811     "catch"        "char"      "class"    "const"            "const_cast"
 812     "continue"     "default"   "delete"   "do"               "double"
 813     "dynamic_cast" "else"      "enum"     "explicit"         "export"
 814     "extern"       "false"     "float"    "for"              "friend"
 815     "goto"         "if"        "inline"   "int"              "long"
 816     "mutable"      "namespace" "new"      "operator"         "private"
 817     "protected"    "public"    "register" "reinterpret_cast" "return"
 818     "short"        "signed"    "sizeof"   "static"           "static_cast"
 819     "struct"       "switch"    "template" "this"             "throw"
 820     "true"         "try"       "typedef"  "typeid"           "typename"
 821     "union"        "unsigned"  "using"    "virtual"          "void"
 822     "volatile"     "wchar_t"   "while"))
 823
 824 (define-coloring-type :c++ "C++"
 825   :parent :c
 826   :transitions
 827   ((:normal
 828     ((scan "//")
 829      (set-mode :comment
 830                :until (scan-any '(#\return #\newline))))))
 831   :formatters
 832   ((:word-ish
 833     (lambda (type s)
 834       (declare (ignore type))
 835       (if (member s *c++-reserved-words* :test #'string=)
 836           (format nil "<span class=\"symbol\">~A</span>"
 837                   s)
 838           s)))))
 839
 840 (defvar *java-reserved-words*
 841   '("abstract"     "boolean"      "break"    "byte"         "case"
 842     "catch"        "char"         "class"    "const"        "continue"
 843     "default"      "do"           "double"   "else"         "extends"
 844     "final"        "finally"      "float"    "for"          "goto"
 845     "if"           "implements"   "import"   "instanceof"   "int"
 846     "interface"    "long"         "native"   "new"          "package"
 847     "private"      "protected"    "public"   "return"       "short"
 848     "static"       "strictfp"     "super"    "switch"       "synchronized"
 849     "this"         "throw"        "throws"   "transient"    "try"
 850     "void"         "volatile"     "while"))
 851
 852 (define-coloring-type :java "Java"
 853   :parent :c++
 854   :formatters
 855   ((:word-ish
 856     (lambda (type s)
 857       (declare (ignore type))
 858       (if (member s *java-reserved-words* :test #'string=)
 859           (format nil "<span class=\"symbol\">~A</span>"
 860                   s)
 861           s)))))
 862
 863 (let ((terminate-next nil))
 864   (define-coloring-type :objective-c "Objective C"
 865     :autodetect (lambda (text) (search "mac" text :test #'char=))
 866     :modes (:begin-message-send :end-message-send)
 867     :transitions
 868     ((:normal
 869       ((scan #\[)
 870        (set-mode :begin-message-send
 871        :until (advance 1)
 872        :advancing nil))
 873       ((scan #\])
 874        (set-mode :end-message-send
 875        :until (advance 1)
 876        :advancing nil))
 877       ((scan-any *c-begin-word*)
 878        (set-mode :word-ish
 879        :until (or
 880           (and (peek-any '(#\:))
 881                (setf terminate-next t))
 882           (and terminate-next (progn
 883                       (setf terminate-next nil)
 884                       (advance 1)))
 885           (scan-any *c-terminators*))
 886        :advancing nil)))
 887      (:word-ish
 888       #+nil
 889       ((scan #\:)
 890        (format t "hi~%")
 891        (set-mode :word-ish :until (advance 1) :advancing nil)
 892        (setf terminate-next t))))
 893   :parent :c++
 894   :formatter-variables ((is-keyword nil) (in-message-send nil))
 895   :formatters
 896   ((:begin-message-send
 897     (lambda (type s)
 898       (setf is-keyword nil)
 899       (setf in-message-send t)
 900       (call-formatter (cons :paren-ish type) s)))
 901    (:end-message-send
 902     (lambda (type s)
 903       (setf is-keyword nil)
 904       (setf in-message-send nil)
 905       (call-formatter (cons :paren-ish type) s)))
 906    (:word-ish
 907     (lambda (type s)
 908       (declare (ignore type))
 909       (prog1
 910      (let ((result (if (find-package :cocoa-lookup)
 911              (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
 912                  s))))
 913        (if result
 914       (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
 915          result s)
 916       (if (member s *c-reserved-words* :test #'string=)
 917           (format nil "<span class=\"symbol\">~A</span>" s)
 918           (if in-message-send
 919          (if is-keyword
 920              (format nil "<span class=\"keyword\">~A</span>" s)
 921              s)
 922          s))))
 923    (setf is-keyword (not is-keyword))))))))
 924
 925
 926 ;#!/usr/bin/clisp
 927 ;#+sbcl
 928 ;(require :asdf)
 929 ;(asdf:oos 'asdf:load-op :colorize)
 930
 931 (defmacro with-each-stream-line ((var stream) &body body)
 932   (let ((eof (gensym))
 933     (eof-value (gensym))
 934     (strm (gensym)))
 935     `(let ((,strm ,stream)
 936        (,eof ',eof-value))
 937       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
 938       ((eql ,var ,eof))
 939     ,@body))))
 940
 941 (defun system (control-string &rest args)
 942   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 943 synchronously execute the result using a Bourne-compatible shell, with
 944 output to *verbose-out*.  Returns the shell's exit code."
 945   (let ((command (apply #'format nil control-string args)))
 946     (format t "; $ ~A~%" command)
 947     #+sbcl
 948     (sb-impl::process-exit-code
 949      (sb-ext:run-program
 950       "/bin/sh"
 951       (list  "-c" command)
 952       :input nil :output *standard-output*))
 953     #+(or cmucl scl)
 954     (ext:process-exit-code
 955      (ext:run-program
 956       "/bin/sh"
 957       (list  "-c" command)
 958       :input nil :output *verbose-out*))
 959     #+clisp             ;XXX not exactly *verbose-out*, I know
 960     (ext:run-shell-command  command :output :terminal :wait t)
 961     ))
 962
 963 (defun strcat (&rest strings)
 964   (apply #'concatenate 'string strings))
 965
 966 (defun string-starts-with (start str)
 967   (and (>= (length str) (length start))
 968        (string-equal start str :end2 (length start))))
 969
 970 (defmacro string-append (outputstr &rest args)
 971   `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
 972
 973 (defconstant +indent+ 0
 974   "Indentation used in the examples.")
 975
 976 (defun texinfo->raw-lisp (code)
 977   "Answer CODE with spurious Texinfo output removed.  For use in
 978 preprocessing output in a @lisp block before passing to colorize."
 979   (decode-from-tt
 980    (with-output-to-string (output)
 981      (do* ((last-position 0)
 982            (next-position
 983             #0=(search #1="<span class=\"roman\">" code
 984                        :start2 last-position :test #'char-equal)
 985             #0#))
 986           ((eq nil next-position)
 987            (write-string code output :start last-position))
 988        (write-string code output :start last-position :end next-position)
 989        (let ((end (search #2="</span>" code
 990                           :start2 (+ next-position (length #1#))
 991                           :test #'char-equal)))
 992          (assert (integerp end) ()
 993                  "Missing ~A tag in HTML for @lisp block~%~
 994                   HTML contents of block:~%~A" #2# code)
 995          (write-string code output
 996                        :start (+ next-position (length #1#))
 997                        :end end)
 998          (setf last-position (+ end (length #2#))))))))
 999
1000 (defun process-file (from to)
1001   (with-open-file (output to :direction :output :if-exists :error)
1002     (with-open-file (input from :direction :input)
1003       (let ((line-processor nil)
1004             (piece-of-code '()))
1005         (labels
1006             ((process-line-inside-pre (line)
1007                (cond ((string-starts-with "</pre>" line)
1008                        (with-input-from-string
1009                            (stream (colorize:html-colorization
1010                                     :common-lisp
1011                                     (texinfo->raw-lisp
1012                                      (apply #'concatenate 'string
1013                                             (nreverse piece-of-code)))))
1014                          (with-each-stream-line (cline stream)
1015                            (format output "  ~A~%" cline)))
1016                        (write-line line output)
1017                        (setq piece-of-code '()
1018                              line-processor #'process-regular-line))
1019                      (t (let ((to-append (subseq line +indent+)))
1020                           (push (if (string= "" to-append)
1021                                   " "
1022                                   to-append) piece-of-code)
1023                           (push (string #\Newline) piece-of-code)))))
1024              (process-regular-line (line)
1025                (let ((len (some (lambda (test-string)
1026                                   (when (string-starts-with test-string line)
1027                                     (length test-string)))
1028                                '("<pre class=\"lisp\">"
1029                                  "<pre class=\"smalllisp\">"))))
1030                  (cond (len
1031                          (setq line-processor #'process-line-inside-pre)
1032                          (write-string "<pre class=\"lisp\">" output)
1033                          (push (subseq line (+ len +indent+)) piece-of-code)
1034                          (push (string #\Newline) piece-of-code))
1035                        (t (write-line line output))))))
1036           (setf line-processor #'process-regular-line)
1037           (with-each-stream-line (line input)
1038             (funcall line-processor line)))))))
1039
1040 (defun process-dir (dir)
1041   (dolist (html-file (directory dir))
1042     (let* ((name (namestring html-file))
1043            (temp-name (strcat name ".temp")))
1044       (process-file name temp-name)
1045       (system "mv ~A ~A" temp-name name))))
1046
1047 ;; (go "/tmp/doc/manual/html_node/*.html")
1048
1049 #+clisp
1050 (progn
1051   (assert (first ext:*args*))
1052   (process-dir (first ext:*args*)))
1053
1054 #+sbcl
1055 (progn
1056   (assert (second sb-ext:*posix-argv*))
1057   (process-dir (second sb-ext:*posix-argv*))
1058   (sb-ext:quit))