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"))

642
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 (highlighter-for language)
(case language
((scheme) highlight-scheme)
((asm) highlight-assembly)
(else highlight-c)))
(define (highlight source) (define (highlight source)
(let ((str (if (string? source) source (port->string source)))) (let ((str (if (string? source) source (port->string source))))
((case (highlight-detect-language str) ((highlighter-for (highlight-detect-language str)) str)))
((scheme) highlight-scheme)
((asm) highlight-assembly)
((c) highlight-c))
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)
(string-append (if (and (list? x) (= 3 (length x)))
"." (symbol->string (car x)) " { color: " (cdr x) (string-append
"; background-color: inherit; }\n")) "." (symbol->string (car x)) " { color: " (cadr x)
"; 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)
(cond (let ((c (peek-char in)))
((char-whitespace? (peek-char in)) (cond
(reverse-list->string res)) ((or (eof-object? c) (char-whitespace? c))
(else (reverse-list->string res))
(read-to-whitespace in (cons (read-char in) res))))) (else
(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,117 +152,100 @@
(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 (define (read-identifier ls)
(lambda (out) (let ((c (peek-char in)))
(define (read-to-eol ls) (cond
(let ((c (read-char in))) ((highlight-scheme-delimiter? c)
(cond (reverse-list->string ls))
((eof-object? c) (reverse-list->string ls)) (else
((eqv? c #\newline) (reverse-list->string (cons c ls))) (read-char in)
(else (read-to-eol (cons c ls)))))) (read-identifier (cons c ls))))))
(define (read-identifier ls) (define (hash-mark)
(let ((c (peek-char in))) (let ((c (read-char in)))
(cond (case c
((highlight-scheme-delimiter? c) ((#\;)
(string->symbol (reverse-list->string ls))) (highlight-class "comment" (highlight 0 '(#\; #\#) '())))
(else ((#\\)
(read-char in) (highlight-class "string"
(read-identifier (cons c ls)))))) (read-identifier (list (read-char in) #\\ #\#))))
(define (hash-mark n) (else
(let ((c (read-char in))) "#"))))
(case c (define (highlight n str res)
((#\;) (let ((c (read-char in)))
(highlight-start 'comment out) (if (eof-object? c)
(highlight n) (reverse (collect str res))
(highlight-end 'comment out)) (case c
((#\\) ((#\;)
(let ((id (read-identifier (list (read-char in) #\\ #\#)))) (let lp ((ls '()))
(highlight-class 'string id out) (let ((ls (cons (read-to-eol in (list #\;)) ls)))
(highlight n))) (cond
(else ((eqv? #\; (peek-char in))
(write-char #\# out) (lp ls))
(write-char c out) (else
(highlight n))))) (highlight n
(define (highlight n) '()
(let ((c (read-char in))) (cons (highlight-class
(if (eof-object? c) "comment"
#f (string-concatenate-reverse ls))
(case c (collect str res))))))))
((#\;) ((#\")
(let lp ((ls '())) (let ((s (read-escaped in #\" (list #\"))))
(let ((ls (cons (read-to-eol (list #\;)) ls))) (highlight n
(cond '()
((eqv? #\; (peek-char in)) (cons (highlight-class "string" s)
(lp ls)) (collect str res)))))
(else ((#\()
(highlight-class 'comment ;;(highlight-start
(string-concatenate-reverse ls) ;; (string->symbol
out) ;; (string-append
(highlight n)))))) ;; "paren"
((#\") ;; (number->string
(let ((str (read-escaped in #\" (list #\")))) ;; (+ 1 (modulo n (length highlight-paren-styles))))))
(highlight-class 'string str out) ;;out)
(highlight n))) (let ((res (collect (cons #\( str) res)))
((#\() (if (highlight-scheme-delimiter? (peek-char in))
;;(highlight-start (highlight (+ n 1) '() res)
;; (string->symbol (let* ((id (read-identifier '()))
;; (string-append (sym (string->symbol id)))
;; "paren" (cond
;; (number->string ((highlight-scheme-definition? sym)
;; (+ 1 (modulo n (length highlight-paren-styles)))))) (let* ((res (cons (read-whitespace in) res))
;;out) (res (cons (highlight-class "keyword" id) res))
(write-char #\( out) (res (if (eqv? #\( (peek-char in))
(if (highlight-scheme-delimiter? (peek-char in)) (cons (string (read-char in)) res)
(highlight (+ n 1)) res)))
(let ((id (read-identifier '()))) (highlight
(cond (+ n 1)
((highlight-scheme-definition? id) '()
(highlight-class 'keyword id out) (cons
(display (read-whitespace in) out) (highlight-class "function" (read-identifier '()))
(if (eqv? #\( (peek-char in)) res))))
(write-char (read-char in) out)) ((highlight-scheme-syntax? sym)
(highlight-class 'function (read-identifier '()) out) (highlight (+ n 1)
(highlight (+ n 1))) '()
((highlight-scheme-syntax? id) (cons (highlight-class "keyword" id) res)))
(highlight-class 'keyword id out) (else
(highlight (+ n 1))) (highlight (+ n 1) '() (cons id res))))))))
(else ((#\))
(display "<span>" out) (cond
(display id out) ((zero? n)
(display "</span>" out) (highlight n
(highlight (+ n 1))))))) '()
((#\)) (cons (highlight-class "syntaxerror" c)
(cond (collect str res))))
((zero? n) (else
(highlight-class 'syntaxerror c out) ;;(highlight-end 'paren
(highlight n)) (highlight (- n 1) (cons c str) res))))
(else ((#\#)
(write-char c out) (highlight n '() (cons (hash-mark) (collect str res))))
;;(highlight-end 'paren out) (else
(highlight (- n 1))))) (cond
((#\#) ((highlight-scheme-delimiter? c)
(hash-mark n)) (highlight n (cons c str) res))
((#\<) (else
(display "&lt;" out) (let ((id (read-identifier (list c))))
(highlight n)) (highlight n '() (cons `(span ,id) (collect str res)))))))))))
((#\&) (highlight 0 '() '())))
(display "&amp;" out)
(highlight n))
;;((#\newline)
;; (write-char c out)
;; (highlight 0))
(else
(cond
((highlight-scheme-delimiter? c)
(write-char c out)
(highlight n))
(else
(let ((id (read-identifier (list c))))
(display "<span>")
(display id out)
(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,203 +257,176 @@
(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 (define (char-c-initial? c)
(lambda (out) (and (char? c) (or (char-alphabetic? c) (eqv? c #\_) (eqv? c #\$))))
(define (read-to-eol ls) (define (char-c-identifier? c)
(let ((c (read-char in))) (and (char? c) (or (char-c-initial? c) (char-numeric? c))))
(cond (define (read-identifier in ls)
((eof-object? c) (reverse-list->string ls)) (let ((c (peek-char in)))
((eqv? c #\newline) (reverse-list->string (cons c ls))) (if (char-c-identifier? c)
(else (read-to-eol (cons c ls)))))) (read-identifier in (cons (read-char in) ls))
(define (char-c-initial? c) (reverse-list->string ls))))
(and (char? c) (or (char-alphabetic? c) (eqv? c #\_) (eqv? c #\$)))) (define (highlight-identifier id)
(define (char-c-identifier? c) (let ((sym (string->symbol id)))
(and (char? c) (or (char-c-initial? c) (char-numeric? c)))) (cond
(define (read-identifier ls) ((highlight-c-keyword? sym)
(let ((c (peek-char in))) (highlight-class "keyword" id))
(if (char-c-identifier? c) ((highlight-c-type? sym)
(read-identifier (cons (read-char in) ls)) (highlight-class "type" id))
(string->symbol (reverse-list->string ls))))) (else
(define (write-identifier id) id))))
(cond (define (highlight-line res)
((highlight-c-keyword? id) (highlight
(highlight-class 'keyword id out)) '()
((highlight-c-type? id) (cond
(highlight-class 'type id out)) ((eqv? #\# (peek-char in))
(else (read-char in)
(display id out)))) (let* ((res (cons (read-whitespace in) (cons "#" res)))
(define (highlight-line) (id (read-identifier in '()))
(cond (res (cons (read-whitespace in)
((eqv? #\# (peek-char in)) (cons (highlight-class "preprocessor" id) res))))
(highlight-start 'preprocessor out) (case (string->symbol id)
(write-char (read-char in) out) ((define)
(display (read-whitespace in) out) (cons (highlight-class "function" (read-to-whitespace in '())) res))
(let ((id (read-identifier '()))) ((include import)
(display id out) (cons (highlight-class "string" (read-to-whitespace in '())) res))
(highlight-end 'preprocessor out) (else
(display (read-whitespace in) out) res))))
(cond ((char-c-initial? (peek-char in))
((eq? 'define id) ;; line beginning w/ an identifier is probably a
(highlight-class ;; function declaration
'function (let ((id1 (read-identifier in '())))
(html-escape (read-to-whitespace in '())) (cond
out)) ((eqv? #\: (peek-char in))
((memq id '(include import)) (cons (highlight-class "function" id1) res))
(highlight-class (else
'string (let lp ((decls '())
(html-escape (read-to-whitespace in '())) (id id1))
out))))) (let ((space (read-whitespace in)))
((char-c-initial? (peek-char in)) (cond
;; line beginning w/ an identifier is probably a ((char-c-initial? (peek-char in))
;; function declaration (lp (cons space (cons id decls))
(let ((id1 (read-identifier '()))) (read-identifier in '())))
(cond ((eqv? #\( (peek-char in))
((eqv? #\: (peek-char in)) `(,space
(highlight-class 'function id1 out)) ,(highlight-class "function" id)
(else ,(highlight-class "type" (reverse decls))
(let lp ((decls '()) ,@res))
(id id1))
(let ((space (read-whitespace in)))
(cond
((char-c-initial? (peek-char in))
(lp (cons space (cons id decls))
(read-identifier '())))
((eqv? #\( (peek-char in))
(highlight-start 'type out)
(for-each (lambda (x) (display x out))
(reverse decls))
(highlight-end 'type out)
(highlight-start 'function out)
(display id out)
(highlight-end 'function out)
(display space out))
(else
(for-each write-identifier (reverse decls))
(display id out)
(display space out))))))))))
(highlight))
(define (highlight)
(let ((c (read-char in)))
(if (eof-object? c)
#f
(case c
((#\/)
(case (peek-char in)
((#\/)
(highlight-start 'comment out)
(write-char c out)
(display (read-to-eol '()) out)
(highlight-end 'comment out)
(newline out)
(highlight))
((#\*)
(highlight-start 'comment out)
(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)))
(write-char c out)
(if (not (and (eqv? prev #\*) (eqv? c #\/)))
(lp c)
#f))))
(highlight-end 'comment out)
(highlight))
(else
(write-char c out)
(highlight))))
((#\" #\')
(let ((str (read-escaped in c (list c))))
(highlight-class 'string str out)
(highlight)))
((#\newline)
(newline out)
(highlight-line))
((#\<)
(display "&lt;" out)
(highlight))
((#\&)
(display "&amp;" out)
(highlight))
(else (else
(cond `(,space ,id ,@(reverse decls) ,@res)))))))))
((char-c-initial? c) (else
(let ((id (read-identifier (list c)))) res))))
(if (eqv? #\: (peek-char in)) (define (highlight str res)
(highlight-class 'function id out) (let ((c (read-char in)))
(write-identifier id)))) (if (eof-object? c)
(else (reverse (collect str res))
(write-char c out))) (case c
(highlight)))))) ((#\/)
(highlight-line))))) (case (peek-char in)
((#\/)
(highlight
'()
(cons (highlight-class "comment" (read-to-eol in '(#\/ #\/)))
(collect str res))))
((#\*)
(let lp ((ls (cons (read-char in) '(#\/))))
(let ((c (read-char in)))
(if (not (and (eqv? (car ls) #\*) (eqv? c #\/)))
(lp (cons c ls))
(highlight
'()
(cons (highlight-class "comment"
(reverse-list->string ls))
(collect str res)))))))
(else
(highlight (cons c str) res))))
((#\" #\')
(let ((res (collect str res))
(s (read-escaped in c (list c))))
(highlight '() (cons (highlight-class "string" s) res))))
((#\newline)
(highlight-line (collect (cons #\newline str) res)))
;; ((#\<)
;; (highlight (append '(#\; #\t #\l #\&) str) res))
;; ((#\&)
;; (highlight (append '(#\; #\p #\m #\a #\&) str) res))
(else
(cond
((char-c-initial? c)
(highlight
'()
(cons
(let ((id (read-identifier in (list c))))
(if (eqv? #\: (peek-char in))
(highlight-class "function" id)
(highlight-identifier id)))
(collect str res))))
(else
(highlight (cons c str) res))))))))
(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 (define (char-asm-initial? c)
(lambda (out) (and (char? c) (or (char-alphabetic? c) (memv c '(#\_ #\$ #\.)))))
(define (read-to-eol ls) (define (char-asm-identifier? c)
(let ((c (read-char in))) (and (char? c) (or (char-asm-initial? c) (char-numeric? c))))
(cond (define (read-identifier in ls)
((eof-object? c) (reverse-list->string ls)) (let ((c (peek-char in)))
((eqv? c #\newline) (reverse-list->string (cons c ls))) (if (char-asm-identifier? c)
(else (read-to-eol (cons c ls)))))) (read-identifier (cons (read-char in) ls))
(define (char-asm-initial? c) (reverse-list->string ls))))
(and (char? c) (or (char-alphabetic? c) (memv c '(#\_ #\$ #\.))))) (define (highlight str res)
(define (char-asm-identifier? c) (let ((c (read-char in)))
(and (char? c) (or (char-asm-initial? c) (char-numeric? c)))) (cond
(define (read-identifier ls) ((eof-object? c)
(let ((c (peek-char in))) (reverse (collect str res)))
(if (char-asm-identifier? c) (else
(read-identifier (cons (read-char in) ls)) (case c
(string->symbol (reverse-list->string ls))))) ((#\newline)
(define (highlight) (highlight-line (collect str res)))
(let ((c (read-char in))) ((#\")
(cond (let ((s (read-escaped in c (list c))))
((eof-object? c)) (highlight
(else '()
(case c (cons (highlight-class "string" s) (collect str res)))))
((#\newline) ((#\%)
(write-char c out) (highlight
(line)) '()
((#\") (cons (highlight-class "variable" (read-identifier in (list c)))
(let ((str (read-escaped in c (list c)))) (collect str res))))
(highlight-class 'string str out) ((#\;)
(highlight))) (highlight
((#\%) '()
(highlight-class 'variable (read-identifier (list c)) out) (cons (highlight-class "comment" (read-to-eol in (list c)))
(highlight)) (collect str res))))
((#\;) (else
(highlight-class 'comment (read-to-eol (list c)) out) (highlight (cons c str) res)))))))
(highlight)) (define (highlight-line res)
((#\<) (cond
(display "&lt;" out) ((eof-object? (peek-char in))
(highlight)) (highlight '() res))
((#\&) ((char-asm-initial? (peek-char in))
(display "&amp;" out) (let ((id (read-identifier in '())))
(highlight)) (highlight
(else '()
(write-char c out) (cons
(highlight))))))) (if (eqv? #\: (peek-char in))
(define (line) (highlight-class "function" id)
(cond (highlight-class "keyword" id))
((eof-object? (peek-char in))) res))))
((char-asm-initial? (peek-char in)) ((eqv? #\tab (peek-char in))
(let ((id (read-identifier '()))) (highlight
(if (eqv? #\: (peek-char in)) '()
(highlight-class 'function id out) (cons (highlight-class "keyword" (read-identifier in '()))
(highlight-class 'keyword id out)) (cons "\t" res))))
(highlight))) (else
((eqv? #\tab (peek-char in)) (highlight '() res))))
(write-char (read-char in) out) (highlight-line '())))
(highlight-class 'keyword (read-identifier '()) out)
(highlight))
(else
(highlight))))
(line)))))