#|-------------------- 0.2.2 |# "./coloring-types.scm" 38030
;; coloring-types.scm
;; A direct port of coloring-types.lisp
;; This version based on lisppaste CVS HEAD ** revision 1.35 **

;; NOTE TO ALL HACKERS OF THIS CODE:
;; *Please* feed all bugfixes you make to this code back to the lisppaste
;; project.  This helps the lisppaste project get better highlighting
;; and makes it easier for us to reintegrate coloring type modifications
;; made upstream.

(define *symbol-characters*
  (make-parameter
   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890"))

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

(define *special-forms*
  (make-parameter
   '("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")))

(define *common-macros*
  (make-parameter
   '("loop" "cond" "lambda")))

(define *open-parens* (make-parameter '(#\()))
(define *close-parens* (make-parameter '(#\))))

(define *css-background-class* (make-parameter "default"))

(define-coloring-type :lisp "Basic Lisp"
  :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 #f))
    ((or (scan #\:) (scan "#:"))
     (set-mode :keyword
               :until (scan-any (*non-constituent*))
               :advancing #f))
    ((scan "#\\")
     (let ((count 0))
       (set-mode :character
                 :until (begin
                          (set! count (add1 count))
                          (if (> count 1)
                              (scan-any (*non-constituent*))))
                 :advancing #f)))
    ((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 (begin
                          (set! count (add1 count))
                          (if (< count 2)
                              (advance 1))))))))
  :formatter-variables
  ((paren-counter 0))
  :formatter-after-hook
  (lambda ()
    (string-concatenate
     (list-tabulate paren-counter
                    (constantly "</span></span>"))))
  :formatters
  (((:normal :first-char-on-line)
    (lambda (type s)
      s))
   ((:in-list)
    (lambda (type s)
      (letrec ((color-parens
                (lambda (s)
                  (let ((paren-pos (find identity
                                         (map (lambda (c)
                                                (string-index s c))
                                              (append (*open-parens*)
                                                      (*close-parens*))))))
                    (if paren-pos
                        (let ((before-paren (substring s 0 paren-pos))
                              (after-paren (substring s (add1 paren-pos)))
                              (paren (string-ref s paren-pos))
                              (open #f)
                              (count 0))
                          (when (member paren (*open-parens*))
                            (set! count (modulo paren-counter 6))
                            (set! paren-counter (add1 paren-counter))
                            (set! open #t))
                          (when (member paren (*close-parens*))
                            (set! paren-counter (sub1 paren-counter)))
                          (if open
                              (format #f "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
                                      before-paren
                                      (add1 count)
                                      paren (*css-background-class*)
                                      (color-parens after-paren))
                              (format #f "~A</span>~C</span>~A"
                                      before-paren
                                      paren (color-parens after-paren))))
                        s)))))
        (color-parens s))))
   ((:symbol :escaped-symbol)
    (lambda (type s)
      (let* ((colon (string-index-right s #\:))
             (new-s (or (and colon (string-drop-right s (add1 colon))) s)))
        (cond
          ((or
            (member new-s (*common-macros*))
            (member new-s (*special-forms*))
            (any (lambda (e)
                   (and (> (string-length new-s) (string-length e))
                        (string-ci=? e (substring new-s 0 (string-length e)))))
                 '("WITH-" "DEF")))
           (format #f "<i><span class=\"symbol\">~A</span></i>" s))
          ((and (> (string-length new-s) 2)
                (char=? (string-ref new-s 0) #\*)
                (char=? (string-ref new-s (sub1 (string-length new-s))) #\*))
           (format #f "<span class=\"special\">~A</span>" s))
          (else s)))))
   (:keyword (lambda (type s)
               (format #f "<span class=\"keyword\">~A</span>"
                       s)))
   ((:comment :multiline)
    (lambda (type s)
      (format #f "<span class=\"comment\">~A</span>"
              s)))
   ((:character)
    (lambda (type s)
      (format #f "<span class=\"character\">~A</span>"
              s)))
   ((:string)
    (lambda (type s)
      (format #f "<span class=\"string\">~A</span>"
              s)))
   ((:single-escaped)
    (lambda (type s)
      (call-formatter (cdr type) s)))
   ((:syntax-error)
    (lambda (type s)
      (format #f "<span class=\"syntaxerror\">~A</span>"
              s)))))

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

(define-coloring-type :elisp "Emacs Lisp"
  :parent :lisp
  :formatters
  (((:symbol :escaped-symbol)
    (lambda (type s)
      (let ((result #f #;(if (find-package :elisp-lookup)
                         (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup))
                                  s))))
        (if result
            (format #f "<a href=\"~A\" class=\"symbol\">~A</a>"
                    result (call-parent-formatter))
            (call-parent-formatter)))))))

(define-coloring-type :common-lisp "Common Lisp"
  :parent :lisp
  :transitions
  (((:normal :in-list)
    ((scan #\|)
     (set-mode :escaped-symbol
               :until (scan #\|)))))
  :formatters 
  (((:symbol :escaped-symbol)
    (lambda (type s)
      (let* ((colon (string-index-right s #\:))
             (to-lookup (if colon (substring s (add1 colon)) s))
             (result #f #;(if (find-package :clhs-lookup)
                         (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup))
                                  to-lookup))))
        (if result
            (format #f "<a href=\"~A\" class=\"symbol\">~A</a>"
                    result (call-parent-formatter))
            (call-parent-formatter)))))))

(define *c-open-parens* (make-parameter "([{"))
(define *c-close-parens* (make-parameter ")]}"))

(define *c-reserved-words*
  (make-parameter
   '("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")))

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

(define-coloring-type :basic-c "Basic C"
  :default-mode :normal
  :abstract #t
  :transitions
  ((:normal
    ((scan-any (*c-begin-word*))
     (set-mode :word-ish
               :until (scan-any (*c-terminators*))
               :advancing #f))
    ((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 #f))
    ((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 ()
    (string-concatenate
     (list-tabulate paren-counter
                    (constantly "</span></span>"))))
  :formatters
  ((:normal
    (lambda (type s)
      s))
   (:comment
    (lambda (type s)
      (format #f "<span class=\"comment\">~A</span>"
              s)))
   (:string
    (lambda (type s)
      (format #f "<span class=\"string\">~A</span>"
              s)))
   (:character
    (lambda (type s)
      (format #f "<span class=\"character\">~A</span>"
              s)))
   (:single-escape
    (lambda (type s)
      (call-formatter (cdr type) s)))
   (:paren-ish
    (lambda (type s)
      (let ((open #f)
            (count 0))
        (if (= (string-length s) 1)
            (begin
              (when (member (string-ref s 0) (string->list (*c-open-parens*)))
                (set! open #t)
                (set! count (modulo paren-counter 6))
                (set! paren-counter (add1 paren-counter)))
              (when (member (string-ref s 0) (string->list (*c-close-parens*)))
                (set! open #f)
                (set! paren-counter (sub1 paren-counter))
                (set! count (modulo paren-counter 6)))
              (if open
                  (format #f "<span class=\"paren~A\">~A<span class=\"~A\">"
                          (add1 count) s (*css-background-class*))
                  (format #f "</span>~A</span>"
                          s)))
            s))))
   (:word-ish
    (lambda (type s)
      (if (member s (*c-reserved-words*))
          (format #f "<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))))
    ((scan "//")
     (set-mode :comment
               :until (scan-any '(#\return #\newline))))))
  :formatters
  ((:preprocessor
    (lambda (type s)
      (format #f "<span class=\"special\">~A</span>" s)))))

(define *c++-reserved-words*
  (make-parameter
   '("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 ()
  :formatters
  ((:word-ish
    (lambda (type s)
      (if (member s (*c++-reserved-words*))
          (format #f "<span class=\"symbol\">~A</span>"
                  s)
          s)))))

(define *java-reserved-words*
  (make-parameter
   '("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)
      (if (member s (*java-reserved-words*))
          (format #f "<span class=\"symbol\">~A</span>"
                  s)
          s)))))

(let ((terminate-next #f)) ;; TODO: Shouldn't this be a formatter-var?
  (define-coloring-type :objective-c "Objective C"
    :transitions
    ((:normal
      ((scan #\[)
       (set-mode :begin-message-send
		 :until (advance 1)
		 :advancing #f))
      ((scan #\])
       (set-mode :end-message-send
		 :until (advance 1)
		 :advancing #f))
      ((scan-any (*c-begin-word*))
       (set-mode :word-ish
		 :until (or
			 (and (peek-any '(#\:))
			      (set! terminate-next #t))
			 (and terminate-next (begin
					       (set! terminate-next #f)
					       (advance 1)))
			 (scan-any (*c-terminators*)))
		 :advancing #f)))
     (:word-ish)) ; ??
  :parent :c++
  :formatter-variables ((is-keyword #f) (in-message-send #f))
  :formatters
  ((:begin-message-send
    (lambda (type s)
      (set! is-keyword #f)
      (set! in-message-send #t)
      (call-formatter (cons :paren-ish type) s)))
   (:end-message-send
    (lambda (type s)
      (set! is-keyword #f)
      (set! in-message-send #f)
      (call-formatter (cons :paren-ish type) s)))
   (:word-ish
    (lambda (type s)
      (let* ((result #f              #;(if (find-package :cocoa-lookup)
                    (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
                    s)))
             (html
              (if result
                  (format #f "<a href=\"~A\" class=\"symbol\">~A</a>"
                          result s)
                  (if (member s (*c-reserved-words*))
                      (format #f "<span class=\"symbol\">~A</span>" s)
                      (if in-message-send
                          (if is-keyword
                              (format #f "<span class=\"keyword\">~A</span>" s)
                              s)
                          s)))))
        (set! is-keyword (not is-keyword))
        html))))))

(define *erlang-open-parens* (make-parameter "([{"))
(define *erlang-close-parens* (make-parameter ")]}"))

(define *erlang-reserved-words*
  (make-parameter
   '("after" "andalso" "begin" "catch" "case" "end" "fun" "if" "of" "orelse"
     "receive" "try" "when" "query" "is_atom" "is_binary" "is_constant"
     "is_float" "is_function" "is_integer" "is_list" "is_number" "is_pid"
     "is_port" "is_reference" "is_tuple" "is_record" "abs" "element" "float"
     "hd" "tl" "length" "node" "round" "self" "size" "trunc" "alive" "apply"
     "atom_to_list" "binary_to_list" "binary_to_term" "concat_binary"
     "date" "disconnect_node" "erase" "exit" "float_to_list" "garbage_collect"
     "get" "get_keys" "group_leader" "halt" "integer_to_list" "internal_bif"
     "link" "list_to_atom" "list_to_binary" "list_to_float" "list_to_integer"
     "make_ref" "node_link" "node_unlink" "notalive" "open_port" "pid_to_list"
     "process_flag" "process_info" "processes" "put" "register" "registered"
     "setelement" "spawn" "spawn_link" "split_binary" "statistics"
     "term_to_binary" "time" "throw" "trace" "trunc" "tuple_to_list"
     "unlink" "unregister" "whereis")))

(define *erlang-begin-word*
  (make-parameter
   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
(define *erlang-begin-fun* (make-parameter "abcdefghijklmnopqrstuvwxyz"))
(define *erlang-begin-var* (make-parameter "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"))
(define *erlang-terminators*
  (make-parameter
   '(#\space #\return #\tab #\newline #\. #\; #\, #\/ #\- #\* #\+
     #\( #\) #\' #\" #\[ #\] #\< #\> #\{ #\})))

(define-coloring-type :erlang "Erlang"
  :default-mode :first-char-on-line
  :transitions
  (((:normal :paren-ish)
    ((scan "%")
     (set-mode :comment
               :until (scan #\newline)))
    ((scan-any (*erlang-begin-var*))
     (set-mode :variable
               :until (scan-any (*erlang-terminators*))
               :advancing #f))
    ((scan-any (*erlang-begin-word*))
     (set-mode :word-ish
               :until (scan-any (*erlang-terminators*))
               :advancing #f))
    ((or
      (scan-any (*erlang-open-parens*))
      (scan-any (*erlang-close-parens*)))
     (set-mode :paren-ish
               :until (advance 1)
               :advancing #f))
    ((scan #\")
     (set-mode :string
               :until (scan #\")))
    ((scan #\')
     (set-mode :atom
               :until (scan #\')))
    ((scan #\?)
     (set-mode :macro
               :until (scan-any (*erlang-terminators*))))
    ((scan #\$)
     (set-mode :char
               :until (scan-any (*erlang-terminators*))))
    ((scan #\newline)
     (set-mode :first-char-on-line)))
   
   ((:function :attribute)
    ((or
      (scan-any (*erlang-open-parens*))
      (scan-any (*erlang-close-parens*)))
     (set-mode :paren-ish
               :until (advance 1)
               :advancing #f))
    ((scan-any (*erlang-terminators*))
     (set-mode :normal
               :until (scan #\newline))))
   
   (:first-char-on-line
    ((scan "%")
     (set-mode :comment
               :until (scan #\newline)))
    ((scan-any (*erlang-begin-fun*))
     (set-mode :function
               :until (scan #\newline)
               :advancing #f))
    ((scan "-")
     (set-mode :attribute
               :until (scan #\newline)
               :advancing #f))
    ((advance 1)
     (set-mode :normal
               :until (scan #\newline))))
   (:string
    ((scan #\\)
     (set-mode :single-escape
               :until (advance 1)))))
  :formatter-variables
  ((paren-counter 0))
  :formatter-after-hook
  (lambda ()
    (string-concatenate
     (list-tabulate paren-counter
                    (constantly "</span></span>"))))
  :formatters
  (((:normal :first-char-on-line)
    (lambda (type s)
      s))
   (:comment
    (lambda (type s)
      (format #f "<span class=\"comment\">~A</span>"
              s)))
   (:string
    (lambda (type s)
      (format #f "<span class=\"string\">~A</span>"
              s)))
   (:variable
    (lambda (type s)
      (format #f "<span class=\"variable\">~A</span>"
              s)))
   (:function
    (lambda (type s)
      (format #f "<span class=\"function\">~A</span>"
              s)))
   (:attribute
    (lambda (type s)
      (format #f "<span class=\"attribute\">~A</span>"
              s)))
   (:macro
    (lambda (type s)
      (format #f "<span class=\"macro\">~A</span>"
              s)))
   (:atom
    (lambda (type s)
      (format #f "<span class=\"atom\">~A</span>"
              s)))
   (:char
    (lambda (type s)
      (format #f "<span class=\"character\">~A</span>"
              s)))
   (:single-escape
    (lambda (type s)
      (call-formatter (cdr type) s)))
   (:paren-ish
    (lambda (type s)
      (let ((open #f)
            (count 0))
        (if (= (string-length s) 1)
            (begin
              (when (member (string-ref s 0)
                            (string->list (*erlang-open-parens*)))
                (set! open #t)
                (set! count (modulo paren-counter 6))
                (set! paren-counter (add1 paren-counter)))
              (when (member (string-ref s 0)
                            (string->list (*erlang-close-parens*)))
                (set! open #f)
                (set! paren-counter (sub1 paren-counter))
                (set! count (modulo paren-counter 6)))
              (if open
                  (format #f "<span class=\"paren~A\">~A<span class=\"~A\">"
                          (add1 count) s (*css-background-class*))
                  (format #f "</span>~A</span>"
                          s)))
            s))))
   (:word-ish
    (lambda (type s)
      (if (member s (*erlang-reserved-words*))
          (format #f "<span class=\"symbol\">~A</span>" s)
          s)))
   ))

(define *python-reserved-words*
  (make-parameter
   '("and"       "assert"        "break"         "class"         "continue"
     "def"       "del"           "elif"          "else"          "except"
     "exec"      "finally"       "for"           "from"          "global"
     "if"        "import"        "in"            "is"            "lambda"
     "not"       "or"            "pass"          "print"         "raise"
     "return"    "try"           "while"         "yield")))

(define-coloring-type :python "Python"
  :default-mode :normal
  :transitions
  ((:normal
    ((or
      (scan-any (*c-open-parens*))
      (scan-any (*c-close-parens*)))
     (set-mode :paren-ish
               :until (advance 1)
               :advancing #f)) 
    ((scan #\#)
     (set-mode :comment
	       :until (scan-any '(#\return #\newline))))
    ((scan #\")
     (set-mode :string
               :until (scan #\")))
    ((scan "\"\"\"")
     (set-mode :string
	       :until (scan "\"\"\"")))
    ((scan "'''")
     (set-mode :string
	       :until (scan "'''")))
    ((scan #\')
     (set-mode :string
	       :until (scan #\')))
    ((scan "@")
     (set-mode :decorator
	       :until (scan-any (*non-constituent*))
	       :advancing #f))
    ((scan "def")
     (set-mode :def
	       :until (scan-any '(#\: #\())
	       :advancing #f))
    ((scan "class")
     (set-mode :def
	       :until (scan-any '(#\: #\())
	       :advancing #f))
    ((scan-any (*c-begin-word*))
     (set-mode :word-ish
               :until (scan-any (*c-terminators*))
               :advancing #f)))
   (:string
    ((scan #\\)
     (set-mode :single-escape
               :until (advance 1)))))
  :formatter-variables ((paren-counter 0))
  :formatters
  ((:normal
    (lambda (type s)
      s))
   (:comment
    (lambda (type s)
      (format #f "<span class=\"comment\">~A</span>"
              s)))
   (:string
    (lambda (type s)
      (format #f "<span class=\"string\">~A</span>"
              s)))
   (:character
    (lambda (type s)
      (format #f "<span class=\"character\">~A</span>"
              s)))
   (:single-escape
    (lambda (type s)
      (call-formatter (cdr type) s)))
   (:paren-ish
    (lambda (type s)
      (let ((open #f)
            (count 0))
        (if (= (string-length s) 1)
            (begin
              (when (member (string-ref s 0) (string->list (*c-open-parens*)))
                (set! open #t)
                (set! count (modulo paren-counter 6))
                (set! paren-counter (add1 paren-counter)))
              (when (member (string-ref s 0) (string->list (*c-close-parens*)))
                (set! open #f)
                (set! paren-counter (sub1 paren-counter))
                (set! count (modulo paren-counter 6)))
              (if open
                  (format #f "<span class=\"paren~A\">~A<span class=\"~A\">"
                          (add1 count) s (*css-background-class*))
                  (format #f "</span>~A</span>"
                          s)))
            s))))
   (:def
    (lambda (type s)
      (format #f "<span class=\"special\">~A</span><span
class=\"keyword\">~A</span>"
              (substring/shared s 0 (string-index s #\space))
              (substring/shared s (string-index s #\space)))))
   (:decorator
    (lambda (type s)
      (format #f "<span class=\"symbol\">~A</span>" s)))
   (:word-ish
    (lambda (type s)
      (if (member s (*python-reserved-words*))
	  (format #f "<span class=\"symbol\">~A</span>"
		  s)
	  s)))))

(define *ruby-reserved-words*
  (make-parameter
   '("BEGIN"    "class"    "ensure"   "nil"      "self"     "when"
     "END"      "def"      "false"    "not"      "super"    "while"
     "alias"    "defined"  "for"      "or"       "then"     "yield"
     "and"      "do"       "if"       "redo"     "true"     "begin"
     "else"     "in"       "rescue"   "undef"    "break"    "elsif"
     "module"   "retry"    "unless"   "case"     "end"      "next"
     "return"   "until")))

(define *ruby-special-procs*
  (make-parameter
   '("include"  "require"  "lambda"   "proc"     "raise")))

(define-coloring-type :ruby "Ruby"
  :default-mode :normal
  :transitions
  (((:normal :in-list)
    ((scan #\()
     (set-mode :in-list
               :until (scan #\))))
    ((scan #\[)
     (set-mode :in-list
               :until (scan #\])))
    ((scan #\{)
     (set-mode :in-list
               :until (scan #\})))
    ((scan #\#)
     (set-mode :comment
	       :until (scan-any '(#\return #\newline))))
    ((scan ":\"")
     (set-mode :quasiquoted-symbol
               :until (scan #\")))
    ((scan ":\'")
     (set-mode :quoted-symbol
               :until (scan #\')))
    ((and (not (peek "::")) (scan #\: :not-preceded-by #\:))
     (set-mode :symbol
               :until (scan-any (*non-constituent*))
               :advancing #f))
    ((scan #\")
     (set-mode :quasi-string            ; For lack of a better term :)
               :until (scan #\")))
    ((scan #\')
     (set-mode :string
	       :until (scan #\')))
    ((scan "=begin")
     (set-mode :comment
	       :until (scan "=end")))
    ((scan "@")
     (set-mode :instance-var
	       :until (scan-any (*non-constituent*))
	       :advancing #f))
    ((scan-any (*c-begin-word*))
     (set-mode :word-ish
               :until (scan-any (*c-terminators*))
               :advancing #f)))
   ;; TODO: Add support for regexes. How to distinguish regex from division?
   ((:quasi-string :quasiquoted-symbol)
    ((scan "#{")
     ;; TODO: Find a way to let CSS know the "normal" within is interpolated
     (set-mode :normal
               :until (scan #\}))))
   ((:string  :quasi-string :quoted-symbol :quasiquoted-symbol)
    ((scan #\\)
     (set-mode :single-escape
               :until (advance 1)))))
  :formatter-variables ((paren-counter 0))
  :formatters
  ((:normal
    (lambda (type s)
      s))
   (:comment
    (lambda (type s)
      (format #f "<span class=\"comment\">~A</span>" s)))
   ((:string :quasi-string)
    (lambda (type s)
      (format #f "<span class=\"string\">~A</span>" s)))
   (:single-escape
    (lambda (type s)
      (call-formatter (cdr type) s)))
   ((:in-list)
    (lambda (type s)
      (letrec ((color-parens
                (lambda (s)
                  (let ((paren-pos (find identity
                                         (map (lambda (c)
                                                (string-index s c))
                                              (append (string->list
                                                       (*c-open-parens*))
                                                      (string->list
                                                       (*c-close-parens*)))))))
                    (if paren-pos
                        (let ((before-paren (substring s 0 paren-pos))
                              (after-paren (substring s (add1 paren-pos)))
                              (paren (string-ref s paren-pos))
                              (open #f)
                              (count 0))
                          (when (member paren (string->list (*c-open-parens*)))
                            (set! count (modulo paren-counter 6))
                            (set! paren-counter (add1 paren-counter))
                            (set! open #t))
                          (when (member paren (string->list (*c-close-parens*)))
                            (set! paren-counter (sub1 paren-counter)))
                          (if open
                              (format #f "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
                                      before-paren
                                      (add1 count)
                                      paren (*css-background-class*)
                                      (color-parens after-paren))
                              (format #f "~A</span>~C</span>~A"
                                      before-paren
                                      paren (color-parens after-paren))))
                        s)))))
        (color-parens s))))
   (:instance-var
    (lambda (type s)
      (format #f "<span class=\"special\">~A</span>" s)))
   ((:symbol :quasiquoted-symbol :quoted-symbol)
    (lambda (type s)
      (format #f "<span class=\"keyword\">~A</span>" s)))
   (:word-ish
    (lambda (type s)
      (if (or (member s (*ruby-reserved-words*))
              (member s (*ruby-special-procs*)))
	  (format #f "<span class=\"symbol\">~A</span>" s)
	  s)))))

(define *haskell-open-parens* (make-parameter "([{"))

(define *haskell-close-parens* (make-parameter ")]}"))

(define *haskell-in-word*
  (make-parameter
   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))

(define *haskell-begin-id*
  (make-parameter "abcdefghijklmnopqrstuvwxyz"))

(define *haskell-begin-cons*
  (make-parameter "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))

(define *haskell-in-symbol*
  (make-parameter "!#$%&*+./<=>?@\\^|-~:"))

(define *haskell-reserved-symbols*
  (make-parameter '(".." "::" "@" "~" "=" "-&gt;" "&lt;-" "|" "\\")))

(define *haskell-reserved-words*
  (make-parameter
   '("case" "class" "data" "default" "deriving" "do" "else" "if"
     "import" "in" "infix" "infixl" "infixr" "instance" "let" "module"
     "newtype" "of" "then" "type" "where")))

(define *haskell-non-constituent*
  (make-parameter
   '(#\space #\return #\tab #\newline #\{ #\} #\( #\) #\" #\[ #\])))

(define-coloring-type :haskell "Haskell"
  :default-mode :normal
  :transitions
  (((:normal)
    ((scan-any (*haskell-in-word*))
     (set-mode :identifier
	       :until (or (scan-any (*haskell-non-constituent*))
			  (scan-any (*haskell-in-symbol*)))
	       :advancing #f))
    ((scan "--")
     (set-mode :comment
	       :until (scan-any '(#\return #\newline))
	       :advancing #f))
    ((scan "{-")
     (set-mode :multi-comment
	       :until (scan "-}")))
    ((scan #\")
     (set-mode :string
	       :until (scan #\")))
    ((scan #\`)
     (set-mode :backquote
	       :until (scan #\`)))
    ((scan "'")
     (set-mode :char
	       :until (scan #\')))
    ((scan-any (*haskell-in-symbol*))
     (set-mode :symbol
	       :until (or (scan-any (*haskell-non-constituent*))
			  (scan-any (*haskell-in-word*))
			  (scan #\'))
	       :advancing #f))
    ((or (scan-any (*haskell-open-parens*))
	 (scan-any (*haskell-close-parens*)))
     (set-mode :parenlike
	       :until (advance 1)
	       :advancing #f))
    ((scan #\newline)
     (set-mode :newline
	       :until (advance 1)
	       :advancing #f)))
   ((:string)
    ((scan #\\)
     (set-mode :single-escape
               :until (advance 1))))
   ((:char)
    ((scan #\\)
     (set-mode :single-escape
               :until (advance 1)))))
  :formatter-variables
  ((paren-counter 0)
   (beginning-of-line #t))
  :formatter-after-hook
  (lambda ()
    (string-concatenate
     (list-tabulate paren-counter
                    (constantly "</span></span>"))))
  :formatters
  (((:normal)
    (lambda (type s)
      (cond (beginning-of-line
	     (set! beginning-of-line #f)
	     (if (and (> (string-length s) 0)
		      (char=? (string-ref s 0) #\space))
		 (string-append "&nbsp;" (substring/shared s 1))
                 s))
	    (else s))))
   ((:newline)
    (lambda (type s)
      (set! beginning-of-line #t)
      s))
   ((:backquote)
    (lambda (type s)
      (set! beginning-of-line #f)
      (if (string-index (*haskell-begin-cons*) (string-ref s 1))
	  (format #f "<span class=\"variable\">~A</span>"
		  s)
          (format #f "<span class=\"atom\">~A</span>"
                  s))))
   ((:comment :multi-comment)
    (lambda (type s)
      (set! beginning-of-line #f)
      (format #f "<span class=\"comment\">~A</span>"
	      s)))
   ((:string)
    (lambda (type s)
      (set! beginning-of-line #f)
      (format #f "<span class=\"string\">~A</span>"
	      s)))
   ((:char)
    (lambda (type s)
      (set! beginning-of-line #f)
      (format #f "<span class=\"character\">~A</span>"
	      s)))
   ((:identifier)
    (lambda (type s)
      (let ((output (cond ((string-index (*haskell-begin-cons*) (string-ref s 0))
                           (format #f "<span class=\"variable\">~A</span>" s))
                          ((member s (*haskell-reserved-words*))
                           (format #f "<span class=\"keyword\">~A</span>" s))
                          (beginning-of-line
                           (format #f "<span class=\"function\">~A</span>" s))
                          (else s))))
	(set! beginning-of-line #f)
        output)))
   ((:symbol)
    (lambda (type s)
      (set! beginning-of-line #f)
      (cond ((member s (*haskell-reserved-symbols*))
	     (format #f "<span class=\"keyword\">~A</span>" s))
	    ((char=? (string-ref s 0) #\:)
	     (format #f "<span class=\"variable\">~A</span>" s))
	    (else (format #f "<span class=\"atom\">~A</span>" s)))))
   ((:single-escape)
    (lambda (type s)
      (call-formatter (cdr type) s)))
   ((:parenlike)
    (lambda (type s)
      (set! beginning-of-line #f)
      (let ((open #f)
            (count 0))
        (if (= (string-length s) 1)
            (begin
              (when (member (string-ref s 0)
                            (string->list (*haskell-open-parens*)))
                (set! open #t)
                (set! count (modulo paren-counter 6))
                (set! paren-counter (add1 paren-counter)))
              (when (member (string-ref s 0)
                            (string->list (*haskell-close-parens*)))
                (set! open #f)
                (set! paren-counter (sub1 paren-counter))
                (set! count (modulo paren-counter 6)))
              (if open
                  (format #f "<span class=\"paren~A\">~A<span class=\"~A\">"
                          (add1 count) s (*css-background-class*))
                  (format #f "</span>~A</span>"
                          s)))
            s))))))

(define-coloring-type :diff "Unified Context Diff"
  :default-mode :first-char-on-line
  :transitions
  (((:first-char-on-line :normal :index :index-file :git-index :git-index-file :git-diff)
    ((scan #\newline)
     (set-mode :first-char-on-line)))
   ((:first-char-on-line)
    ((scan "@@")
     (set-mode :range-information
	       :until (scan "@@")))
    ((scan "===")
     (set-mode :separator
	       :until (scan #\newline)))
    ((scan "--- ")
     (set-mode :file-from
	       :until (scan #\newline)))
    ((scan "+++ ")
     (set-mode :file-to
	       :until (scan #\newline)))
    ((scan "diff --git ")
     (set-mode :git-diff
	       :until (scan #\newline)))
    ((scan "index ")
     (set-mode :git-index))
    ((scan "Index: ")
     (set-mode :index))
    ((scan #\-)
     (set-mode :diff-deleted
	       :until (scan #\newline)))
    ((scan #\+)
     (set-mode :diff-added
	       :until (scan #\newline))) 
    ((advance 1)
     (set-mode :normal)))
   ((:git-diff)
    ((scan "a/")
     (set-mode :git-index-file))
    ((scan "b/")
     (set-mode :git-index-file)))
   ((:git-index-file)
    ((scan #\space)
     (set-mode :git-diff)))
   ((:index)
    ((advance 1)
     (set-mode :index-file))))
  :formatters
  (((:normal :first-char-on-line)
    (lambda (type s)
      (format #f "<span class=\"diff-normal\">~A</span>" s)))
   ((:separator :file-from :file-to)
    (lambda (type s)
      (format #f "<span class=\"string\">~A</span>" s)))
   ((:range-information)
    (lambda (type s)
      (format #f "<span class=\"variable\">~A</span>" s)))
   ((:diff-added)
    (lambda (type s)
      (format #f "<span class=\"diff-added\">~A</span>" s)))
   ((:diff-deleted)
    (lambda (type s)
      (format #f "<span class=\"diff-deleted\">~A</span>" s)))
   ((:index :git-index :git-diff)
    (lambda (type s)
      (format #f "<span class=\"variable\">~A</span>" s)))
   ((:index-file :git-index-file)
    (lambda (type s)
      (format #f "<span class=\"symbol\">~A</span>" s)))))

#|-------------------- 0.2.2 |# "./colorize.meta" 310
((egg "colorize.egg")
 (synopsis "Colorize programming code as HTML")
 (category web)
 (author "Brian Mastenbrook, converted to Scheme by Peter Bex")
 (maintainer "Peter Bex")
 (doc-from-wiki)
 (license "MIT")
 (depends defstruct)
 (files "coloring-types.scm" "colorize.scm" "colorize.setup" "colorize.meta"))

#|-------------------- 0.2.2 |# "./colorize.scm" 18302
;;
;; This is a Chicken port of lisppaste's colorizing code
;; This version based on released lisppaste 2.3
;;
;; Copyright (c) 2010 Peter Bex
;; Copyright (c) 2003-2010 Brian Mastenbrook
;; 
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;
;; TODO:
;; * Implement lookup tables in coloring-types.scm
;; * SXML output?
;; * Export more so people can implement their own colorizers. Another module?
;; * Maybe extract the useful parsing stuff from this and make it into
;;    its own egg?  Then we could clean up this code a lot, too.
;;    I've done this port to benefit from the coloring types lisppaste has,
;;    not because the colorizing macro is so elegant ;)

(module colorize
  (html-colorize coloring-type-names coloring-type-exists?)

(import chicken scheme)
(use data-structures extras srfi-1 srfi-13 defstruct)

(define *coloring-types* (make-parameter '()))

(defstruct coloring-type
  default-mode
  transition-functions
  fancy-name
  term-formatter
  (formatter-after-hook (constantly ""))
  (parent-type #f)
  (abstract? #f))

(define (find-coloring-type* type)
  (and-let* ((make-type (alist-ref type (*coloring-types*))))
    (make-type)))

(define (find-coloring-type type)
  (let ((type (find-coloring-type* type)))
    (if (and type (coloring-type-abstract? type))
        (error "You can't use abstract coloring types directly")
        type)))

(define (coloring-type-names)
  (filter-map (lambda (t)
                (let ((type ((cdr t))))
                  (and (not (coloring-type-abstract? type))
                       (cons (car t) (coloring-type-fancy-name type)))))
              (*coloring-types*)))

(define (coloring-type-exists? name)
  (and-let* ((make-type (alist-ref name (*coloring-types*)))
             (type (make-type)))
    (not (coloring-type-abstract? type))))

(set! (setter find-coloring-type)
      (lambda (type new-value)
        (if new-value
            (let ((found (assoc type (*coloring-types*))))
              (if found
                  (set! (cdr found) new-value)
                  (*coloring-types*
                   (append (*coloring-types*)
                           (list (cons type new-value))))))
            (*coloring-types* (remove (lambda (t)
                                        (eq? (car t) type))
                                      *coloring-types*)))))

(define *scan-calls* (make-parameter 0))

(define *reset-position* (make-parameter #f))

(define-syntax with-scanning-functions*
  (syntax-rules ()
    ((_ (advance scan-any scan peek-any peek set-mode not-preceded-by)
        string-param position-place mode-place mode-wait-place body ...)
     (letrec ((advance (lambda (num)
                         (set! position-place (+ position-place num))
                         #t))
              (peek-any (lambda (items #!key not-preceded-by)
                          (*scan-calls* (add1 (*scan-calls*)))
                          (let* ((items (if (string? items)
                                            (string->list items)
                                            items))
                                 (not-preceded-by (if (char? not-preceded-by)
                                                      (string not-preceded-by)
                                                      not-preceded-by))
                                 (position position-place)
                                 (str string-param)
                                 (item
                                  (and
                                   (< position (string-length str))
                                   (find (lambda (item)
                                           #;(printf "looking for ~S in ~S starting at ~S~%"
                                                   item str position)
                                           (if (char? item)
                                               (char=? (string-ref str position)
                                                       item)
                                               (string-contains
                                                str item
                                                position
                                                (min (string-length str)
                                                     (+ position (string-length
                                                                  item))))))
                                         items))))
                            (when (char? item)
                              (set! item (string item)))
                            (if
                             (if item
                                 (if not-preceded-by
                                     (if (>= (- position (string-length not-preceded-by)) 0)
                                         (not (string=?
                                               (substring/shared
                                                str (- position (string-length not-preceded-by)) position)
                                               not-preceded-by))
                                         #t)
                                     #t)
                                 #f)
                             item
                             (begin
                               (when (*reset-position*)
                                 (set! position-place (*reset-position*)))
                               #f)))))
              (scan-any (lambda (items #!key not-preceded-by)
                          (let ((item (peek-any items :not-preceded-by not-preceded-by)))
                            (and item (advance (string-length item))))))
              (peek (lambda (item #!key not-preceded-by)
                      (peek-any (list item) :not-preceded-by not-preceded-by)))
              (scan (lambda (item #!key not-preceded-by)
                      (scan-any (list item) :not-preceded-by not-preceded-by))))
       (letrec-syntax ((set-mode
                        (syntax-rules (:until :advancing)
                          ((_ new-mode)
                           (set-mode new-mode :until #f :advancing #t))
                          ((_ new-mode :until until)
                           (set-mode new-mode :until until :advancing #t))
                          ((_ new-mode :advancing advancing)
                           (set-mode new-mode :until #f :advancing advancing))
                          ((_ new-mode :advancing advancing :until until)
                           ;; Swap order
                           (set-mode new-mode :until until :advancing advancing))
                          ((_ new-mode :until until :advancing advancing)
                           (begin
                             (set! mode-place new-mode)
                             (set! mode-wait-place
                                   (lambda (position)
                                     (parameterize ((*reset-position* position))
                                       (values until advancing)))))))))
         body ...)))))

(define-syntax with-scanning-functions
  (er-macro-transformer
   (lambda (exp ren cmp)
     `(,(ren 'with-scanning-functions*)
       ;; Unhygienic names:
       (advance scan-any scan peek-any peek set-mode not-preceded-by)
       . ,(cdr exp)))))

(define-syntax define-coloring-type*
  (syntax-rules ()
    ((_ ?name ?fancy-name ?abstract ?default-mode ((?mode ?table ...) ...)
        (?formatter ...) ?parent ((?formatter-variable ?formatter-value) ...)
        ?formatter-after-hook ?call-parent-formatter ?call-formatter)
     (set! (find-coloring-type '?name)
           (lambda ()
             (let ((parent-type
                    (or (find-coloring-type* '?parent)
                        (and '?parent
                             (error "No such coloring type: ~S" '?parent))))
                   (?formatter-variable ?formatter-value) ...)
               (make-coloring-type
                :fancy-name ?fancy-name
                :abstract? ?abstract
                :default-mode
                (or ?default-mode
                    (and parent-type (coloring-type-default-mode parent-type)))
                :parent-type parent-type
                :formatter-after-hook
                (lambda ()
                  (string-append
                   (?formatter-after-hook)
                   (if parent-type
                       ((coloring-type-formatter-after-hook parent-type))
                       "")))
                :term-formatter
                (lambda (term)
                  (letrec ((?call-parent-formatter
                            (lambda (#!optional (type (car term))
                                                (str (cdr term)))
                              (if parent-type
                                  ((coloring-type-term-formatter parent-type)
                                   (cons type str))
                                  str)))
                           (?call-formatter
                            (lambda (#!optional (type (car term))
                                                (str (cdr term)))
                              ((case (first type)
                                 ?formatter ...
                                 (else (lambda (type text)
                                         (?call-parent-formatter type text))))
                               type str))))
                    (?call-formatter)))
                :transition-functions
                (list (cons '?mode
                            (lambda (current-mode str position)
                              (let ((mode-wait (constantly #f))
                                    (position-foobage position))
                                (with-scanning-functions
                                 str position-foobage current-mode mode-wait
                                 (parameterize ((*reset-position* position))
                                   (cond ?table ...))
                                 (values position-foobage current-mode
                                         (lambda (new-position)
                                           ;; XXX: Should this be a LET?
                                           (set! position-foobage new-position)
                                           (receive (_ advance)
                                             (mode-wait position-foobage)
                                             (values position-foobage advance))))))))
                      ...))))))))

(define-for-syntax (maybe-keyword->symbol obj)
  (if (keyword? obj)
      (string->symbol (keyword->string obj))
      obj))

(define-syntax define-coloring-type
  (er-macro-transformer
   (lambda (exp ren cmp)
     `(,(ren 'define-coloring-type*)
       ;; Some hackery to "parse" keyword args in the macro call
        . ,(apply (lambda (name fancy-name #!key (abstract #f)
                                default-mode (transitions '())
                                (formatters '()) parent
                                (formatter-variables '())
                                (formatter-after-hook `(,(ren 'constantly) "")))
                    (list (maybe-keyword->symbol name) fancy-name abstract
                          default-mode transitions
                          ;; Scheme's case construct doesn't accept single values
                          (map (lambda (f)
                                 (if (not (pair? (car f)))
                                     (cons (list (car f)) (cdr f))
                                     f))
                               formatters)
                          (maybe-keyword->symbol parent)
                          formatter-variables formatter-after-hook
                          ;; Unhygienic names:
                          'call-parent-formatter 'call-formatter)) (cdr exp))))))

(define (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))))

(define (scan-string coloring-type str)
  (let* ((coloring-type-object
          (or (find-coloring-type coloring-type)
              (error (sprintf "No such coloring type: ~S" coloring-type))))
         (transitions (full-transition-table coloring-type-object))
         (result '())
         (low-bound 0)
         (current-mode (coloring-type-default-mode coloring-type-object))
         (mode-stack '())
         (current-wait (lambda _ (values #f #f)))
         (wait-stack '())
         (current-position 0))
    (call/cc ;; This shouldn't be needed but it's a straight translation from CL
     (lambda (return)
       (parameterize ((*scan-calls* 0))
         (let loop ((finish-current
                     (lambda (new-position new-mode new-wait action
                                           #!key (extend #t))
                       (let ((to (if extend new-position current-position)))
                         (when (> to low-bound)
                           (set! result
                                 (append result
                                         (list (cons (cons current-mode
                                                           mode-stack)
                                                     (substring/shared
                                                      str low-bound to))))))
                         (set! low-bound to)
                         (when (eq? action 'pop)
                           (set! mode-stack (cdr mode-stack))
                           (set! wait-stack (cdr wait-stack)))
                         (when (eq? action 'push)
                           (set! mode-stack (cons current-mode mode-stack))
                           (set! wait-stack (cons current-wait wait-stack)))
                         (set! current-mode new-mode)
                         (set! current-position new-position)
                         (set! current-wait new-wait))
                       #t)))
           (if (> current-position (string-length str))
               (begin
                 #;(format #t "Scan was called ~S times.~%"
                         (*scan-calls*))
                 (finish-current (string-length str) #f
                                 (lambda _ (values #f #f)) 'none)
                 (return result))
               (or (any (lambda (transition-info)
                          (and-let* ((transition-mode (car transition-info))
                                     ((or (eqv? transition-mode current-mode)
                                          (and (list? transition-mode)
                                               (member current-mode
                                                       transition-mode))))
                                     (do-transition! (cdr transition-info)))
                            (receive (new-position new-mode new-wait)
                              (do-transition! current-mode str current-position)
                              (and (> new-position current-position)
                                   (finish-current new-position new-mode
                                                   new-wait 'push
                                                   :extend #f)))))
                        transitions)
                   (receive (pos advance)
                     (current-wait current-position)
                     #;(format #t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position)
                     (and pos
                          (> pos current-position)
                          (finish-current (if advance
                                              pos
                                              current-position)
                                          (car mode-stack)
                                          (car wait-stack)
                                          'pop
                                          :extend advance)))
                   (begin
                     (set! current-position (add1 current-position))
                     #t))) ; #t return not necessary
           ;; Fugly CL loop macro. Should rewrite when this code works and
           ;; I understand what's really happening
           (loop finish-current)))))))

(define (format-scan coloring-type scan)
  (let* ((coloring-type-object
          (or (find-coloring-type coloring-type)
              (error (sprintf "No such coloring type: ~S" coloring-type))))
         (color-formatter (coloring-type-term-formatter coloring-type-object)))
    (string-append (string-concatenate (map color-formatter scan))
                   ((coloring-type-formatter-after-hook coloring-type-object)))))

;; From Spiffy:
(define (htmlize str)
  (string-translate* str '(("<" . "&lt;")    (">" . "&gt;")
                           ("\"" . "&quot;") ("'" . "&#x27;") ("&" . "&amp;"))))

(define (html-colorize coloring-type string)
  (format-scan coloring-type
               (map (lambda (p) (cons (car p) (htmlize (cdr p))))
                    (scan-string coloring-type string))))

(include "coloring-types.scm")
)

#|-------------------- 0.2.2 |# "./colorize.setup" 229
(compile -s -O2 -K prefix colorize.scm -j colorize)
(compile -s -O2 -K prefix colorize.import.scm)

(install-extension
  'colorize
  '("colorize.so" "colorize.import.so")
  `((version 0.2.2)
    (documentation "colorize.html")))