;; coloring-types.scm
;; A direct port of coloring-types.lisp
;; This version based on lisppaste CVS HEAD ** revision 1.35 **
;;
;; Currently lisppaste is not actively maintained. When and if that changes,
;; please communicate changes and bugfixes here to lisppaste's maintainer
;; so we can mutually benefit from improvements and new colorizers.

(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 :normal
  :transitions
  (((:normal :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))
    ((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 #\)))))
   (:multiline
    ((scan "#|")
     (set-mode :multiline
               :until (scan "|#"))))
   ((:symbol :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)
    (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))
          ((string-prefix? ":" s)
           (format #f "<span class=\"keyword\">~A</span>" s))
          (else 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 :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))))
        (cond
         (result
          (format #f "<a href=\"~A\" class=\"symbol\">~A</a>"
                  result (call-parent-formatter)))
         ((or (string-prefix? "#:" s) (string-suffix? ":" s))
          (format #f "<span class=\"keyword\">~A</span>" s))
         (else (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)
                              #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))
    ((scan #\newline)
     (set-mode :first-char-on-line)) ; Stay in this mode
    ((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)))))

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

(define-coloring-type :css "Cascading Style Sheets"
  :default-mode :normal
  :transitions
  (((:normal :ruleset :value)
    ((scan #\@)
     (set-mode :at-keyword
               :until (scan-any (*css-terminators*))
               :advancing #f))
    ((scan #\{)
     (set-mode :ruleset
               :until (scan #\})))
    ((scan "/*")
     (set-mode :comment
               :until (scan "*/")))
    ((scan #\")
     (set-mode :string
               :until (scan #\"))))
   (:string
    ((scan #\\)
     (set-mode :single-escape
               :until (advance 1))))
   (:ruleset
    ((scan #\!)
     (set-mode :exclamation
               :until (scan-any (*css-terminators*))
               :advancing #f))
    ((scan-any (*css-begin-word*))
     (set-mode :property
               :until (scan #\:)
               :advancing #f))
    ((scan #\:)
     (set-mode :value
               :until (scan-any ";}!")
               :advancing #f))))
  :formatters
  (((:normal :ruleset :value)
    (lambda (type s) s))
   (:property
    (lambda (type s)
      (format #f "<span class=\"variable\">~A</span>" 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)))
   (:single-escape
    (lambda (type s)
      (call-formatter (cdr type) s)))
   (:at-keyword
    (lambda (type s)
      (format #f "<span class=\"keyword\">~A</span>" s)))
   (:exclamation
    (lambda (type s)
      (format #f "<span class=\"special\">~A</span>" s)))))

(define *xml-begin-word*
  (make-parameter
   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ:_"))

(define *xml-non-constituent*
  (make-parameter
   '(#\space #\return #\tab #\newline #\< #\> #\" #\/ #\=)))

;; TODO: Figure out if we can do "paren bouncing" for XML.
;; Might be too tricky, so let's not for now.
(define-coloring-type :xml "Extensible Markup Language"
  :default-mode :normal
  :transitions
  (((:normal)
    ((scan "<?")
     (set-mode :pi
               :until (scan "?>")))
    ((scan "<!--")
     (set-mode :comment
               :until (scan "-->")))
    ((scan "</")
     (set-mode :end-tag
               :until (scan #\>)))
    ((scan #\<)
     (set-mode :start-tag
               :until (scan #\>))))
   ((:normal :string)
    ((scan #\&)
     (set-mode :entity
               :until (scan #\;))))
   ((:start-tag :end-tag)
    ((scan-any (*xml-begin-word*))
     (set-mode :tag-name
               :until (scan-any (*xml-non-constituent*))
               :advancing #f)))
   (:start-tag
    ((and (not (peek #\>)) (advance 1))
     (set-mode :attributes
               :until (scan #\>)
               :advancing #f)))
   (:attributes
    ((scan-any (*xml-begin-word*))
     (set-mode :attribute-name
               :until (scan-any (*xml-non-constituent*))
               :advancing #f))
    ((scan #\')
     (set-mode :string
               :until (scan #\')))
    ((scan #\")
     (set-mode :string
               :until (scan #\")))))
  ;; TODO: Add support for CDATA, ENTITY and other "obscure" things :)
  :formatters
  (((:normal :attributes)
    (lambda (type s) s))
   ((:tag-name :attribute-name)
    (lambda (type s)
      (format #f "<span class=\"variable\">~A</span>" s)))
   (:pi
    (lambda (type s)
      (format #f "<span class=\"keyword\">~A</span>" 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)))
   (:entity
    (lambda (type s)
      (format #f "<span class=\"character\">~A</span>" s)))))

;; So far, nothing special.  We might want to highlight
;; recognised tags specially?
(define-coloring-type :xhtml "Extensible HyperText Markup Language" :parent :xml)

;; This should really inherit from SGML...
(define-coloring-type :html "HyperText Markup Language" :parent :xml)