2009-12-22

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って正規表現サポートしてるのかな?)

No comments:

Post a Comment