Scheme: ソースを色づけするスクリプトを書いてみた

何か実用的なものを作ってみようと思い書いてみた。
(実用的かどうかはよく分からんが・・・)

1: (require rnrs/hashtables-6)
2: (define keywords (make-eq-hashtable))
3: (define (set-keywords)
4:   (begin
5:     (hashtable-set! keywords 'define "<span style=\"color: blue;\">define</span>")
6:     (hashtable-set! keywords 'if "<span style=\"color: blue;\">if</span>")
7:     (hashtable-set! keywords 'let "<span style=\"color: blue;\">let</span>")
8:     (hashtable-set! keywords 'letrec "<span style=\"color: blue;\">letrec</span>")
9:     (hashtable-set! keywords 'lambda "<span style=\"color: blue;\">lambda</span>")
10:     (hashtable-set! keywords 'cond "<span style=\"color: blue;\">cond</span>")))
11: (define (keyword? key)
12:   (hashtable-contains? keywords key))
13: (define (highlighted-keyword key)
14:   (hashtable-ref keywords key ""))
15: ; string might be like this "(define",
16: ; this function should return like this -> "(<span style=\"color: blue;\">define</span>"
17: (define (has-tag? str)
18:   (let loop((strls (string->list str)))
19:     (cond ((null? strls) #f)
20:           ((char=? (car strls) #\<) #t) ; if the string has "<" it's must be tag(might be < procedure...)
21:           (else (loop (cdr strls))))))
22: (define (list->symbol ls)
23:   (string->symbol (list->string ls)))
24: (define (parse-keyword str)
25:   (if (has-tag? str)
26:       str ; if the string has tag, just return.
27:     (letrec ((ls (string->list str))
28:              (set ((lambda (l)
29:                     (let firstb((c (car l))
30:                                 (rest (cdr l))
31:                                 (ret '()))
32:                       (cond ((null? rest) (cons ret rest))
33:                             ((char=? c #\() (cons (append ret (list c)) rest))
34:                             (else (firstb (car rest) (cdr rest) (append ret (list c)))))))
35:                       ls)) ; blanket + space
36:              (br (car set))
37:              (rest (cdr set)))
38:             (if (null? rest) 
39:                 str ; only ( or spaces
40:               (let ((key (list->symbol rest)))
41:                 (if (keyword? key)
42:                     (string-append (list->string br) (highlighted-keyword key))
43:                   str))))))
44: 
45: (define (read-file file-name)
46:   (with-input-from-file
47:    file-name
48:    (lambda ()
49:      (let loop((ls '())
50:                (c (read-char)))
51:        (if (eof-object? c)
52:            (reverse ls)
53:          (loop (cons c ls)(read-char)))))))
54: 
55: (define (last-char str)
56:   (let ((l (string-length str)))
57:     (if (= l 0)
58:         (integer->char 0)
59:       (string-ref str (- l 1)))))
60: 
61: (define (high-light str)
62:   (let ((ls (string->list str)))
63:     (if (null? ls)
64:         "" 
65:       (let loop((forward "")
66:                 (c (car ls))
67:                 (src (cdr ls))
68:                 (is-quoted #f)
69:                 (is-escape #f))
70:         (cond ((null? src) (string-append forward (string c)))
71:               ; escape begin
72:               ((char=? c #\&)
73:                (loop (string-append forward (string c)) (car src) (cdr src) is-quoted #t))
74:               ; escapse end
75:               ((and is-escape (char=? c #\;))
76:                (loop (string-append forward (string c)) (car src) (cdr src) is-quoted #f))
77:               ; quote
78:               ((and (char=? c #\") (not (char=? #\\ (last-char forward))))
79:                (cond ((and is-quoted) ; end quote
80:                       (loop (string-append forward (string c) "</span>") (car src) (cdr src) #f is-escape))
81:                      ((not is-quoted) ; begin quote
82:                       (loop (string-append forward "<span style=\"color: green;\">" (string c))
83:                         (car src) (cdr src) #t is-escape))
84:                      ; in quote
85:                      (else (loop (string-append forward (string c)) (car src) (cdr src) is-quoted is-escape))))
86:               ; comment
87:               ((and (not is-quoted)
88:                     (not is-escape)
89:                     (not (char=? #\\ (last-char forward)))
90:                     (char=? c #\;))
91:                (string-append forward
92:                               "<span style=\"color: #006600; font-style: italic;\">" 
93:                               (string c)
94:                               (list->string src)
95:                               "</span>"))
96:               (else 
97:                (if (and (< 0 (string-length forward)) (char-whitespace? c)) ; if the charactor is whitespace
98:                    (begin
99:                      (set! forward (parse-keyword forward)); check if the string is keyword
100:                      (loop (string-append forward (string c))(car src) (cdr src) is-quoted is-escape))
101:                  (loop (string-append forward (string c))(car src) (cdr src) is-quoted is-escape))))))))
102: 
103: (define (make-line str num)
104:   (string-append "<div><span style=\"display: inline-block; width: 30px; font-weight: bold; text-align: right;\">" 
105:                  (number->string num)
106:                  "</span>: " 
107:                  (high-light str)
108:                  "</div>"))
109: 
110: (define (escape c)
111:   (cond ((char=? #\< c) "<")
112:         ((char=? #\> c) ">")
113:         ;((char=? #\" c) """)
114:         ;((char=? #\& c) "&")
115:         (else (string c))))
116: 
117: (define (read-line source)
118:   (if (null? source)
119:       '()
120:     (let line((ret (cons "" (cdr source)))
121:               (c (escape (car source))))
122:       (cond ((null? (cdr ret)) ret)
123:             ((string=? "\r" c) (line (cons (car ret)(cddr ret)) (escape (cadr ret))))
124:             ((string=? "\n" c) ret)
125:             ((string=? "\t" c) (line (cons (string-append (make-string 8 #\Space)
126:                                                           (car ret))
127:                                            (cddr ret))
128:                                      (escape (cadr ret))))
129:             (else (line (cons (string-append (car ret) c)
130:                               (cddr ret))
131:                         (escape (cadr ret))))))))
132: 
133: (define (build-html contents)
134:   (define (build-itr contents)
135:     (let build((ret "")
136:                (line (read-line contents))
137:                (num 1))
138:       (if (null? line)
139:           ret
140:         (build (string-append ret (make-line (car line) num))
141:                (read-line (cdr line))
142:                (+ num 1)))))
143:   (string-append "<pre>" (build-itr contents) "</pre>"))
144: 
145: (define (main args)
146:   (if (null? args)
147:       (begin
148:         (display "usage: scm2html file-name")
149:         -1)
150:     (let ((contents (read-file args)))
151:       (set-keywords)
152:       (display (build-html contents))
153:       (newline))))
154: 
155: (main "scm2html.scm") ; test

長い上に汚い・・・っが、開き直ってさらしてみた。

仕様：
* 行番号付与
* コメント、文字列及びキーワード色づけ
* タブをスペースに変換。

既知の不具合：
ダブルクオート(文字列)の色づけ周りは大分怪しい。文字列の後ろになんか文字がないとタグがおかしくなる。(ブラウザで見る分には問題ないけど、HTMLとして不正になる)

Perlで作れば簡単なのに何やってんだろうとか思いながら作った。Schemeは文字列処理得意じゃないのかしら？
(正規表現使ってないからだと思うが・・・R6RSって正規表現サポートしてるのかな？)