source: project/release/4/colorize/trunk/coloring-types.scm @ 27134

Last change on this file since 27134 was 27134, checked in by sjamaan, 9 years ago

colorize: Add (initial version of) css language support

File size: 38.7 KB
Line 
1;; coloring-types.scm
2;; A direct port of coloring-types.lisp
3;; This version based on lisppaste CVS HEAD ** revision 1.35 **
4;;
5;; Currently lisppaste is not actively maintained. When and if that changes,
6;; please communicate changes and bugfixes here to lisppaste's maintainer
7;; so we can mutually benefit from improvements and new colorizers.
8
9(define *symbol-characters*
10  (make-parameter
11   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-:1234567890"))
12
13(define *non-constituent*
14  (make-parameter
15   '(#\space #\tab #\newline #\linefeed #\page #\return
16     #\" #\' #\( #\) #\, #\; #\` #\[ #\])))
17
18(define *special-forms*
19  (make-parameter
20   '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the"
21     "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*"
22     "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally"
23     "return-from" "setq" "multiple-value-call")))
24
25(define *common-macros*
26  (make-parameter
27   '("loop" "cond" "lambda")))
28
29(define *open-parens* (make-parameter '(#\()))
30(define *close-parens* (make-parameter '(#\))))
31
32(define *css-background-class* (make-parameter "default"))
33
34(define-coloring-type :lisp "Basic Lisp"
35  :default-mode :normal
36  :transitions
37  (((:normal :in-list)
38    ((or
39      (scan-any (*symbol-characters*))
40      (and (scan #\.) (scan-any (*symbol-characters*)))
41      (and (scan #\\) (advance 1)))
42     (set-mode :symbol
43               :until (scan-any (*non-constituent*))
44               :advancing #f))
45    ((scan "#\\")
46     (let ((count 0))
47       (set-mode :character
48                 :until (begin
49                          (set! count (add1 count))
50                          (if (> count 1)
51                              (scan-any (*non-constituent*))))
52                 :advancing #f)))
53    ((scan #\")
54     (set-mode :string
55               :until (scan #\")))
56    ((scan #\;)
57     (set-mode :comment
58               :until (scan #\newline)))
59    ((scan "#|")
60     (set-mode :multiline
61               :until (scan "|#")))
62    ((scan #\()
63     (set-mode :in-list
64               :until (scan #\)))))
65   (:multiline
66    ((scan "#|")
67     (set-mode :multiline
68               :until (scan "|#"))))
69   ((:symbol :escaped-symbol :string)
70    ((scan #\\)
71     (let ((count 0))
72       (set-mode :single-escaped
73                 :until (begin
74                          (set! count (add1 count))
75                          (if (< count 2)
76                              (advance 1))))))))
77  :formatter-variables
78  ((paren-counter 0))
79  :formatter-after-hook
80  (lambda ()
81    (string-concatenate
82     (list-tabulate paren-counter
83                    (constantly "</span></span>"))))
84  :formatters
85  (((:normal)
86    (lambda (type s)
87      s))
88   ((:in-list)
89    (lambda (type s)
90      (letrec ((color-parens
91                (lambda (s)
92                  (let ((paren-pos (find identity
93                                         (map (lambda (c)
94                                                (string-index s c))
95                                              (append (*open-parens*)
96                                                      (*close-parens*))))))
97                    (if paren-pos
98                        (let ((before-paren (substring s 0 paren-pos))
99                              (after-paren (substring s (add1 paren-pos)))
100                              (paren (string-ref s paren-pos))
101                              (open #f)
102                              (count 0))
103                          (when (member paren (*open-parens*))
104                            (set! count (modulo paren-counter 6))
105                            (set! paren-counter (add1 paren-counter))
106                            (set! open #t))
107                          (when (member paren (*close-parens*))
108                            (set! paren-counter (sub1 paren-counter)))
109                          (if open
110                              (format #f "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
111                                      before-paren
112                                      (add1 count)
113                                      paren (*css-background-class*)
114                                      (color-parens after-paren))
115                              (format #f "~A</span>~C</span>~A"
116                                      before-paren
117                                      paren (color-parens after-paren))))
118                        s)))))
119        (color-parens s))))
120   ((:symbol :escaped-symbol)
121    (lambda (type s)
122      (let* ((colon (string-index-right s #\:))
123             (new-s (or (and colon (string-drop-right s (add1 colon))) s)))
124        (cond
125          ((or
126            (member new-s (*common-macros*))
127            (member new-s (*special-forms*))
128            (any (lambda (e)
129                   (and (> (string-length new-s) (string-length e))
130                        (string-ci=? e (substring new-s 0 (string-length e)))))
131                 '("WITH-" "DEF")))
132           (format #f "<i><span class=\"symbol\">~A</span></i>" s))
133          ((and (> (string-length new-s) 2)
134                (char=? (string-ref new-s 0) #\*)
135                (char=? (string-ref new-s (sub1 (string-length new-s))) #\*))
136           (format #f "<span class=\"special\">~A</span>" s))
137          ((string-prefix? ":" s)
138           (format #f "<span class=\"keyword\">~A</span>" s))
139          (else s)))))
140   ((:comment :multiline)
141    (lambda (type s)
142      (format #f "<span class=\"comment\">~A</span>"
143              s)))
144   ((:character)
145    (lambda (type s)
146      (format #f "<span class=\"character\">~A</span>"
147              s)))
148   ((:string)
149    (lambda (type s)
150      (format #f "<span class=\"string\">~A</span>"
151              s)))
152   ((:single-escaped)
153    (lambda (type s)
154      (call-formatter (cdr type) s)))
155   ((:syntax-error)
156    (lambda (type s)
157      (format #f "<span class=\"syntaxerror\">~A</span>"
158              s)))))
159
160(define-coloring-type :scheme "Scheme"
161  :parent :lisp
162  :transitions
163  (((:normal :in-list)
164    ((scan "#:")
165     (set-mode :symbol
166               :until (scan-any (*non-constituent*))
167               :advancing #f))
168    ((scan "...")
169     (set-mode :symbol
170               :until (scan-any (*non-constituent*))
171               :advancing #f))
172    ((scan #\[)
173     (set-mode :in-list
174               :until (scan #\])))))
175  :formatters
176  (((:in-list)
177    (lambda (type s)
178      (parameterize ((*open-parens* (cons #\[ (*open-parens*)))
179                     (*close-parens* (cons #\] (*close-parens*))))
180        (call-parent-formatter))))
181   ((:symbol :escaped-symbol)
182    (lambda (type s)
183      (let ((result #f #;(if (find-package :r5rs-lookup)
184                         (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup))
185                                  s))))
186        (cond
187         (result
188          (format #f "<a href=\"~A\" class=\"symbol\">~A</a>"
189                  result (call-parent-formatter)))
190         ((or (string-prefix? "#:" s) (string-suffix? ":" s))
191          (format #f "<span class=\"keyword\">~A</span>" s))
192         (else (call-parent-formatter))))))))
193
194(define-coloring-type :elisp "Emacs Lisp"
195  :parent :lisp
196  :formatters
197  (((:symbol :escaped-symbol)
198    (lambda (type s)
199      (let ((result #f #;(if (find-package :elisp-lookup)
200                         (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup))
201                                  s))))
202        (if result
203            (format #f "<a href=\"~A\" class=\"symbol\">~A</a>"
204                    result (call-parent-formatter))
205            (call-parent-formatter)))))))
206
207(define-coloring-type :common-lisp "Common Lisp"
208  :parent :lisp
209  :transitions
210  (((:normal :in-list)
211    ((scan #\|)
212     (set-mode :escaped-symbol
213               :until (scan #\|)))))
214  :formatters 
215  (((:symbol :escaped-symbol)
216    (lambda (type s)
217      (let* ((colon (string-index-right s #\:))
218             (to-lookup (if colon (substring s (add1 colon)) s))
219             (result #f #;(if (find-package :clhs-lookup)
220                         (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup))
221                                  to-lookup))))
222        (if result
223            (format #f "<a href=\"~A\" class=\"symbol\">~A</a>"
224                    result (call-parent-formatter))
225            (call-parent-formatter)))))))
226
227(define *c-open-parens* (make-parameter "([{"))
228(define *c-close-parens* (make-parameter ")]}"))
229
230(define *c-reserved-words*
231  (make-parameter
232   '("auto"   "break"  "case"   "char"   "const"
233     "continue" "default" "do"     "double" "else"
234     "enum"   "extern" "float"  "for"    "goto"
235     "if"     "int"    "long"   "register" "return"
236     "short"  "signed" "sizeof" "static" "struct"
237     "switch" "typedef" "union"  "unsigned" "void"
238     "volatile" "while"  "__restrict" "_Bool")))
239
240(define *c-begin-word*
241  (make-parameter
242   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
243(define *c-terminators*
244  (make-parameter
245   '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+
246     #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#)))
247
248(define-coloring-type :basic-c "Basic C"
249  :default-mode :normal
250  :abstract #t
251  :transitions
252  ((:normal
253    ((scan-any (*c-begin-word*))
254     (set-mode :word-ish
255               :until (scan-any (*c-terminators*))
256               :advancing #f))
257    ((scan "/*")
258     (set-mode :comment
259               :until (scan "*/")))
260   
261    ((or
262      (scan-any (*c-open-parens*))
263      (scan-any (*c-close-parens*)))
264     (set-mode :paren-ish
265               :until (advance 1)
266               :advancing #f))
267    ((scan #\")
268     (set-mode :string
269               :until (scan #\")))
270    ((or (scan "'\\")
271         (scan #\'))
272     (set-mode :character
273               :until (advance 2))))
274   (:string
275    ((scan #\\)
276     (set-mode :single-escape
277               :until (advance 1)))))
278  :formatter-variables
279  ((paren-counter 0))
280  :formatter-after-hook
281  (lambda ()
282    (string-concatenate
283     (list-tabulate paren-counter
284                    (constantly "</span></span>"))))
285  :formatters
286  ((:normal
287    (lambda (type s)
288      s))
289   (:comment
290    (lambda (type s)
291      (format #f "<span class=\"comment\">~A</span>"
292              s)))
293   (:string
294    (lambda (type s)
295      (format #f "<span class=\"string\">~A</span>"
296              s)))
297   (:character
298    (lambda (type s)
299      (format #f "<span class=\"character\">~A</span>"
300              s)))
301   (:single-escape
302    (lambda (type s)
303      (call-formatter (cdr type) s)))
304   (:paren-ish
305    (lambda (type s)
306      (let ((open #f)
307            (count 0))
308        (if (= (string-length s) 1)
309            (begin
310              (when (member (string-ref s 0) (string->list (*c-open-parens*)))
311                (set! open #t)
312                (set! count (modulo paren-counter 6))
313                (set! paren-counter (add1 paren-counter)))
314              (when (member (string-ref s 0) (string->list (*c-close-parens*)))
315                (set! open #f)
316                (set! paren-counter (sub1 paren-counter))
317                (set! count (modulo paren-counter 6)))
318              (if open
319                  (format #f "<span class=\"paren~A\">~A<span class=\"~A\">"
320                          (add1 count) s (*css-background-class*))
321                  (format #f "</span>~A</span>"
322                          s)))
323            s))))
324   (:word-ish
325    (lambda (type s)
326      (if (member s (*c-reserved-words*))
327          (format #f "<span class=\"symbol\">~A</span>" s)
328          s)))
329   ))
330
331(define-coloring-type :c "C"
332  :parent :basic-c
333  :transitions
334  ((:normal
335    ((scan #\#)
336     (set-mode :preprocessor
337               :until (scan-any '(#\return #\newline))))
338    ((scan "//")
339     (set-mode :comment
340               :until (scan-any '(#\return #\newline))))))
341  :formatters
342  ((:preprocessor
343    (lambda (type s)
344      (format #f "<span class=\"special\">~A</span>" s)))))
345
346(define *c++-reserved-words*
347  (make-parameter
348   '("asm"          "auto"      "bool"     "break"            "case"
349     "catch"        "char"      "class"   "const"            "const_cast"
350     "continue"     "default"   "delete"   "do"               "double"
351     "dynamic_cast" "else"      "enum"     "explicit"         "export"
352     "extern"       "false"     "float"    "for"              "friend"
353     "goto"         "if"        "inline"   "int"              "long"
354     "mutable"      "namespace" "new"      "operator"         "private"
355     "protected"    "public"    "register" "reinterpret_cast" "return"
356     "short"        "signed"    "sizeof"   "static"           "static_cast"
357     "struct"       "switch"    "template" "this"             "throw"
358     "true"         "try"       "typedef"  "typeid"           "typename"
359     "union"        "unsigned"  "using"    "virtual"          "void"
360     "volatile"     "wchar_t"   "while")))
361
362(define-coloring-type :c++ "C++"
363  :parent :c
364  :transitions ()
365  :formatters
366  ((:word-ish
367    (lambda (type s)
368      (if (member s (*c++-reserved-words*))
369          (format #f "<span class=\"symbol\">~A</span>"
370                  s)
371          s)))))
372
373(define *java-reserved-words*
374  (make-parameter
375   '("abstract"     "boolean"      "break"    "byte"         "case" 
376     "catch"        "char"         "class"   "const"        "continue" 
377     "default"      "do"           "double"   "else"         "extends" 
378     "final"        "finally"      "float"    "for"          "goto" 
379     "if"           "implements"   "import"   "instanceof"   "int" 
380     "interface"    "long"         "native"   "new"          "package" 
381     "private"      "protected"    "public"   "return"       "short" 
382     "static"       "strictfp"     "super"    "switch"       "synchronized" 
383     "this"         "throw"        "throws"   "transient"    "try" 
384     "void"         "volatile"     "while")))
385
386(define-coloring-type :java "Java"
387  :parent :c++
388  :formatters
389  ((:word-ish
390    (lambda (type s)
391      (if (member s (*java-reserved-words*))
392          (format #f "<span class=\"symbol\">~A</span>"
393                  s)
394          s)))))
395
396(let ((terminate-next #f)) ;; TODO: Shouldn't this be a formatter-var?
397  (define-coloring-type :objective-c "Objective C"
398    :transitions
399    ((:normal
400      ((scan #\[)
401       (set-mode :begin-message-send
402                 :until (advance 1)
403                 :advancing #f))
404      ((scan #\])
405       (set-mode :end-message-send
406                 :until (advance 1)
407                 :advancing #f))
408      ((scan-any (*c-begin-word*))
409       (set-mode :word-ish
410                 :until (or
411                         (and (peek-any '(#\:))
412                              (set! terminate-next #t)
413                              #t)
414                         (and terminate-next (begin
415                                               (set! terminate-next #f)
416                                               (advance 1)))
417                         (scan-any (*c-terminators*)))
418                 :advancing #f)))
419     (:word-ish)) ; ??
420  :parent :c++
421  :formatter-variables ((is-keyword #f) (in-message-send #f))
422  :formatters
423  ((:begin-message-send
424    (lambda (type s)
425      (set! is-keyword #f)
426      (set! in-message-send #t)
427      (call-formatter (cons :paren-ish type) s)))
428   (:end-message-send
429    (lambda (type s)
430      (set! is-keyword #f)
431      (set! in-message-send #f)
432      (call-formatter (cons :paren-ish type) s)))
433   (:word-ish
434    (lambda (type s)
435      (let* ((result #f              #;(if (find-package :cocoa-lookup)
436                    (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup))
437                    s)))
438             (html
439              (if result
440                  (format #f "<a href=\"~A\" class=\"symbol\">~A</a>"
441                          result s)
442                  (if (member s (*c-reserved-words*))
443                      (format #f "<span class=\"symbol\">~A</span>" s)
444                      (if in-message-send
445                          (if is-keyword
446                              (format #f "<span class=\"keyword\">~A</span>" s)
447                              s)
448                          s)))))
449        (set! is-keyword (not is-keyword))
450        html))))))
451
452(define *erlang-open-parens* (make-parameter "([{"))
453(define *erlang-close-parens* (make-parameter ")]}"))
454
455(define *erlang-reserved-words*
456  (make-parameter
457   '("after" "andalso" "begin" "catch" "case" "end" "fun" "if" "of" "orelse"
458     "receive" "try" "when" "query" "is_atom" "is_binary" "is_constant"
459     "is_float" "is_function" "is_integer" "is_list" "is_number" "is_pid"
460     "is_port" "is_reference" "is_tuple" "is_record" "abs" "element" "float"
461     "hd" "tl" "length" "node" "round" "self" "size" "trunc" "alive" "apply"
462     "atom_to_list" "binary_to_list" "binary_to_term" "concat_binary"
463     "date" "disconnect_node" "erase" "exit" "float_to_list" "garbage_collect"
464     "get" "get_keys" "group_leader" "halt" "integer_to_list" "internal_bif"
465     "link" "list_to_atom" "list_to_binary" "list_to_float" "list_to_integer"
466     "make_ref" "node_link" "node_unlink" "notalive" "open_port" "pid_to_list"
467     "process_flag" "process_info" "processes" "put" "register" "registered"
468     "setelement" "spawn" "spawn_link" "split_binary" "statistics"
469     "term_to_binary" "time" "throw" "trace" "trunc" "tuple_to_list"
470     "unlink" "unregister" "whereis")))
471
472(define *erlang-begin-word*
473  (make-parameter
474   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
475(define *erlang-begin-fun* (make-parameter "abcdefghijklmnopqrstuvwxyz"))
476(define *erlang-begin-var* (make-parameter "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"))
477(define *erlang-terminators*
478  (make-parameter
479   '(#\space #\return #\tab #\newline #\. #\; #\, #\/ #\- #\* #\+
480     #\( #\) #\' #\" #\[ #\] #\< #\> #\{ #\})))
481
482(define-coloring-type :erlang "Erlang"
483  :default-mode :first-char-on-line
484  :transitions
485  (((:normal :paren-ish)
486    ((scan "%")
487     (set-mode :comment
488               :until (scan #\newline)))
489    ((scan-any (*erlang-begin-var*))
490     (set-mode :variable
491               :until (scan-any (*erlang-terminators*))
492               :advancing #f))
493    ((scan-any (*erlang-begin-word*))
494     (set-mode :word-ish
495               :until (scan-any (*erlang-terminators*))
496               :advancing #f))
497    ((or
498      (scan-any (*erlang-open-parens*))
499      (scan-any (*erlang-close-parens*)))
500     (set-mode :paren-ish
501               :until (advance 1)
502               :advancing #f))
503    ((scan #\")
504     (set-mode :string
505               :until (scan #\")))
506    ((scan #\')
507     (set-mode :atom
508               :until (scan #\')))
509    ((scan #\?)
510     (set-mode :macro
511               :until (scan-any (*erlang-terminators*))))
512    ((scan #\$)
513     (set-mode :char
514               :until (scan-any (*erlang-terminators*))))
515    ((scan #\newline)
516     (set-mode :first-char-on-line)))
517   
518   ((:function :attribute)
519    ((or
520      (scan-any (*erlang-open-parens*))
521      (scan-any (*erlang-close-parens*)))
522     (set-mode :paren-ish
523               :until (advance 1)
524               :advancing #f))
525    ((scan-any (*erlang-terminators*))
526     (set-mode :normal
527               :until (scan #\newline))))
528   
529   (:first-char-on-line
530    ((scan "%")
531     (set-mode :comment
532               :until (scan #\newline)))
533    ((scan-any (*erlang-begin-fun*))
534     (set-mode :function
535               :until (scan #\newline)
536               :advancing #f))
537    ((scan "-")
538     (set-mode :attribute
539               :until (scan #\newline)
540               :advancing #f))
541    ((scan #\newline)
542     (set-mode :first-char-on-line)) ; Stay in this mode
543    ((advance 1)
544     (set-mode :normal
545               :until (scan #\newline))))
546   (:string
547    ((scan #\\)
548     (set-mode :single-escape
549               :until (advance 1)))))
550  :formatter-variables
551  ((paren-counter 0))
552  :formatter-after-hook
553  (lambda ()
554    (string-concatenate
555     (list-tabulate paren-counter
556                    (constantly "</span></span>"))))
557  :formatters
558  (((:normal :first-char-on-line)
559    (lambda (type s)
560      s))
561   (:comment
562    (lambda (type s)
563      (format #f "<span class=\"comment\">~A</span>"
564              s)))
565   (:string
566    (lambda (type s)
567      (format #f "<span class=\"string\">~A</span>"
568              s)))
569   (:variable
570    (lambda (type s)
571      (format #f "<span class=\"variable\">~A</span>"
572              s)))
573   (:function
574    (lambda (type s)
575      (format #f "<span class=\"function\">~A</span>"
576              s)))
577   (:attribute
578    (lambda (type s)
579      (format #f "<span class=\"attribute\">~A</span>"
580              s)))
581   (:macro
582    (lambda (type s)
583      (format #f "<span class=\"macro\">~A</span>"
584              s)))
585   (:atom
586    (lambda (type s)
587      (format #f "<span class=\"atom\">~A</span>"
588              s)))
589   (:char
590    (lambda (type s)
591      (format #f "<span class=\"character\">~A</span>"
592              s)))
593   (:single-escape
594    (lambda (type s)
595      (call-formatter (cdr type) s)))
596   (:paren-ish
597    (lambda (type s)
598      (let ((open #f)
599            (count 0))
600        (if (= (string-length s) 1)
601            (begin
602              (when (member (string-ref s 0)
603                            (string->list (*erlang-open-parens*)))
604                (set! open #t)
605                (set! count (modulo paren-counter 6))
606                (set! paren-counter (add1 paren-counter)))
607              (when (member (string-ref s 0)
608                            (string->list (*erlang-close-parens*)))
609                (set! open #f)
610                (set! paren-counter (sub1 paren-counter))
611                (set! count (modulo paren-counter 6)))
612              (if open
613                  (format #f "<span class=\"paren~A\">~A<span class=\"~A\">"
614                          (add1 count) s (*css-background-class*))
615                  (format #f "</span>~A</span>"
616                          s)))
617            s))))
618   (:word-ish
619    (lambda (type s)
620      (if (member s (*erlang-reserved-words*))
621          (format #f "<span class=\"symbol\">~A</span>" s)
622          s)))
623   ))
624
625(define *python-reserved-words*
626  (make-parameter
627   '("and"       "assert"        "break"         "class"         "continue"
628     "def"       "del"           "elif"          "else"          "except"
629     "exec"      "finally"       "for"           "from"          "global"
630     "if"        "import"        "in"            "is"            "lambda"
631     "not"       "or"            "pass"          "print"         "raise"
632     "return"    "try"           "while"         "yield")))
633
634(define-coloring-type :python "Python"
635  :default-mode :normal
636  :transitions
637  ((:normal
638    ((or
639      (scan-any (*c-open-parens*))
640      (scan-any (*c-close-parens*)))
641     (set-mode :paren-ish
642               :until (advance 1)
643               :advancing #f)) 
644    ((scan #\#)
645     (set-mode :comment
646               :until (scan-any '(#\return #\newline))))
647    ((scan #\")
648     (set-mode :string
649               :until (scan #\")))
650    ((scan "\"\"\"")
651     (set-mode :string
652               :until (scan "\"\"\"")))
653    ((scan "'''")
654     (set-mode :string
655               :until (scan "'''")))
656    ((scan #\')
657     (set-mode :string
658               :until (scan #\')))
659    ((scan "@")
660     (set-mode :decorator
661               :until (scan-any (*non-constituent*))
662               :advancing #f))
663    ((scan "def")
664     (set-mode :def
665               :until (scan-any '(#\: #\())
666               :advancing #f))
667    ((scan "class")
668     (set-mode :def
669               :until (scan-any '(#\: #\())
670               :advancing #f))
671    ((scan-any (*c-begin-word*))
672     (set-mode :word-ish
673               :until (scan-any (*c-terminators*))
674               :advancing #f)))
675   (:string
676    ((scan #\\)
677     (set-mode :single-escape
678               :until (advance 1)))))
679  :formatter-variables ((paren-counter 0))
680  :formatters
681  ((:normal
682    (lambda (type s)
683      s))
684   (:comment
685    (lambda (type s)
686      (format #f "<span class=\"comment\">~A</span>"
687              s)))
688   (:string
689    (lambda (type s)
690      (format #f "<span class=\"string\">~A</span>"
691              s)))
692   (:character
693    (lambda (type s)
694      (format #f "<span class=\"character\">~A</span>"
695              s)))
696   (:single-escape
697    (lambda (type s)
698      (call-formatter (cdr type) s)))
699   (:paren-ish
700    (lambda (type s)
701      (let ((open #f)
702            (count 0))
703        (if (= (string-length s) 1)
704            (begin
705              (when (member (string-ref s 0) (string->list (*c-open-parens*)))
706                (set! open #t)
707                (set! count (modulo paren-counter 6))
708                (set! paren-counter (add1 paren-counter)))
709              (when (member (string-ref s 0) (string->list (*c-close-parens*)))
710                (set! open #f)
711                (set! paren-counter (sub1 paren-counter))
712                (set! count (modulo paren-counter 6)))
713              (if open
714                  (format #f "<span class=\"paren~A\">~A<span class=\"~A\">"
715                          (add1 count) s (*css-background-class*))
716                  (format #f "</span>~A</span>"
717                          s)))
718            s))))
719   (:def
720    (lambda (type s)
721      (format #f "<span class=\"special\">~A</span><span
722class=\"keyword\">~A</span>"
723              (substring/shared s 0 (string-index s #\space))
724              (substring/shared s (string-index s #\space)))))
725   (:decorator
726    (lambda (type s)
727      (format #f "<span class=\"symbol\">~A</span>" s)))
728   (:word-ish
729    (lambda (type s)
730      (if (member s (*python-reserved-words*))
731          (format #f "<span class=\"symbol\">~A</span>"
732                  s)
733          s)))))
734
735(define *ruby-reserved-words*
736  (make-parameter
737   '("BEGIN"    "class"    "ensure"   "nil"      "self"     "when"
738     "END"      "def"      "false"    "not"      "super"    "while"
739     "alias"    "defined"  "for"      "or"       "then"     "yield"
740     "and"      "do"       "if"       "redo"     "true"     "begin"
741     "else"     "in"       "rescue"   "undef"    "break"    "elsif"
742     "module"   "retry"    "unless"   "case"     "end"      "next"
743     "return"   "until")))
744
745(define *ruby-special-procs*
746  (make-parameter
747   '("include"  "require"  "lambda"   "proc"     "raise")))
748
749(define-coloring-type :ruby "Ruby"
750  :default-mode :normal
751  :transitions
752  (((:normal :in-list)
753    ((scan #\()
754     (set-mode :in-list
755               :until (scan #\))))
756    ((scan #\[)
757     (set-mode :in-list
758               :until (scan #\])))
759    ((scan #\{)
760     (set-mode :in-list
761               :until (scan #\})))
762    ((scan #\#)
763     (set-mode :comment
764               :until (scan-any '(#\return #\newline))))
765    ((scan ":\"")
766     (set-mode :quasiquoted-symbol
767               :until (scan #\")))
768    ((scan ":\'")
769     (set-mode :quoted-symbol
770               :until (scan #\')))
771    ((and (not (peek "::")) (scan #\: :not-preceded-by #\:))
772     (set-mode :symbol
773               :until (scan-any (*non-constituent*))
774               :advancing #f))
775    ((scan #\")
776     (set-mode :quasi-string            ; For lack of a better term :)
777               :until (scan #\")))
778    ((scan #\')
779     (set-mode :string
780               :until (scan #\')))
781    ((scan "=begin")
782     (set-mode :comment
783               :until (scan "=end")))
784    ((scan "@")
785     (set-mode :instance-var
786               :until (scan-any (*non-constituent*))
787               :advancing #f))
788    ((scan-any (*c-begin-word*))
789     (set-mode :word-ish
790               :until (scan-any (*c-terminators*))
791               :advancing #f)))
792   ;; TODO: Add support for regexes. How to distinguish regex from division?
793   ((:quasi-string :quasiquoted-symbol)
794    ((scan "#{")
795     ;; TODO: Find a way to let CSS know the "normal" within is interpolated
796     (set-mode :normal
797               :until (scan #\}))))
798   ((:string  :quasi-string :quoted-symbol :quasiquoted-symbol)
799    ((scan #\\)
800     (set-mode :single-escape
801               :until (advance 1)))))
802  :formatter-variables ((paren-counter 0))
803  :formatters
804  ((:normal
805    (lambda (type s)
806      s))
807   (:comment
808    (lambda (type s)
809      (format #f "<span class=\"comment\">~A</span>" s)))
810   ((:string :quasi-string)
811    (lambda (type s)
812      (format #f "<span class=\"string\">~A</span>" s)))
813   (:single-escape
814    (lambda (type s)
815      (call-formatter (cdr type) s)))
816   ((:in-list)
817    (lambda (type s)
818      (letrec ((color-parens
819                (lambda (s)
820                  (let ((paren-pos (find identity
821                                         (map (lambda (c)
822                                                (string-index s c))
823                                              (append (string->list
824                                                       (*c-open-parens*))
825                                                      (string->list
826                                                       (*c-close-parens*)))))))
827                    (if paren-pos
828                        (let ((before-paren (substring s 0 paren-pos))
829                              (after-paren (substring s (add1 paren-pos)))
830                              (paren (string-ref s paren-pos))
831                              (open #f)
832                              (count 0))
833                          (when (member paren (string->list (*c-open-parens*)))
834                            (set! count (modulo paren-counter 6))
835                            (set! paren-counter (add1 paren-counter))
836                            (set! open #t))
837                          (when (member paren (string->list (*c-close-parens*)))
838                            (set! paren-counter (sub1 paren-counter)))
839                          (if open
840                              (format #f "~A<span class=\"paren~A\">~C<span class=\"~A\">~A"
841                                      before-paren
842                                      (add1 count)
843                                      paren (*css-background-class*)
844                                      (color-parens after-paren))
845                              (format #f "~A</span>~C</span>~A"
846                                      before-paren
847                                      paren (color-parens after-paren))))
848                        s)))))
849        (color-parens s))))
850   (:instance-var
851    (lambda (type s)
852      (format #f "<span class=\"special\">~A</span>" s)))
853   ((:symbol :quasiquoted-symbol :quoted-symbol)
854    (lambda (type s)
855      (format #f "<span class=\"keyword\">~A</span>" s)))
856   (:word-ish
857    (lambda (type s)
858      (if (or (member s (*ruby-reserved-words*))
859              (member s (*ruby-special-procs*)))
860          (format #f "<span class=\"symbol\">~A</span>" s)
861          s)))))
862
863(define *haskell-open-parens* (make-parameter "([{"))
864
865(define *haskell-close-parens* (make-parameter ")]}"))
866
867(define *haskell-in-word*
868  (make-parameter
869   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"))
870
871(define *haskell-begin-id*
872  (make-parameter "abcdefghijklmnopqrstuvwxyz"))
873
874(define *haskell-begin-cons*
875  (make-parameter "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
876
877(define *haskell-in-symbol*
878  (make-parameter "!#$%&*+./<=>?@\\^|-~:"))
879
880(define *haskell-reserved-symbols*
881  (make-parameter '(".." "::" "@" "~" "=" "-&gt;" "&lt;-" "|" "\\")))
882
883(define *haskell-reserved-words*
884  (make-parameter
885   '("case" "class" "data" "default" "deriving" "do" "else" "if"
886     "import" "in" "infix" "infixl" "infixr" "instance" "let" "module"
887     "newtype" "of" "then" "type" "where")))
888
889(define *haskell-non-constituent*
890  (make-parameter
891   '(#\space #\return #\tab #\newline #\{ #\} #\( #\) #\" #\[ #\])))
892
893(define-coloring-type :haskell "Haskell"
894  :default-mode :normal
895  :transitions
896  (((:normal)
897    ((scan-any (*haskell-in-word*))
898     (set-mode :identifier
899               :until (or (scan-any (*haskell-non-constituent*))
900                          (scan-any (*haskell-in-symbol*)))
901               :advancing #f))
902    ((scan "--")
903     (set-mode :comment
904               :until (scan-any '(#\return #\newline))
905               :advancing #f))
906    ((scan "{-")
907     (set-mode :multi-comment
908               :until (scan "-}")))
909    ((scan #\")
910     (set-mode :string
911               :until (scan #\")))
912    ((scan #\`)
913     (set-mode :backquote
914               :until (scan #\`)))
915    ((scan "'")
916     (set-mode :char
917               :until (scan #\')))
918    ((scan-any (*haskell-in-symbol*))
919     (set-mode :symbol
920               :until (or (scan-any (*haskell-non-constituent*))
921                          (scan-any (*haskell-in-word*))
922                          (scan #\'))
923               :advancing #f))
924    ((or (scan-any (*haskell-open-parens*))
925         (scan-any (*haskell-close-parens*)))
926     (set-mode :parenlike
927               :until (advance 1)
928               :advancing #f))
929    ((scan #\newline)
930     (set-mode :newline
931               :until (advance 1)
932               :advancing #f)))
933   ((:string)
934    ((scan #\\)
935     (set-mode :single-escape
936               :until (advance 1))))
937   ((:char)
938    ((scan #\\)
939     (set-mode :single-escape
940               :until (advance 1)))))
941  :formatter-variables
942  ((paren-counter 0)
943   (beginning-of-line #t))
944  :formatter-after-hook
945  (lambda ()
946    (string-concatenate
947     (list-tabulate paren-counter
948                    (constantly "</span></span>"))))
949  :formatters
950  (((:normal)
951    (lambda (type s)
952      (cond (beginning-of-line
953             (set! beginning-of-line #f)
954             (if (and (> (string-length s) 0)
955                      (char=? (string-ref s 0) #\space))
956                 (string-append "&nbsp;" (substring/shared s 1))
957                 s))
958            (else s))))
959   ((:newline)
960    (lambda (type s)
961      (set! beginning-of-line #t)
962      s))
963   ((:backquote)
964    (lambda (type s)
965      (set! beginning-of-line #f)
966      (if (string-index (*haskell-begin-cons*) (string-ref s 1))
967          (format #f "<span class=\"variable\">~A</span>"
968                  s)
969          (format #f "<span class=\"atom\">~A</span>"
970                  s))))
971   ((:comment :multi-comment)
972    (lambda (type s)
973      (set! beginning-of-line #f)
974      (format #f "<span class=\"comment\">~A</span>"
975              s)))
976   ((:string)
977    (lambda (type s)
978      (set! beginning-of-line #f)
979      (format #f "<span class=\"string\">~A</span>"
980              s)))
981   ((:char)
982    (lambda (type s)
983      (set! beginning-of-line #f)
984      (format #f "<span class=\"character\">~A</span>"
985              s)))
986   ((:identifier)
987    (lambda (type s)
988      (let ((output (cond ((string-index (*haskell-begin-cons*) (string-ref s 0))
989                           (format #f "<span class=\"variable\">~A</span>" s))
990                          ((member s (*haskell-reserved-words*))
991                           (format #f "<span class=\"keyword\">~A</span>" s))
992                          (beginning-of-line
993                           (format #f "<span class=\"function\">~A</span>" s))
994                          (else s))))
995        (set! beginning-of-line #f)
996        output)))
997   ((:symbol)
998    (lambda (type s)
999      (set! beginning-of-line #f)
1000      (cond ((member s (*haskell-reserved-symbols*))
1001             (format #f "<span class=\"keyword\">~A</span>" s))
1002            ((char=? (string-ref s 0) #\:)
1003             (format #f "<span class=\"variable\">~A</span>" s))
1004            (else (format #f "<span class=\"atom\">~A</span>" s)))))
1005   ((:single-escape)
1006    (lambda (type s)
1007      (call-formatter (cdr type) s)))
1008   ((:parenlike)
1009    (lambda (type s)
1010      (set! beginning-of-line #f)
1011      (let ((open #f)
1012            (count 0))
1013        (if (= (string-length s) 1)
1014            (begin
1015              (when (member (string-ref s 0)
1016                            (string->list (*haskell-open-parens*)))
1017                (set! open #t)
1018                (set! count (modulo paren-counter 6))
1019                (set! paren-counter (add1 paren-counter)))
1020              (when (member (string-ref s 0)
1021                            (string->list (*haskell-close-parens*)))
1022                (set! open #f)
1023                (set! paren-counter (sub1 paren-counter))
1024                (set! count (modulo paren-counter 6)))
1025              (if open
1026                  (format #f "<span class=\"paren~A\">~A<span class=\"~A\">"
1027                          (add1 count) s (*css-background-class*))
1028                  (format #f "</span>~A</span>"
1029                          s)))
1030            s))))))
1031
1032(define-coloring-type :diff "Unified Context Diff"
1033  :default-mode :first-char-on-line
1034  :transitions
1035  (((:first-char-on-line :normal :index :index-file :git-index :git-index-file :git-diff)
1036    ((scan #\newline)
1037     (set-mode :first-char-on-line)))
1038   ((:first-char-on-line)
1039    ((scan "@@")
1040     (set-mode :range-information
1041               :until (scan "@@")))
1042    ((scan "===")
1043     (set-mode :separator
1044               :until (scan #\newline)))
1045    ((scan "--- ")
1046     (set-mode :file-from
1047               :until (scan #\newline)))
1048    ((scan "+++ ")
1049     (set-mode :file-to
1050               :until (scan #\newline)))
1051    ((scan "diff --git ")
1052     (set-mode :git-diff
1053               :until (scan #\newline)))
1054    ((scan "index ")
1055     (set-mode :git-index))
1056    ((scan "Index: ")
1057     (set-mode :index))
1058    ((scan #\-)
1059     (set-mode :diff-deleted
1060               :until (scan #\newline)))
1061    ((scan #\+)
1062     (set-mode :diff-added
1063               :until (scan #\newline))) 
1064    ((advance 1)
1065     (set-mode :normal)))
1066   ((:git-diff)
1067    ((scan "a/")
1068     (set-mode :git-index-file))
1069    ((scan "b/")
1070     (set-mode :git-index-file)))
1071   ((:git-index-file)
1072    ((scan #\space)
1073     (set-mode :git-diff)))
1074   ((:index)
1075    ((advance 1)
1076     (set-mode :index-file))))
1077  :formatters
1078  (((:normal :first-char-on-line)
1079    (lambda (type s)
1080      (format #f "<span class=\"diff-normal\">~A</span>" s)))
1081   ((:separator :file-from :file-to)
1082    (lambda (type s)
1083      (format #f "<span class=\"string\">~A</span>" s)))
1084   ((:range-information)
1085    (lambda (type s)
1086      (format #f "<span class=\"variable\">~A</span>" s)))
1087   ((:diff-added)
1088    (lambda (type s)
1089      (format #f "<span class=\"diff-added\">~A</span>" s)))
1090   ((:diff-deleted)
1091    (lambda (type s)
1092      (format #f "<span class=\"diff-deleted\">~A</span>" s)))
1093   ((:index :git-index :git-diff)
1094    (lambda (type s)
1095      (format #f "<span class=\"variable\">~A</span>" s)))
1096   ((:index-file :git-index-file)
1097    (lambda (type s)
1098      (format #f "<span class=\"symbol\">~A</span>" s)))))
1099
1100(define *css-begin-word*
1101  (make-parameter
1102   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
1103(define *css-terminators*
1104  (make-parameter
1105   '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+
1106     #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\# #\!)))
1107
1108(define-coloring-type :css "Cascading Style Sheets"
1109  :default-mode :normal
1110  :transitions
1111  (((:normal :ruleset)
1112    ((scan #\@)
1113     (set-mode :at-keyword
1114               :until (scan-any (*css-terminators*))
1115               :advancing #f))
1116    ((scan #\{)
1117     (set-mode :ruleset
1118               :until (scan #\})))
1119    ((scan "/*")
1120     (set-mode :comment
1121               :until (scan "*/")))
1122    ((scan #\")
1123     (set-mode :string
1124               :until (scan #\"))))
1125   (:string
1126    ((scan #\\)
1127     (set-mode :single-escape
1128               :until (advance 1))))
1129   (:ruleset
1130    ((scan #\!)
1131     (set-mode :exclamation
1132               :until (scan-any (*css-terminators*))
1133               :advancing #f))
1134    ((scan-any (*css-begin-word*))
1135     (set-mode :property
1136               :until (scan #\:)
1137               :advancing #f))
1138    ((scan #\:)
1139     (set-mode :value
1140               :until (scan-any ";}!")
1141               :advancing #f))))
1142  :formatters
1143  (((:normal :ruleset :value)
1144    (lambda (type s) s))
1145   (:property
1146    (lambda (type s)
1147      (format #f "<span class=\"variable\">~A</span>" s)))
1148   (:comment
1149    (lambda (type s)
1150      (format #f "<span class=\"comment\">~A</span>" s)))
1151   (:string
1152    (lambda (type s)
1153      (format #f "<span class=\"string\">~A</span>" s)))
1154   (:single-escape
1155    (lambda (type s)
1156      (call-formatter (cdr type) s)))
1157   (:at-keyword
1158    (lambda (type s)
1159      (format #f "<span class=\"keyword\">~A</span>" s)))
1160   (:exclamation
1161    (lambda (type s)
1162      (format #f "<span class=\"special\">~A</span>" s)))))
Note: See TracBrowser for help on using the repository browser.