Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 14:49:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

updating highlight lib for sxml

Browse source
This commit is contained in:
Alex Shinn 2011-04-06 01:26:31 +09:00
parent d94baacd9a
commit 69b17aee0d
2 changed files with 303 additions and 343 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
lib/chibi/highlight.module
View file

@ -1,7 +1,7 @@
(module (chibi highlight) (module (chibi highlight)
(export highlight highlight-detect-language highlight-style (export highlight highlight-detect-language highlighter-for highlight-style
highlight-scheme highlight-c highlight-assembly) highlight-scheme highlight-c highlight-assembly)
(import-immutable (scheme)) (import-immutable (scheme))
(import (srfi 1) (chibi io) (chibi ast)) (import (srfi 1) (chibi io))
(include "highlight.scm")) (include "highlight.scm"))

428
lib/chibi/highlight.scm
View file

@ -12,26 +12,23 @@
(define (highlight-detect-language str) (define (highlight-detect-language str)
(cond (cond
((or (string-contains str "(define") ((guard (exn (else #f))
(string-contains str "(eval") (call-with-input-string str
(string-contains str "(set") (lambda (in) (do ((x #f (read in))) ((eof-object? x)))))
(string-contains str "(string") #t)
(string-contains str "(let")
(string-contains str "(lambda (")
)
'scheme) 'scheme)
((string-contains str "\tmovl\t")
'asm)
(else (else
'c))) 'c)))
(define (highlight source) (define (highlighter-for language)
(let ((str (if (string? source) source (port->string source)))) (case language
((case (highlight-detect-language str)
((scheme) highlight-scheme) ((scheme) highlight-scheme)
((asm) highlight-assembly) ((asm) highlight-assembly)
((c) highlight-c)) (else highlight-c)))
str)))
(define (highlight source)
(let ((str (if (string? source) source (port->string source))))
((highlighter-for (highlight-detect-language str)) str)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -49,7 +46,8 @@
(character . "#0055AA") (character . "#0055AA")
(syntaxerror . "#FF0000") (syntaxerror . "#FF0000")
(diff-deleted . "#5F2121") (diff-deleted . "#5F2121")
(diff-added . "#215F21")))) (diff-added . "#215F21")
)))
(define highlight-paren-styles (define highlight-paren-styles
;;'("#BAFFFF" "#FFCACA" "#FFFFBA" "#CACAFF" "#CAFFCA" "FFBAFF") ;;'("#BAFFFF" "#FFCACA" "#FFFFBA" "#CACAFF" "#CAFFCA" "FFBAFF")
@ -60,9 +58,14 @@
(append (append
(map (map
(lambda (x) (lambda (x)
(if (and (list? x) (= 3 (length x)))
(string-append (string-append
"." (symbol->string (car x)) " { color: " (cdr x) "." (symbol->string (car x)) " { color: " (cadr x)
"; background-color: inherit; }\n")) "; background-color: " (caddr x) "; }\n")
(string-append
"." (symbol->string (car x)) " { color: "
(if (pair? (cdr x)) (cadr x) (cdr x))
"; background-color: inherit; }\n")))
(cond ((assq (and (pair? theme) (car theme)) highlight-themes) => cdr) (cond ((assq (and (pair? theme) (car theme)) highlight-themes) => cdr)
(else (cdar highlight-themes)))) (else (cdar highlight-themes))))
(map (map
@ -73,21 +76,10 @@
"span.paren" (number->string i) "span.paren" (number->string i)
" { color: " s "; background-color: inherit; }\n")) " { color: " s "; background-color: inherit; }\n"))
highlight-paren-styles highlight-paren-styles
(cdr (iota (+ 1 (length highlight-paren-styles))))) (cdr (iota (+ 1 (length highlight-paren-styles))))))))
)))
(define (highlight-start class out) (define (highlight-class class x)
(display "<span class=\"" out) `(span (^ (class . ,class)) ,@(if (list? x) x (list x))))
(display class out)
(display "\">" out))
(define (highlight-end class out)
(display "</span>" out))
(define (highlight-class class str out)
(highlight-start class out)
(display str out)
(highlight-end class out))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -98,11 +90,12 @@
(reverse-list->string res)))) (reverse-list->string res))))
(define (read-to-whitespace in res) (define (read-to-whitespace in res)
(let ((c (peek-char in)))
(cond (cond
((char-whitespace? (peek-char in)) ((or (eof-object? c) (char-whitespace? c))
(reverse-list->string res)) (reverse-list->string res))
(else (else
(read-to-whitespace in (cons (read-char in) res))))) (read-to-whitespace in (cons (read-char in) res))))))
(define (read-escaped in term ls) (define (read-escaped in term ls)
(let ((c (read-char in))) (let ((c (read-char in)))
@ -115,9 +108,19 @@
;;((eqv? c #\\) (read-escaped in term (cons (read-char in) (cons c ls)))) ;;((eqv? c #\\) (read-escaped in term (cons (read-char in) (cons c ls))))
(else (read-escaped in term (cons c ls)))))) (else (read-escaped in term (cons c ls))))))
(define (read-to-eol in ls)
(let ((c (read-char in)))
(cond
((eof-object? c) (reverse-list->string ls))
((eqv? c #\newline) (reverse-list->string (cons c ls)))
(else (read-to-eol in (cons c ls))))))
(define (html-escape str) (define (html-escape str)
(call-with-input-string str (lambda (in) (read-escaped in #f '())))) (call-with-input-string str (lambda (in) (read-escaped in #f '()))))
(define (collect str res)
(if (pair? str) (cons (reverse-list->string str) res) res))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (highlight-scheme-delimiter? ch) (define (highlight-scheme-delimiter? ch)
@ -138,8 +141,9 @@
quote quasiquote unquote unquote-splicing error errorf quote quasiquote unquote unquote-splicing error errorf
define-syntax let-syntax letrec-syntax syntax-rules define-syntax let-syntax letrec-syntax syntax-rules
syntax-case parameterize module library require syntax-case parameterize module library require
require-extension use use-modules import export require-extension use use-modules import import-immutable
define-module select-module provide autoload define-module select-module provide autoload export
only except rename prefix include include-shared
condition-case guard cond-expand for with to by condition-case guard cond-expand for with to by
in-list in-lists in-string in-string-reverse in-list in-lists in-string in-string-reverse
in-vector in-vector-reverse in-file listing appending in-vector in-vector-reverse in-file listing appending
@ -148,57 +152,48 @@
(define (highlight-scheme source) (define (highlight-scheme source)
(let ((in (if (string? source) (open-input-string source) source))) (let ((in (if (string? source) (open-input-string source) source)))
(call-with-output-string
(lambda (out)
(define (read-to-eol ls)
(let ((c (read-char in)))
(cond
((eof-object? c) (reverse-list->string ls))
((eqv? c #\newline) (reverse-list->string (cons c ls)))
(else (read-to-eol (cons c ls))))))
(define (read-identifier ls) (define (read-identifier ls)
(let ((c (peek-char in))) (let ((c (peek-char in)))
(cond (cond
((highlight-scheme-delimiter? c) ((highlight-scheme-delimiter? c)
(string->symbol (reverse-list->string ls))) (reverse-list->string ls))
(else (else
(read-char in) (read-char in)
(read-identifier (cons c ls)))))) (read-identifier (cons c ls))))))
(define (hash-mark n) (define (hash-mark)
(let ((c (read-char in))) (let ((c (read-char in)))
(case c (case c
((#\;) ((#\;)
(highlight-start 'comment out) (highlight-class "comment" (highlight 0 '(#\; #\#) '())))
(highlight n)
(highlight-end 'comment out))
((#\\) ((#\\)
(let ((id (read-identifier (list (read-char in) #\\ #\#)))) (highlight-class "string"
(highlight-class 'string id out) (read-identifier (list (read-char in) #\\ #\#))))
(highlight n)))
(else (else
(write-char #\# out) "#"))))
(write-char c out) (define (highlight n str res)
(highlight n)))))
(define (highlight n)
(let ((c (read-char in))) (let ((c (read-char in)))
(if (eof-object? c) (if (eof-object? c)
#f (reverse (collect str res))
(case c (case c
((#\;) ((#\;)
(let lp ((ls '())) (let lp ((ls '()))
(let ((ls (cons (read-to-eol (list #\;)) ls))) (let ((ls (cons (read-to-eol in (list #\;)) ls)))
(cond (cond
((eqv? #\; (peek-char in)) ((eqv? #\; (peek-char in))
(lp ls)) (lp ls))
(else (else
(highlight-class 'comment (highlight n
(string-concatenate-reverse ls) '()
out) (cons (highlight-class
(highlight n)))))) "comment"
(string-concatenate-reverse ls))
(collect str res))))))))
((#\") ((#\")
(let ((str (read-escaped in #\" (list #\")))) (let ((s (read-escaped in #\" (list #\"))))
(highlight-class 'string str out) (highlight n
(highlight n))) '()
(cons (highlight-class "string" s)
(collect str res)))))
((#\() ((#\()
;;(highlight-start ;;(highlight-start
;; (string->symbol ;; (string->symbol
@ -207,58 +202,50 @@
;; (number->string ;; (number->string
;; (+ 1 (modulo n (length highlight-paren-styles)))))) ;; (+ 1 (modulo n (length highlight-paren-styles))))))
;;out) ;;out)
(write-char #\( out) (let ((res (collect (cons #\( str) res)))
(if (highlight-scheme-delimiter? (peek-char in)) (if (highlight-scheme-delimiter? (peek-char in))
(highlight (+ n 1)) (highlight (+ n 1) '() res)
(let ((id (read-identifier '()))) (let* ((id (read-identifier '()))
(sym (string->symbol id)))
(cond (cond
((highlight-scheme-definition? id) ((highlight-scheme-definition? sym)
(highlight-class 'keyword id out) (let* ((res (cons (read-whitespace in) res))
(display (read-whitespace in) out) (res (cons (highlight-class "keyword" id) res))
(if (eqv? #\( (peek-char in)) (res (if (eqv? #\( (peek-char in))
(write-char (read-char in) out)) (cons (string (read-char in)) res)
(highlight-class 'function (read-identifier '()) out) res)))
(highlight (+ n 1))) (highlight
((highlight-scheme-syntax? id) (+ n 1)
(highlight-class 'keyword id out) '()
(highlight (+ n 1))) (cons
(highlight-class "function" (read-identifier '()))
res))))
((highlight-scheme-syntax? sym)
(highlight (+ n 1)
'()
(cons (highlight-class "keyword" id) res)))
(else (else
(display "<span>" out) (highlight (+ n 1) '() (cons id res))))))))
(display id out)
(display "</span>" out)
(highlight (+ n 1)))))))
((#\)) ((#\))
(cond (cond
((zero? n) ((zero? n)
(highlight-class 'syntaxerror c out) (highlight n
(highlight n)) '()
(cons (highlight-class "syntaxerror" c)
(collect str res))))
(else (else
(write-char c out) ;;(highlight-end 'paren
;;(highlight-end 'paren out) (highlight (- n 1) (cons c str) res))))
(highlight (- n 1)))))
((#\#) ((#\#)
(hash-mark n)) (highlight n '() (cons (hash-mark) (collect str res))))
((#\<)
(display "&lt;" out)
(highlight n))
((#\&)
(display "&amp;" out)
(highlight n))
;;((#\newline)
;; (write-char c out)
;; (highlight 0))
(else (else
(cond (cond
((highlight-scheme-delimiter? c) ((highlight-scheme-delimiter? c)
(write-char c out) (highlight n (cons c str) res))
(highlight n))
(else (else
(let ((id (read-identifier (list c)))) (let ((id (read-identifier (list c))))
(display "<span>") (highlight n '() (cons `(span ,id) (collect str res)))))))))))
(display id out) (highlight 0 '() '())))
(display "</span>")
(highlight n)))))))))
(highlight 0)))))
(define (highlight-c-keyword? id) (define (highlight-c-keyword? id)
(memq id '(asm break case catch const_cast continue default delete (memq id '(asm break case catch const_cast continue default delete
@ -270,63 +257,53 @@
(define (highlight-c-type? id) (define (highlight-c-type? id)
(memq id '(auto bool char class const double enum extern float inline int long (memq id '(auto bool char class const double enum extern float inline int long
short signed static struct union unsigned void volatile wchar_t))) short signed static struct union unsigned void volatile wchar_t
sexp)))
(define (highlight-c source) (define (highlight-c source)
(let ((in (if (string? source) (open-input-string source) source))) (let ((in (if (string? source) (open-input-string source) source)))
(call-with-output-string
(lambda (out)
(define (read-to-eol ls)
(let ((c (read-char in)))
(cond
((eof-object? c) (reverse-list->string ls))
((eqv? c #\newline) (reverse-list->string (cons c ls)))
(else (read-to-eol (cons c ls))))))
(define (char-c-initial? c) (define (char-c-initial? c)
(and (char? c) (or (char-alphabetic? c) (eqv? c #\_) (eqv? c #\$)))) (and (char? c) (or (char-alphabetic? c) (eqv? c #\_) (eqv? c #\$))))
(define (char-c-identifier? c) (define (char-c-identifier? c)
(and (char? c) (or (char-c-initial? c) (char-numeric? c)))) (and (char? c) (or (char-c-initial? c) (char-numeric? c))))
(define (read-identifier ls) (define (read-identifier in ls)
(let ((c (peek-char in))) (let ((c (peek-char in)))
(if (char-c-identifier? c) (if (char-c-identifier? c)
(read-identifier (cons (read-char in) ls)) (read-identifier in (cons (read-char in) ls))
(string->symbol (reverse-list->string ls))))) (reverse-list->string ls))))
(define (write-identifier id) (define (highlight-identifier id)
(let ((sym (string->symbol id)))
(cond (cond
((highlight-c-keyword? id) ((highlight-c-keyword? sym)
(highlight-class 'keyword id out)) (highlight-class "keyword" id))
((highlight-c-type? id) ((highlight-c-type? sym)
(highlight-class 'type id out)) (highlight-class "type" id))
(else (else
(display id out)))) id))))
(define (highlight-line) (define (highlight-line res)
(highlight
'()
(cond (cond
((eqv? #\# (peek-char in)) ((eqv? #\# (peek-char in))
(highlight-start 'preprocessor out) (read-char in)
(write-char (read-char in) out) (let* ((res (cons (read-whitespace in) (cons "#" res)))
(display (read-whitespace in) out) (id (read-identifier in '()))
(let ((id (read-identifier '()))) (res (cons (read-whitespace in)
(display id out) (cons (highlight-class "preprocessor" id) res))))
(highlight-end 'preprocessor out) (case (string->symbol id)
(display (read-whitespace in) out) ((define)
(cond (cons (highlight-class "function" (read-to-whitespace in '())) res))
((eq? 'define id) ((include import)
(highlight-class (cons (highlight-class "string" (read-to-whitespace in '())) res))
'function (else
(html-escape (read-to-whitespace in '())) res))))
out))
((memq id '(include import))
(highlight-class
'string
(html-escape (read-to-whitespace in '()))
out)))))
((char-c-initial? (peek-char in)) ((char-c-initial? (peek-char in))
;; line beginning w/ an identifier is probably a ;; line beginning w/ an identifier is probably a
;; function declaration ;; function declaration
(let ((id1 (read-identifier '()))) (let ((id1 (read-identifier in '())))
(cond (cond
((eqv? #\: (peek-char in)) ((eqv? #\: (peek-char in))
(highlight-class 'function id1 out)) (cons (highlight-class "function" id1) res))
(else (else
(let lp ((decls '()) (let lp ((decls '())
(id id1)) (id id1))
@ -334,139 +311,122 @@
(cond (cond
((char-c-initial? (peek-char in)) ((char-c-initial? (peek-char in))
(lp (cons space (cons id decls)) (lp (cons space (cons id decls))
(read-identifier '()))) (read-identifier in '())))
((eqv? #\( (peek-char in)) ((eqv? #\( (peek-char in))
(highlight-start 'type out) `(,space
(for-each (lambda (x) (display x out)) ,(highlight-class "function" id)
(reverse decls)) ,(highlight-class "type" (reverse decls))
(highlight-end 'type out) ,@res))
(highlight-start 'function out)
(display id out)
(highlight-end 'function out)
(display space out))
(else (else
(for-each write-identifier (reverse decls)) `(,space ,id ,@(reverse decls) ,@res)))))))))
(display id out) (else
(display space out)))))))))) res))))
(highlight)) (define (highlight str res)
(define (highlight)
(let ((c (read-char in))) (let ((c (read-char in)))
(if (eof-object? c) (if (eof-object? c)
#f (reverse (collect str res))
(case c (case c
((#\/) ((#\/)
(case (peek-char in) (case (peek-char in)
((#\/) ((#\/)
(highlight-start 'comment out) (highlight
(write-char c out) '()
(display (read-to-eol '()) out) (cons (highlight-class "comment" (read-to-eol in '(#\/ #\/)))
(highlight-end 'comment out) (collect str res))))
(newline out)
(highlight))
((#\*) ((#\*)
(highlight-start 'comment out) (let lp ((ls (cons (read-char in) '(#\/))))
(write-char c out)
(write-char (read-char in) out)
(let ((prev (read-char in)))
(write-char prev out)
(let lp ((prev prev))
(let ((c (read-char in))) (let ((c (read-char in)))
(write-char c out) (if (not (and (eqv? (car ls) #\*) (eqv? c #\/)))
(if (not (and (eqv? prev #\*) (eqv? c #\/))) (lp (cons c ls))
(lp c) (highlight
#f)))) '()
(highlight-end 'comment out) (cons (highlight-class "comment"
(highlight)) (reverse-list->string ls))
(collect str res)))))))
(else (else
(write-char c out) (highlight (cons c str) res))))
(highlight))))
((#\" #\') ((#\" #\')
(let ((str (read-escaped in c (list c)))) (let ((res (collect str res))
(highlight-class 'string str out) (s (read-escaped in c (list c))))
(highlight))) (highlight '() (cons (highlight-class "string" s) res))))
((#\newline) ((#\newline)
(newline out) (highlight-line (collect (cons #\newline str) res)))
(highlight-line)) ;; ((#\<)
((#\<) ;; (highlight (append '(#\; #\t #\l #\&) str) res))
(display "&lt;" out) ;; ((#\&)
(highlight)) ;; (highlight (append '(#\; #\p #\m #\a #\&) str) res))
((#\&)
(display "&amp;" out)
(highlight))
(else (else
(cond (cond
((char-c-initial? c) ((char-c-initial? c)
(let ((id (read-identifier (list c)))) (highlight
'()
(cons
(let ((id (read-identifier in (list c))))
(if (eqv? #\: (peek-char in)) (if (eqv? #\: (peek-char in))
(highlight-class 'function id out) (highlight-class "function" id)
(write-identifier id)))) (highlight-identifier id)))
(collect str res))))
(else (else
(write-char c out))) (highlight (cons c str) res))))))))
(highlight)))))) (highlight-line '())))
(highlight-line)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (highlight-assembly source) (define (highlight-assembly source)
(let ((in (if (string? source) (open-input-string source) source))) (let ((in (if (string? source) (open-input-string source) source)))
(call-with-output-string
(lambda (out)
(define (read-to-eol ls)
(let ((c (read-char in)))
(cond
((eof-object? c) (reverse-list->string ls))
((eqv? c #\newline) (reverse-list->string (cons c ls)))
(else (read-to-eol (cons c ls))))))
(define (char-asm-initial? c) (define (char-asm-initial? c)
(and (char? c) (or (char-alphabetic? c) (memv c '(#\_ #\$ #\.))))) (and (char? c) (or (char-alphabetic? c) (memv c '(#\_ #\$ #\.)))))
(define (char-asm-identifier? c) (define (char-asm-identifier? c)
(and (char? c) (or (char-asm-initial? c) (char-numeric? c)))) (and (char? c) (or (char-asm-initial? c) (char-numeric? c))))
(define (read-identifier ls) (define (read-identifier in ls)
(let ((c (peek-char in))) (let ((c (peek-char in)))
(if (char-asm-identifier? c) (if (char-asm-identifier? c)
(read-identifier (cons (read-char in) ls)) (read-identifier (cons (read-char in) ls))
(string->symbol (reverse-list->string ls))))) (reverse-list->string ls))))
(define (highlight) (define (highlight str res)
(let ((c (read-char in))) (let ((c (read-char in)))
(cond (cond
((eof-object? c)) ((eof-object? c)
(reverse (collect str res)))
(else (else
(case c (case c
((#\newline) ((#\newline)
(write-char c out) (highlight-line (collect str res)))
(line))
((#\") ((#\")
(let ((str (read-escaped in c (list c)))) (let ((s (read-escaped in c (list c))))
(highlight-class 'string str out) (highlight
(highlight))) '()
(cons (highlight-class "string" s) (collect str res)))))
((#\%) ((#\%)
(highlight-class 'variable (read-identifier (list c)) out) (highlight
(highlight)) '()
(cons (highlight-class "variable" (read-identifier in (list c)))
(collect str res))))
((#\;) ((#\;)
(highlight-class 'comment (read-to-eol (list c)) out) (highlight
(highlight)) '()
((#\<) (cons (highlight-class "comment" (read-to-eol in (list c)))
(display "&lt;" out) (collect str res))))
(highlight))
((#\&)
(display "&amp;" out)
(highlight))
(else (else
(write-char c out) (highlight (cons c str) res)))))))
(highlight))))))) (define (highlight-line res)
(define (line)
(cond (cond
((eof-object? (peek-char in))) ((eof-object? (peek-char in))
(highlight '() res))
((char-asm-initial? (peek-char in)) ((char-asm-initial? (peek-char in))
(let ((id (read-identifier '()))) (let ((id (read-identifier in '())))
(highlight
'()
(cons
(if (eqv? #\: (peek-char in)) (if (eqv? #\: (peek-char in))
(highlight-class 'function id out) (highlight-class "function" id)
(highlight-class 'keyword id out)) (highlight-class "keyword" id))
(highlight))) res))))
((eqv? #\tab (peek-char in)) ((eqv? #\tab (peek-char in))
(write-char (read-char in) out) (highlight
(highlight-class 'keyword (read-identifier '()) out) '()
(highlight)) (cons (highlight-class "keyword" (read-identifier in '()))
(cons "\t" res))))
(else (else
(highlight)))) (highlight '() res))))
(line))))) (highlight-line '())))