;; 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 ""))))
: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~C~A"
before-paren
(add1 count)
paren (*css-background-class*)
(color-parens after-paren))
(format #f "~A~C~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 "~A" 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 "~A" s))
((string-prefix? ":" s)
(format #f "~A" s))
(else s)))))
((:comment :multiline)
(lambda (type s)
(format #f ""
s)))
((:character)
(lambda (type s)
(format #f "~A"
s)))
((:string)
(lambda (type s)
(format #f "~A"
s)))
((:single-escaped)
(lambda (type s)
(call-formatter (cdr type) s)))
((:syntax-error)
(lambda (type s)
(format #f "~A"
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"
result (call-parent-formatter)))
((or (string-prefix? "#:" s) (string-suffix? ":" s))
(format #f "~A" 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"
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"
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 ""))))
:formatters
((:normal
(lambda (type s)
s))
(:comment
(lambda (type s)
(format #f ""
s)))
(:string
(lambda (type s)
(format #f "~A"
s)))
(:character
(lambda (type s)
(format #f "~A"
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 "~A"
(add1 count) s (*css-background-class*))
(format #f "~A"
s)))
s))))
(:word-ish
(lambda (type s)
(if (member s (*c-reserved-words*))
(format #f "~A" 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 "~A" 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 "~A"
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 "~A"
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"
result s)
(if (member s (*c-reserved-words*))
(format #f "~A" s)
(if in-message-send
(if is-keyword
(format #f "~A" 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 ""))))
:formatters
(((:normal :first-char-on-line)
(lambda (type s)
s))
(:comment
(lambda (type s)
(format #f ""
s)))
(:string
(lambda (type s)
(format #f "~A"
s)))
(:variable
(lambda (type s)
(format #f "~A"
s)))
(:function
(lambda (type s)
(format #f "~A"
s)))
(:attribute
(lambda (type s)
(format #f "~A"
s)))
(:macro
(lambda (type s)
(format #f "~A"
s)))
(:atom
(lambda (type s)
(format #f "~A"
s)))
(:char
(lambda (type s)
(format #f "~A"
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 "~A"
(add1 count) s (*css-background-class*))
(format #f "~A"
s)))
s))))
(:word-ish
(lambda (type s)
(if (member s (*erlang-reserved-words*))
(format #f "~A" 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 ""
s)))
(:string
(lambda (type s)
(format #f "~A"
s)))
(:character
(lambda (type s)
(format #f "~A"
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 "~A"
(add1 count) s (*css-background-class*))
(format #f "~A"
s)))
s))))
(:def
(lambda (type s)
(format #f "~A~A"
(substring/shared s 0 (string-index s #\space))
(substring/shared s (string-index s #\space)))))
(:decorator
(lambda (type s)
(format #f "~A" s)))
(:word-ish
(lambda (type s)
(if (member s (*python-reserved-words*))
(format #f "~A"
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 "" s)))
((:string :quasi-string)
(lambda (type s)
(format #f "~A" 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~C~A"
before-paren
(add1 count)
paren (*css-background-class*)
(color-parens after-paren))
(format #f "~A~C~A"
before-paren
paren (color-parens after-paren))))
s)))))
(color-parens s))))
(:instance-var
(lambda (type s)
(format #f "~A" s)))
((:symbol :quasiquoted-symbol :quoted-symbol)
(lambda (type s)
(format #f "~A" s)))
(:word-ish
(lambda (type s)
(if (or (member s (*ruby-reserved-words*))
(member s (*ruby-special-procs*)))
(format #f "~A" 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 '(".." "::" "@" "~" "=" "->" "<-" "|" "\\")))
(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 ""))))
: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 " " (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 "~A"
s)
(format #f "~A"
s))))
((:comment :multi-comment)
(lambda (type s)
(set! beginning-of-line #f)
(format #f ""
s)))
((:string)
(lambda (type s)
(set! beginning-of-line #f)
(format #f "~A"
s)))
((:char)
(lambda (type s)
(set! beginning-of-line #f)
(format #f "~A"
s)))
((:identifier)
(lambda (type s)
(let ((output (cond ((string-index (*haskell-begin-cons*) (string-ref s 0))
(format #f "~A" s))
((member s (*haskell-reserved-words*))
(format #f "~A" s))
(beginning-of-line
(format #f "~A" 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 "~A" s))
((char=? (string-ref s 0) #\:)
(format #f "~A" s))
(else (format #f "~A" 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 "~A"
(add1 count) s (*css-background-class*))
(format #f "~A"
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 "~A" s)))
((:separator :file-from :file-to)
(lambda (type s)
(format #f "~A" s)))
((:range-information)
(lambda (type s)
(format #f "~A" s)))
((:diff-added)
(lambda (type s)
(format #f "~A" s)))
((:diff-deleted)
(lambda (type s)
(format #f "~A" s)))
((:index :git-index :git-diff)
(lambda (type s)
(format #f "~A" s)))
((:index-file :git-index-file)
(lambda (type s)
(format #f "~A" 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 "~A" s)))
(:comment
(lambda (type s)
(format #f "" s)))
(:string
(lambda (type s)
(format #f "~A" s)))
(:single-escape
(lambda (type s)
(call-formatter (cdr type) s)))
(:at-keyword
(lambda (type s)
(format #f "~A" s)))
(:exclamation
(lambda (type s)
(format #f "~A" 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 "")))
((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 "~A" s)))
(:pi
(lambda (type s)
(format #f "~A" s)))
(:comment
(lambda (type s)
(format #f "" s)))
(:string
(lambda (type s)
(format #f "~A" s)))
(:entity
(lambda (type s)
(format #f "~A" 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)