guile-hurd/cffi/doc/colorize-lisp-examples.lisp

;;; This is code was taken from lisppaste2 and is a quick hack
;;; to colorize lisp examples in the html generated by Texinfo.
;;; It is not general-purpose utility, though it could easily be
;;; turned into one.

;;;; colorize-package.lisp

(defpackage :colorize
  (:use :common-lisp)
  (:export :scan-string :format-scan :html-colorization
           :find-coloring-type :autodetect-coloring-type
           :coloring-types :scan :scan-any :advance :call-parent-formatter
           :*coloring-css* :make-background-css :*css-background-class*
           :colorize-file :colorize-file-to-stream :*version-token*))

;;;; coloring-css.lisp

(in-package :colorize)

(defparameter *coloring-css*
  ".symbol { color: #770055; background-color: transparent; border: 0px; margin: 0px;}
a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
.special { color : #FF5000; background-color : inherit; }
.keyword { color : #770000; background-color : inherit; }
.comment { color : #007777; background-color : inherit; }
.string { color : #777777; background-color : inherit; }
.character { color : #0055AA; background-color : inherit; }
.syntaxerror { color : #FF0000; background-color : inherit; }
span.paren1:hover { color : inherit; background-color : #BAFFFF; }
span.paren2:hover { color : inherit; background-color : #FFCACA; }
span.paren3:hover { color : inherit; background-color : #FFFFBA; }
span.paren4:hover { color : inherit; background-color : #CACAFF; }
span.paren5:hover { color : inherit; background-color : #CAFFCA; }
span.paren6:hover { color : inherit; background-color : #FFBAFF; }
")

(defvar *css-background-class* "lisp-bg")

(defun for-css (thing)
  (if (symbolp thing) (string-downcase (symbol-name thing))
      thing))

(defun make-background-css (color &key (class *css-background-class*) (extra nil))
  (format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*~:*
.~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%"
          class color
          (mapcar #'(lambda (extra)
                      (format nil "~A : ~{~A ~}"
                              (for-css (first extra))
                              (mapcar #'for-css (cdr extra))))
                  extra)))

;;;; colorize.lisp

;(in-package :colorize)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *coloring-types* nil)
  (defparameter *version-token* (gensym)))

(defclass coloring-type ()
  ((modes :initarg :modes :accessor coloring-type-modes)
   (default-mode :initarg :default-mode :accessor coloring-type-default-mode)
   (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions)
   (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name)
   (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter)
   (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil)
   (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly ""))
   (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function
                        :initform (constantly nil))
   (parent-type :initarg :parent-type :accessor coloring-type-parent-type
                :initform nil)
   (visible :initarg :visible :accessor coloring-type-visible
            :initform t)))

(defun find-coloring-type (type)
  (if (typep type 'coloring-type)
      type
      (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name))))

(defun autodetect-coloring-type (name)
  (car
   (find name *coloring-types*
         :key #'cdr
         :test #'(lambda (name type)
                   (and (coloring-type-visible type)
                        (funcall (coloring-type-autodetect-function type) name))))))

(defun coloring-types ()
  (loop for type-pair in *coloring-types*
        if (coloring-type-visible (cdr type-pair))
        collect (cons (car type-pair)
                      (coloring-type-fancy-name (cdr type-pair)))))

(defun (setf find-coloring-type) (new-value type)
  (if new-value
      (let ((found (assoc type *coloring-types*)))
        (if found
            (setf (cdr found) new-value)
            (setf *coloring-types*
                  (nconc *coloring-types*
                         (list (cons type new-value))))))
      (setf *coloring-types* (remove type *coloring-types* :key #'car))))

(defvar *scan-calls* 0)

(defvar *reset-position* nil)

(defmacro with-gensyms ((&rest names) &body body)
  `(let ,(mapcar #'(lambda (name)
                     (list name `(make-symbol ,(symbol-name name)))) names)
    ,@body))

(defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body)
  (with-gensyms (num items position not-preceded-by string item new-mode until advancing)
    `(labels ((advance (,num)
               (setf ,position-place (+ ,position-place ,num))
               t)
              (peek-any (,items &key ,not-preceded-by)
               (incf *scan-calls*)
               (let* ((,items (if (stringp ,items)
                                  (coerce ,items 'list) ,items))
                      (,not-preceded-by (if (characterp ,not-preceded-by)
                                            (string ,not-preceded-by) ,not-preceded-by))
                      (,position ,position-place)
                      (,string ,string-param))
                 (let ((,item (and
                               (< ,position (length ,string))
                               (find ,string ,items
                                     :test #'(lambda (,string ,item)
                                               #+nil
                                               (format t "looking for ~S in ~S starting at ~S~%"
                                                       ,item ,string ,position)
                                               (if (characterp ,item)
                                                   (char= (elt ,string ,position)
                                                          ,item)
                                                   (search ,item ,string :start2 ,position
                                                           :end2 (min (length ,string)
                                                                      (+ ,position (length ,item))))))))))
                   (if (characterp ,item)
                       (setf ,item (string ,item)))
                   (if
                    (if ,item
                        (if ,not-preceded-by
                            (if (>= (- ,position (length ,not-preceded-by)) 0)
                                (not (string= (subseq ,string
                                                      (- ,position (length ,not-preceded-by))
                                                      ,position)
                                              ,not-preceded-by))
                                t)
                            t)
                        nil)
          ,item
                    (progn
                      (and *reset-position*
                           (setf ,position-place *reset-position*))
                      nil)))))
         (scan-any (,items &key ,not-preceded-by)
      (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by)))
        (and ,item (advance (length ,item)))))
         (peek (,item &key ,not-preceded-by)
      (peek-any (list ,item) :not-preceded-by ,not-preceded-by))
              (scan (,item &key ,not-preceded-by)
               (scan-any (list ,item) :not-preceded-by ,not-preceded-by)))
      (macrolet ((set-mode (,new-mode &key ,until (,advancing t))
                   (list 'progn
                         (list 'setf ',mode-place ,new-mode)
                         (list 'setf ',mode-wait-place
                               (list 'lambda (list ',position)
                                     (list 'let (list (list '*reset-position* ',position))
                                           (list 'values ,until ,advancing)))))))
        ,@body))))

(defvar *formatter-local-variables*)

(defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters
                                autodetect parent formatter-variables (formatter-after-hook '(constantly ""))
                                invisible)
  (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance)
    `(let ((,parent-type (or (find-coloring-type ,parent)
                             (and ,parent
                                  (error "No such coloring type: ~S" ,parent)))))
      (setf (find-coloring-type ,name)
       (make-instance 'coloring-type
        :fancy-name ',fancy-name
        :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type)))
        :default-mode (or ',default-mode
                          (if ,parent-type (coloring-type-default-mode ,parent-type)))
        ,@(if autodetect
              `(:autodetect-function ,autodetect))
        :parent-type ,parent-type
        :visible (not ,invisible)
        :formatter-initial-values (lambda nil
                                    (list* ,@(mapcar #'(lambda (e)
                                                         `(cons ',(car e) ,(second e)))
                                                     formatter-variables)
                                           (if ,parent-type
                                               (funcall (coloring-type-formatter-initial-values ,parent-type))
                                               nil)))
        :formatter-after-hook (lambda nil
                                (symbol-macrolet ,(mapcar #'(lambda (e)
                                                              `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
                                                          formatter-variables)
                                    (concatenate 'string
                                                 (funcall ,formatter-after-hook)
                                                 (if ,parent-type
                                                     (funcall (coloring-type-formatter-after-hook ,parent-type))
                                                     ""))))
        :term-formatter
        (symbol-macrolet ,(mapcar #'(lambda (e)
                                      `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*))))
                                  formatter-variables)
            (lambda (,term)
              (labels ((call-parent-formatter (&optional (,type (car ,term))
                                                         (,string (cdr ,term)))
                         (if ,parent-type
                             (funcall (coloring-type-term-formatter ,parent-type)
                                      (cons ,type ,string))))
                       (call-formatter (&optional (,type (car ,term))
                                                  (,string (cdr ,term)))
                         (funcall
                          (case (first ,type)
                            ,@formatters
                            (t (lambda (,type text)
                                 (call-parent-formatter ,type text))))
                          ,type ,string)))
                (call-formatter))))
        :transition-functions
        (list
         ,@(loop for transition in transitions
                 collect (destructuring-bind (mode &rest table) transition
                           `(cons ',mode
                             (lambda (,current-mode ,string ,position)
                               (let ((,mode-wait (constantly nil))
                                     (,position-foobage ,position))
                                 (with-scanning-functions ,string ,position-foobage
                                                          ,current-mode ,mode-wait
                                                          (let ((*reset-position* ,position))
                                                            (cond ,@table))
                                                          (values ,position-foobage ,current-mode
                                                                  (lambda (,new-position)
                                                                    (setf ,position-foobage ,new-position)
                                                                    (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage))))
                                                                      (values ,position-foobage ,advance)))))
                                 )))))))))))

(defun full-transition-table (coloring-type-object)
  (let ((parent (coloring-type-parent-type coloring-type-object)))
    (if parent
        (append (coloring-type-transition-functions coloring-type-object)
                (full-transition-table parent))
        (coloring-type-transition-functions coloring-type-object))))

(defun scan-string (coloring-type string)
  (let* ((coloring-type-object (or (find-coloring-type coloring-type)
                                   (error "No such coloring type: ~S" coloring-type)))
         (transitions (full-transition-table coloring-type-object))
         (result nil)
         (low-bound 0)
         (current-mode (coloring-type-default-mode coloring-type-object))
         (mode-stack nil)
         (current-wait (constantly nil))
         (wait-stack nil)
         (current-position 0)
         (*scan-calls* 0))
    (flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop)
             (let ((to (if extend new-position current-position)))
               (if (> to low-bound)
                   (setf result (nconc result
                                       (list (cons (cons current-mode mode-stack)
                                                   (subseq string low-bound
                                                           to))))))
               (setf low-bound to)
               (when pop
                 (pop mode-stack)
                 (pop wait-stack))
               (when push
                 (push current-mode mode-stack)
                 (push current-wait wait-stack))
               (setf current-mode new-mode
                     current-position new-position
                     current-wait new-wait))))
      (loop
       (if (> current-position (length string))
           (return-from scan-string
             (progn
               (format *trace-output* "Scan was called ~S times.~%"
                       *scan-calls*)
               (finish-current (length string) nil (constantly nil))
               result))
           (or
            (loop for transition in
                  (mapcar #'cdr
                          (remove current-mode transitions
                                  :key #'car
                                  :test-not #'(lambda (a b)
                                                (or (eql a b)
                                                    (if (listp b)
                                                        (member a b))))))
                  if
                  (and transition
                       (multiple-value-bind
                             (new-position new-mode new-wait)
                           (funcall transition current-mode string current-position)
                         (when (> new-position current-position)
                           (finish-current new-position new-mode new-wait :extend nil :push t)
                           t)))
                  return t)
            (multiple-value-bind
                  (pos advance)
                (funcall current-wait current-position)
              #+nil
              (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position)
              (and pos
                   (when (> pos current-position)
                     (finish-current (if advance
                                         pos
                                         current-position)
                                     (car mode-stack)
                                     (car wait-stack)
                                     :extend advance
                                     :pop t)
                     t)))
            (progn
              (incf current-position)))
           )))))

(defun format-scan (coloring-type scan)
  (let* ((coloring-type-object (or (find-coloring-type coloring-type)
                                   (error "No such coloring type: ~S" coloring-type)))
         (color-formatter (coloring-type-term-formatter coloring-type-object))
         (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object))))
    (format nil "~{~A~}~A"
            (mapcar color-formatter scan)
            (funcall (coloring-type-formatter-after-hook coloring-type-object)))))

(defun encode-for-pre (string)
  (declare (simple-string string))
  (let ((output (make-array (truncate (length string) 2/3)
                            :element-type 'character
                            :adjustable t
                            :fill-pointer 0)))
    (with-output-to-string (out output)
      (loop for char across string
            do (case char
                 ((#\&) (write-string "&amp;" out))
                 ((#\<) (write-string "&lt;" out))
                 ((#\>) (write-string "&gt;" out))
                 ((#\") (write-string "&quot;" out))
                 ((#\RIGHTWARDS_DOUBLE_ARROW) (write-string "&rArr;" out))
                 (t (write-char char out)))))
    (coerce output 'simple-string)))

(defun string-substitute (string substring replacement-string)
  "String substitute by Larry Hunter. Obtained from Google"
  (let ((substring-length (length substring))
    (last-end 0)
    (new-string ""))
    (do ((next-start
      (search substring string)
      (search substring string :start2 last-end)))
    ((null next-start)
     (concatenate 'string new-string (subseq string last-end)))
      (setq new-string
    (concatenate 'string
      new-string
      (subseq string last-end next-start)
      replacement-string))
      (setq last-end (+ next-start substring-length)))))

(defun decode-from-tt (string)
  (string-substitute
   (string-substitute
    (string-substitute
     (string-substitute
      (string-substitute string "&amp;" "&")
      "&lt;" "<")
     "&gt;" ">")
    "&rArr;" (string #\RIGHTWARDS_DOUBLE_ARROW))
   "&quot;" "\""))

(defun html-colorization (coloring-type string)
  (format-scan coloring-type
               (mapcar #'(lambda (p)
                           (cons (car p)
                                 (let ((tt (encode-for-pre (cdr p))))
                                   (if (and (> (length tt) 0)
                                            (char= (elt tt (1- (length tt))) #\>))
                                       (format nil "~A~%" tt) tt))))
                       (scan-string coloring-type string))))

(defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default"))
  (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
                         (merge-pathnames input-file-name)
                         (make-pathname :type "lisp"
                                        :defaults (merge-pathnames input-file-name))))
         (*css-background-class* css-background))
    (with-open-file (s input-file :direction :input)
      (let ((lines nil)
            (string nil))
        (block done
          (loop (let ((line (read-line s nil nil)))
                  (if line
                      (push line lines)
                      (return-from done)))))
        (setf string (format nil "~{~A~%~}"
                             (nreverse lines)))
        (if wrap
            (format s2
                    "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">
<html><head><style type=\"text/css\">~A~%~A</style><body>
<table width=\"100%\"><tr><td class=\"~A\">
<tt>~A</tt>
</tr></td></table></body></html>"
                    *coloring-css*
                    (make-background-css "white")
                    *css-background-class*
                    (html-colorization coloring-type string))
            (write-string (html-colorization coloring-type string) s2))))))

(defun colorize-file (coloring-type input-file-name &optional output-file-name)
  (let* ((input-file (if (pathname-type (merge-pathnames input-file-name))
                         (merge-pathnames input-file-name)
                         (make-pathname :type "lisp"
                                        :defaults (merge-pathnames input-file-name))))
         (output-file (or output-file-name
                          (make-pathname :type "html"
                                         :defaults input-file))))
    (with-open-file (s2 output-file :direction :output :if-exists :supersede)
      (colorize-file-to-stream coloring-type input-file-name s2))))

;; coloring-types.lisp

;(in-package :colorize)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *version-token* (gensym)))

(defparameter *symbol-characters*
  "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890")

(defparameter *non-constituent*
  '(#\space #\tab #\newline #\linefeed #\page #\return
    #\" #\' #\( #\) #\, #\; #\` #\[ #\]))

(defparameter *special-forms*
  '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the"
    "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*"
    "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally"
    "return-from" "setq" "multiple-value-call"))

(defparameter *common-macros*
  '("loop" "cond" "lambda"))

(defparameter *open-parens* '(#\())
(defparameter *close-parens* '(#\)))

(define-coloring-type :lisp "Basic Lisp"
  :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment
                  :multiline :character
                  :single-escaped :in-list :syntax-error)
  :default-mode :first-char-on-line
  :transitions
  (((:in-list)
    ((or
      (scan-any *symbol-characters*)
      (and (scan #\.) (scan-any *symbol-characters*))
      (and (scan #\\) (advance 1)))
     (set-mode :symbol
               :until (scan-any *non-constituent*)
               :advancing nil))
    ((or (scan #\:) (scan "#:"))
     (set-mode :keyword
               :until (scan-any *non-constituent*)
               :advancing nil))
    ((scan "#\\")
     (let ((count 0))
       (set-mode :character
                 :until (progn
                          (incf count)
                          (if (> count 1)
                              (scan-any *non-constituent*)))
                 :advancing nil)))
    ((scan #\")
     (set-mode :string
               :until (scan #\")))
    ((scan #\;)
     (set-mode :comment
               :until (scan #\newline)))
    ((scan "#|")
     (set-mode :multiline
               :until (scan "|#")))
    ((scan #\()
     (set-mode :in-list
               :until (scan #\)))))
   ((:normal :first-char-on-line)
    ((scan #\()
     (set-mode :in-list
               :until (scan #\)))))
   (:first-char-on-line
    ((scan #\;)
     (set-mode :comment
               :until (scan #\newline)))
    ((scan "#|")
     (set-mode :multiline
               :until (scan "|#")))
    ((advance 1)
     (set-mode :normal
               :until (scan #\newline))))
   (:multiline
    ((scan "#|")
     (set-mode :multiline
               :until (scan "|#"))))
   ((:symbol :keyword :escaped-symbol :string)
    ((scan #\\)
     (let ((count 0))
       (set-mode :single-escaped
                 :until (progn
                          (incf count)
                          (if (< count 2)
                              (advance 1))))))))
  :formatter-variables ((paren-counter 0))
  :formatter-after-hook (lambda nil
                          (format nil "~{~A~}"
                                  (loop for i from paren-counter downto 1
                                        collect "</span></span>")))
  :formatters
  (((:normal :first-char-on-line)
    (lambda (type s)
      (declare (ignore type))
      s))
   ((:in-list)
    (lambda (type s)
      (declare (ignore type))
      (labels ((color-parens (s)
                 (let ((paren-pos (find-if-not #'null
                                               (mapcar #'(lambda (c)
                                                           (position c s))
                                                       (append *open-parens*
                                                               *close-parens*)))))
                   (if paren-pos
                       (let ((before-paren (subseq s 0 paren-pos))
                             (after-paren (subseq s (1+ paren-pos)))
                             (paren (elt s paren-pos))
                             (open nil)
                             (count 0))
                         (when (member paren *open-parens* :test #'char=)
                           (setf count (mod paren-counter 6))
                           (incf paren-counter)
                           (setf open t))
                         (when (member paren *close-parens* :test #'char=)
                           (decf paren-counter))
                         (if open
                             (format nil "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
                                     before-paren
                                     (1+ count)
                                     paren *css-background-class*
                                     (color-parens after-paren))
                             (format nil "~A</span>~C</span>~A"
                                     before-paren
                                     paren (color-parens after-paren))))
                       s))))
        (color-parens s))))
   ((:symbol :escaped-symbol)
    (lambda (type s)
      (declare (ignore type))
      (let* ((colon (position #\: s :from-end t))
             (new-s (or (and colon (subseq s (1+ colon))) s)))
        (cond
          ((or
            (member new-s *common-macros* :test #'string-equal)
            (member new-s *special-forms* :test #'string-equal)
            (some #'(lambda (e)
                      (and (> (length new-s) (length e))
                           (string-equal e (subseq new-s 0 (length e)))))
                  '("WITH-" "DEF")))
           (format nil "<i><span class=\"symbol\">~A</span></i>" s))
          ((and (> (length new-s) 2)
                (char= (elt new-s 0) #\*)
                (char= (elt new-s (1- (length new-s))) #\*))
           (format nil "<span class=\"special\">~A</span>" s))
          (t s)))))
   (:keyword (lambda (type s)
      (declare (ignore type))
               (format nil "<span class=\"keyword\">~A</span>"
                       s)))
   ((:comment :multiline)
    (lambda (type s)
      (declare (ignore type))
      (format nil "<span class=\"comment\">~A</span>"
              s)))
   ((:character)
    (lambda (type s)
      (declare (ignore type))
      (format nil "<span class=\"character\">~A</span>"
              s)))
   ((:string)
    (lambda (type s)
      (declare (ignore type))
      (format nil "<span class=\"string\">~A</span>"
              s)))
   ((:single-escaped)
    (lambda (type s)
      (call-formatter (cdr type) s)))
   ((:syntax-error)
    (lambda (type s)
      (declare (ignore type))
      (format nil "<span class=\"syntaxerror\">~A</span>"
              s)))))

(define-coloring-type :scheme "Scheme"
  :autodetect (lambda (text)
                (or
                 (search "scheme" text :test #'char-equal)
                 (search "chicken" text :test #'char-equal)))
  :parent :lisp
  :transitions
  (((:normal :in-list)
    ((scan "...")
     (set-mode :symbol
               :until (scan-any *non-constituent*)
               :advancing nil))
    ((scan #\[)
     (set-mode :in-list
               :until (scan #\])))))
  :formatters
  (((:in-list)
    (lambda (type s)
      (declare (ignore type s))
      (let ((*open-parens* (cons #\[ *open-parens*))
            (*close-parens* (cons #\] *close-parens*)))
        (call-parent-formatter))))
   ((:symbol :escaped-symbol)
    (lambda (type s)
      (declare (ignore type))
      (let ((result (if (find-package :r5rs-lookup)
                         (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup))
                                  s))))
        (if result
            (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
                    result (call-parent-formatter))
            (call-parent-formatter)))))))

(define-coloring-type :elisp "Emacs Lisp"
  :autodetect (lambda (name)
                (member name '("emacs")
                        :test #'(lambda (name ext)
                                  (search ext name :test #'char-equal))))
  :parent :lisp
  :formatters
  (((:symbol :escaped-symbol)
    (lambda (type s)
      (declare (ignore type))
      (let ((result (if (find-package :elisp-lookup)
                         (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup))
                                  s))))
        (if result
            (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
                    result (call-parent-formatter))
            (call-parent-formatter)))))))

(define-coloring-type :common-lisp "Common Lisp"
  :autodetect (lambda (text)
                (search "lisp" text :test #'char-equal))
  :parent :lisp
  :transitions
  (((:normal :in-list)
    ((scan #\|)
     (set-mode :escaped-symbol
               :until (scan #\|)))))
  :formatters
  (((:symbol :escaped-symbol)
    (lambda (type s)
      (declare (ignore type))
      (let* ((colon (position #\: s :from-end t :test #'char=))
             (to-lookup (if colon (subseq s (1+ colon)) s))
             (result (if (find-package :clhs-lookup)
                         (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup))
                                  to-lookup))))
        (if result
            (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
                    result (call-parent-formatter))
            (call-parent-formatter)))))))

(define-coloring-type :common-lisp-file "Common Lisp File"
  :parent :common-lisp
  :default-mode :in-list
  :invisible t)

(defvar *c-open-parens* "([{")
(defvar *c-close-parens* ")]}")

(defvar *c-reserved-words*
  '("auto"   "break"  "case"   "char"   "const"
    "continue" "default" "do"     "double" "else"
    "enum"   "extern" "float"  "for"    "goto"
    "if"     "int"    "long"   "register" "return"
    "short"  "signed" "sizeof" "static" "struct"
    "switch" "typedef" "union"  "unsigned" "void"
    "volatile" "while"  "__restrict" "_Bool"))

(defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
(defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#))

(define-coloring-type :basic-c "Basic C"
  :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor)
  :default-mode :normal
  :invisible t
  :transitions
  ((:normal
    ((scan-any *c-begin-word*)
     (set-mode :word-ish
               :until (scan-any *c-terminators*)
               :advancing nil))
    ((scan "/*")
     (set-mode :comment
               :until (scan "*/")))
    ((or
      (scan-any *c-open-parens*)
      (scan-any *c-close-parens*))
     (set-mode :paren-ish
               :until (advance 1)
               :advancing nil))
    ((scan #\")
     (set-mode :string
               :until (scan #\")))
    ((or (scan "'\\")
         (scan #\'))
     (set-mode :character
               :until (advance 2))))
   (:string
    ((scan #\\)
     (set-mode :single-escape
               :until (advance 1)))))
  :formatter-variables
  ((paren-counter 0))
  :formatter-after-hook (lambda nil
                          (format nil "~{~A~}"
                                  (loop for i from paren-counter downto 1
                                        collect "</span></span>")))
  :formatters
  ((:normal
    (lambda (type s)
      (declare (ignore type))
      s))
   (:comment
    (lambda (type s)
      (declare (ignore type))
      (format nil "<span class=\"comment\">~A</span>"
              s)))
   (:string
    (lambda (type s)
      (declare (ignore type))
      (format nil "<span class=\"string\">~A</span>"
              s)))
   (:character
    (lambda (type s)
      (declare (ignore type))
      (format nil "<span class=\"character\">~A</span>"
              s)))
   (:single-escape
    (lambda (type s)
      (call-formatter (cdr type) s)))
   (:paren-ish
    (lambda (type s)
      (declare (ignore type))
      (let ((open nil)
            (count 0))
        (if (eql (length s) 1)
            (progn
              (when (member (elt s 0) (coerce *c-open-parens* 'list))
                (setf open t)
                (setf count (mod paren-counter 6))
                (incf paren-counter))
              (when (member (elt s 0) (coerce *c-close-parens* 'list))
                (setf open nil)
                (decf paren-counter)
                (setf count (mod paren-counter 6)))
              (if open
                  (format nil "<span class=\"paren~A\">~A<span class=\"~A\">"
                          (1+ count) s *css-background-class*)
                  (format nil "</span>~A</span>"
                          s)))
            s))))
   (:word-ish
    (lambda (type s)
      (declare (ignore type))
      (if (member s *c-reserved-words* :test #'string=)
          (format nil "<span class=\"symbol\">~A</span>" s)
          s)))
   ))

(define-coloring-type :c "C"
  :parent :basic-c
  :transitions
  ((:normal
    ((scan #\#)
     (set-mode :preprocessor
               :until (scan-any '(#\return #\newline))))))
  :formatters
  ((:preprocessor
    (lambda (type s)
      (declare (ignore type))
      (format nil "<span class=\"special\">~A</span>" s)))))

(defvar *c++-reserved-words*
  '("asm"          "auto"      "bool"     "break"            "case"
    "catch"        "char"      "class"    "const"            "const_cast"
    "continue"     "default"   "delete"   "do"               "double"
    "dynamic_cast" "else"      "enum"     "explicit"         "export"
    "extern"       "false"     "float"    "for"              "friend"
    "goto"         "if"        "inline"   "int"              "long"
    "mutable"      "namespace" "new"      "operator"         "private"
    "protected"    "public"    "register" "reinterpret_cast" "return"
    "short"        "signed"    "sizeof"   "static"           "static_cast"
    "struct"       "switch"    "template" "this"             "throw"
    "true"         "try"       "typedef"  "typeid"           "typename"
    "union"        "unsigned"  "using"    "virtual"          "void"
    "volatile"     "wchar_t"   "while"))

(define-coloring-type :c++ "C++"
  :parent :c
  :transitions
  ((:normal
    ((scan "//")
     (set-mode :comment
               :until (scan-any '(#\return #\newline))))))
  :formatters
  ((:word-ish
    (lambda (type s)
      (declare (ignore type))
      (if (member s *c++-reserved-words* :test #'string=)
          (format nil "<span class=\"symbol\">~A</span>"
                  s)
          s)))))

(defvar *java-reserved-words*
  '("abstract"     "boolean"      "break"    "byte"         "case"
    "catch"        "char"         "class"    "const"        "continue"
    "default"      "do"           "double"   "else"         "extends"
    "final"        "finally"      "float"    "for"          "goto"
    "if"           "implements"   "import"   "instanceof"   "int"
    "interface"    "long"         "native"   "new"          "package"
    "private"      "protected"    "public"   "return"       "short"
    "static"       "strictfp"     "super"    "switch"       "synchronized"
    "this"         "throw"        "throws"   "transient"    "try"
    "void"         "volatile"     "while"))

(define-coloring-type :java "Java"
  :parent :c++
  :formatters
  ((:word-ish
    (lambda (type s)
      (declare (ignore type))
      (if (member s *java-reserved-words* :test #'string=)
          (format nil "<span class=\"symbol\">~A</span>"
                  s)
          s)))))

(let ((terminate-next nil))
  (define-coloring-type :objective-c "Objective C"
    :autodetect (lambda (text) (search "mac" text :test #'char=))
    :modes (:begin-message-send :end-message-send)
    :transitions
    ((:normal
      ((scan #\[)
       (set-mode :begin-message-send
       :until (advance 1)
       :advancing nil))
      ((scan #\])
       (set-mode :end-message-send
       :until (advance 1)
       :advancing nil))
      ((scan-any *c-begin-word*)
       (set-mode :word-ish
       :until (or
          (and (peek-any '(#\:))
               (setf terminate-next t))
          (and terminate-next (progn
                      (setf terminate-next nil)
                      (advance 1)))
          (scan-any *c-terminators*))
       :advancing nil)))
     (:word-ish
      #+nil
      ((scan #\:)
       (format t "hi~%")
       (set-mode :word-ish :until (advance 1) :advancing nil)
       (setf terminate-next t))))
  :parent :c++
  :formatter-variables ((is-keyword nil) (in-message-send nil))
  :formatters
  ((:begin-message-send
    (lambda (type s)
      (setf is-keyword nil)
      (setf in-message-send t)
      (call-formatter (cons :paren-ish type) s)))
   (:end-message-send
    (lambda (type s)
      (setf is-keyword nil)
      (setf in-message-send nil)
      (call-formatter (cons :paren-ish type) s)))
   (:word-ish
    (lambda (type s)
      (declare (ignore type))
      (prog1
     (let ((result (if (find-package :cocoa-lookup)
             (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
                 s))))
       (if result
      (format nil "<a href=\"~A\" class=\"symbol\">~A</a>"
         result s)
      (if (member s *c-reserved-words* :test #'string=)
          (format nil "<span class=\"symbol\">~A</span>" s)
          (if in-message-send
         (if is-keyword
             (format nil "<span class=\"keyword\">~A</span>" s)
             s)
         s))))
   (setf is-keyword (not is-keyword))))))))


;#!/usr/bin/clisp
;#+sbcl
;(require :asdf)
;(asdf:oos 'asdf:load-op :colorize)

(defmacro with-each-stream-line ((var stream) &body body)
  (let ((eof (gensym))
    (eof-value (gensym))
    (strm (gensym)))
    `(let ((,strm ,stream)
       (,eof ',eof-value))
      (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
      ((eql ,var ,eof))
    ,@body))))

(defun system (control-string &rest args)
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
output to *verbose-out*.  Returns the shell's exit code."
  (let ((command (apply #'format nil control-string args)))
    (format t "; $ ~A~%" command)
    #+sbcl
    (sb-impl::process-exit-code
     (sb-ext:run-program
      "/bin/sh"
      (list  "-c" command)
      :input nil :output *standard-output*))
    #+(or cmucl scl)
    (ext:process-exit-code
     (ext:run-program
      "/bin/sh"
      (list  "-c" command)
      :input nil :output *verbose-out*))
    #+clisp             ;XXX not exactly *verbose-out*, I know
    (ext:run-shell-command  command :output :terminal :wait t)
    ))

(defun strcat (&rest strings)
  (apply #'concatenate 'string strings))

(defun string-starts-with (start str)
  (and (>= (length str) (length start))
       (string-equal start str :end2 (length start))))

(defmacro string-append (outputstr &rest args)
  `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))

(defconstant +indent+ 0
  "Indentation used in the examples.")

(defun texinfo->raw-lisp (code)
  "Answer CODE with spurious Texinfo output removed.  For use in
preprocessing output in a @lisp block before passing to colorize."
  (decode-from-tt
   (with-output-to-string (output)
     (do* ((last-position 0)
           (next-position
            #0=(search #1="<span class=\"roman\">" code
                       :start2 last-position :test #'char-equal)
            #0#))
          ((eq nil next-position)
           (write-string code output :start last-position))
       (write-string code output :start last-position :end next-position)
       (let ((end (search #2="</span>" code
                          :start2 (+ next-position (length #1#))
                          :test #'char-equal)))
         (assert (integerp end) ()
                 "Missing ~A tag in HTML for @lisp block~%~
                  HTML contents of block:~%~A" #2# code)
         (write-string code output
                       :start (+ next-position (length #1#))
                       :end end)
         (setf last-position (+ end (length #2#))))))))

(defun process-file (from to)
  (with-open-file (output to :direction :output :if-exists :error)
    (with-open-file (input from :direction :input)
      (let ((line-processor nil)
            (piece-of-code '()))
        (labels
            ((process-line-inside-pre (line)
               (cond ((string-starts-with "</pre>" line)
                       (with-input-from-string
                           (stream (colorize:html-colorization
                                    :common-lisp
                                    (texinfo->raw-lisp
                                     (apply #'concatenate 'string
                                            (nreverse piece-of-code)))))
                         (with-each-stream-line (cline stream)
                           (format output "  ~A~%" cline)))
                       (write-line line output)
                       (setq piece-of-code '()
                             line-processor #'process-regular-line))
                     (t (let ((to-append (subseq line +indent+)))
                          (push (if (string= "" to-append)
                                  " "
                                  to-append) piece-of-code)
                          (push (string #\Newline) piece-of-code)))))
             (process-regular-line (line)
               (let ((len (some (lambda (test-string)
                                  (when (string-starts-with test-string line)
                                    (length test-string)))
                               '("<pre class=\"lisp\">"
                                 "<pre class=\"smalllisp\">"))))
                 (cond (len
                         (setq line-processor #'process-line-inside-pre)
                         (write-string "<pre class=\"lisp\">" output)
                         (push (subseq line (+ len +indent+)) piece-of-code)
                         (push (string #\Newline) piece-of-code))
                       (t (write-line line output))))))
          (setf line-processor #'process-regular-line)
          (with-each-stream-line (line input)
            (funcall line-processor line)))))))

(defun process-dir (dir)
  (dolist (html-file (directory dir))
    (let* ((name (namestring html-file))
           (temp-name (strcat name ".temp")))
      (process-file name temp-name)
      (system "mv ~A ~A" temp-name name))))

;; (go "/tmp/doc/manual/html_node/*.html")

#+clisp
(progn
  (assert (first ext:*args*))
  (process-dir (first ext:*args*)))

#+sbcl
(progn
  (assert (second sb-ext:*posix-argv*))
  (process-dir (second sb-ext:*posix-argv*))
  (sb-ext:quit))