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

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

colorize: Explicitly return #t instead of relying on set!'s undefined return value.

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