Location: contrib, 627 Lines
; Scheme 9 from Empty Space, Function Library ; By Nils M Holm, 2010-2018 ; In the public domain ; ; (scm2html <option> ...) ==> string | unspecific ; ; Render Scheme code in HTML with syntax highlighting and optional ; CSS-based paren-matching. Input is read from (current-input-stream) ; and output is written to (current-output-stream) unless the ; 'INPUT-STRING: option is specified (see below). ; ; The rendition of the Scheme code will be placed in a PRE container ; of the class "scheme" (<PRE class=scheme>). When paren-matching is ; enabled, the class will change to "scheme-hl". ; ; The following container classes are used to specify the colors ; and other styles of the individual elements: ; ; o comment ; p parenthesis ; s symbol ; c constant ; r R4RS procedure ; y R4RS syntax ; x S9fES procedure ; z S9fES syntax ; m normal form ; n nested expression (for paren matching) ; ; See the "scheme.css" style sheet for examples. ; ; The following <option>s exist; ; ; 'FULL-HTML: boolean ; When set to #T, SCM2HTML will output a full HTML document ; and not just a PRE container. Will not work in string mode. ; ; 'LOUT-MODE: boolean ; Generate Lout output rather than HTML output. ; ; 'TROFF-MODE: boolean ; Generate TROFF output rather than HTML output. ; ; 'INPUT-STRING: string ; Input is read from a string and output is written to a string. ; In string mode, the 'FULL-HTML: option does not work. When this ; option is set, the result of the procedure will be of the form: ; ; (attributes string) ; ; where STRING is the output of the rendering process. See the ; description of 'INITIAL-STYLE: for more information on the ; ATTRIBUTES part. The output string of SCM2HTML is always ; lacking a trailing </SPAN> element. ; ; 'INITIAL-STYLE: list ; Initialize the color class and boldface flag with the values taken ; from LIST. LIST should be the car part of an object returned by ; SCM2HTML previously. It allows to render multiple lines that are ; logically connected by preserving the style across line boundaries. ; ; 'MARK-S9-PROCS: boolean ; When set to #T, S9fES procedures will be highlighted with an ; extra color. Otherwise, they will be rendered in the same color ; as user-defined symbols. ; ; 'MARK-S9-EXTNS: boolean ; When set to #T, S9fES syntax extensions will be highlighted with ; an extra color. Otherwise, they will be rendered in the same color ; as user-defined symbols. ; ; 'SHOW-MATCHES: boolean ; When set to #T, SCM2HTML will insert CSS code that allow to match ; parentheses interactively in the resulting code by moving the ; cursor over expressions. Does not work in string mode. ; ; 'TILDE-QUOTES: boolean ; When set to #T, #\~ characters in programs will serve is ; invisible quotation. Used to facilitate the rendering of ; evaluation sequences. ; ; 'TERMINATE: list ; Return termination tags for the color and boldface settings ; specified in LIST (see INPUT-STRING:). ; ; Example: (scm2html 'input-string: "'()") ; ==> (("c" #f quote 0 ()) ; "<SPAN class=y><B>'</B></SPAN><SPAN class=c>()") (load-from-library "keyword-value.scm") (load-from-library "symbols.scm") (load-from-library "read-line.scm") (load-from-library "setters.scm") (load-from-library "hof.scm") (load-from-library "htmlify-char.scm") (load-from-library "loutify-char.scm") (load-from-library "troffify-char.scm") (define (scm2html . options) (define *load-from-library* 0) (define *input-string* #f) (define *output-string* #f) (define END-OF-INPUT (list 'EOI)) (define LP #\() (define RP #\)) (define LB #\[) (define RB #\]) (define (Prolog) (let ((p (cond (troff-mode '(".CB")) (lout-mode '("@Pre{")) (show-matches '("<PRE class=scheme-hl>")) (else '("<PRE class=scheme>"))))) (if full-html (append '("<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"" " \"http://www.w3.org/TR/html4/loose.dtd\">" "<HTML>" "<HEAD>" "<TITLE></TITLE>" "<LINK rel=\"stylesheet\" type=\"text/css\" href=\"scheme.css\">" "</HEAD>" "<BODY>") p) p))) (define (Epilog) (change-color #f #f #f) (let ((p (cond (lout-mode '("}")) (troff-mode '(".CE")) (else '("</PRE>"))))) (if full-html (append p '("</BODY>" "</HTML>")) p))) (define (end-of-input? x) (if *input-string* (eq? x END-OF-INPUT) (eof-object? x))) (define (next-char) (if (not *input-string*) (read-char) (if (null? *input-string*) END-OF-INPUT (pop! *input-string*)))) (define (peek-next-char) (if (not *input-string*) (peek-char) (if (null? *input-string*) END-OF-INPUT (car *input-string*)))) (define (output x) (if *output-string* (push! x *output-string*) (display x))) (define (output-string) (apply string-append (map (lambda (x) (if (string? x) x (string x))) (reverse! *output-string*)))) (define (output* lines) (let* ((l* (reverse lines)) (last (car l*)) (lines (reverse! (cdr l*)))) (for-each (lambda (s) (output s) (output #\newline)) lines) (output last))) (define Color-comment "o") (define Color-paren "p") (define Color-symbol "s") (define Color-constant "c") (define Color-std-proc "r") (define Color-std-syntax "y") (define Color-ext-proc "x") (define Color-ext-syntax "z") (define Color-normal-form "m") (define *Color* #f) (define *Bold* #f) (define *Qtype* #f) (define *Parens* 0) (define *Paren-stack* '()) (define (escaped-output s) (cond (troff-mode (output (apply string-append (map troffify-char (string->list s))))) (lout-mode (output (apply string-append (map loutify-char (string->list s))))) (else (output (htmlify-string s))))) (define (change-color quoted co bo) (cond (quoted) ((and (equal? co *Color*) (eq? bo *Bold*))) (else (if *Bold* (cond (lout-mode (output "}")) (troff-mode) (else (output "</B>")))) (if *Color* (cond (lout-mode (output "}")) (troff-mode) (else (output "</SPAN>")))) (if co (cond (lout-mode (output "@S_") (output co) (output "{")) (troff-mode) (else (output "<SPAN class=") (output co) (output ">")))) (if bo (cond (lout-mode (output "@B{")) (troff-mode) (else (output "<B>")))) (set! *Color* co) (set! *Bold* bo)))) (define (with-color quoted co thunk) (change-color quoted co #f) (thunk)) (define (with-bold-color quoted co thunk) (change-color quoted co #t) (thunk)) (define symbolic? (let ((specials "!#$%&*+-./:<=>?@^_~")) (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (and (memv c (string->list specials)) #t))))) (define (print-paren c q) (cond (show-matches (if *Bold* (begin (output "</B>") (set! *Bold* #f))) (output "</SPAN>") (if (or (char=? c LP) (char=? c LB)) (output "<SPAN class=n>")) (output "<SPAN class=") (output (if q Color-constant Color-paren)) (output ">") (set! *Color* #f) (output c) (if (or (char=? c RP) (char=? c RB)) (output "</SPAN></SPAN>"))) (else (with-color q Color-paren (lambda () (output c))))) (next-char)) (define (r4rs-syntax? s) (and (memq (string->symbol s) (r4rs-syntax-objects)) #t)) (define (s9fes-syntax? s) (and mark-s9-procs (memq (string->symbol s) (s9fes-syntax-objects)) #t)) (define (r4rs-procedure? s) (and (memq (string->symbol s) (r4rs-procedures)) #t)) (define (s9fes-procedure? s) (and mark-s9-procs (memq (string->symbol s) (s9fes-procedures)) #t)) (define (s9fes-extension? s) (and mark-s9-extns (or (memq (string->symbol s) (s9fes-extension-procedures)) (memq (string->symbol s) (s9fes-extension-symbols))) #t)) (define (collect pred c s) (if (pred c) (collect pred (next-char) (cons c s)) (cons c (list->string (reverse! s))))) (define (print-symbol-or-number c q) (let ((c/s (collect symbolic? c '()))) (cond ((string->number (cdr c/s)) (with-color q Color-constant (lambda () (escaped-output (cdr c/s))))) ((r4rs-syntax? (cdr c/s)) (with-bold-color q Color-std-syntax (lambda () (escaped-output (cdr c/s))))) ((r4rs-procedure? (cdr c/s)) (with-color q Color-std-proc (lambda () (escaped-output (cdr c/s))))) ((s9fes-syntax? (cdr c/s)) (with-bold-color q Color-ext-syntax (lambda () (escaped-output (cdr c/s))))) ((s9fes-procedure? (cdr c/s)) (if (string=? "load-from-library" (cdr c/s)) (set! *load-from-library* 2)) (with-color q Color-ext-proc (lambda () (escaped-output (cdr c/s))))) ((s9fes-extension? (cdr c/s)) (with-color q Color-ext-proc (lambda () (escaped-output (cdr c/s))))) (else (with-color q Color-symbol (lambda () (escaped-output (cdr c/s)))))) (car c/s))) (define (print-const s q) (with-color q Color-constant (lambda () (escaped-output s))) (next-char)) (define (print-string c q) (letrec ((collect-string (lambda (c s esc) (cond ((end-of-input? c) (error "scm2html: unexpected EOF in string literal")) ((and (char=? c #\") (not esc)) (list->string (reverse! (cons #\" s)))) (else (collect-string (next-char) (cons c s) (and (not esc) (char=? #\\ c)))))))) (let* ((s (collect-string c '() #t)) (s2 (substring s 1 (- (string-length s) 1)))) (if (and (not lout-mode) (not troff-mode) (= *load-from-library* 1)) (with-color q Color-constant (lambda () (output "\"<A href=\"") (output s2) (let ((k (string-length s2))) (if (not (and (> k 3) (string=? (substring s2 (- k 4) k) ".scm"))) (output ".scm"))) (output ".html\">") (escaped-output s2) (output "</A>\""))) (with-color q Color-constant (lambda () (escaped-output s))))) (next-char))) (define (print-comment c) (let ((col (if *Color* *Color* Color-symbol))) (with-color #f Color-comment (lambda () (escaped-output (cdr (collect (curry (compose not char=?) #\newline) c '()))))) (with-color #f col (lambda () #t))) #\newline) (define (print-name pre c q) (with-color q Color-constant (lambda () (escaped-output "#") (escaped-output pre) (let ((c/s (collect (lambda (c) (or (char-alphabetic? c) (char-numeric? c))) (next-char) (list c)))) (escaped-output (cdr c/s)) (car c/s))))) (define (print-unreadable c q) (with-color q Color-ext-syntax (lambda () (escaped-output "#") (let ((c/s (collect (lambda (c) (not (char=? #\> c))) (next-char) (list c)))) (escaped-output (cdr c/s)) (escaped-output ">") (next-char))))) (define (print-shbang) (with-bold-color #f Color-ext-syntax (lambda () (escaped-output "#!"))) (with-color #f Color-comment (lambda () (output (read-line)))) #\newline) (define (print-block-comment) (let ((comment-color (lambda () (change-color #f Color-comment #f))) (syntax-color (lambda () (change-color #f Color-ext-syntax #t))) (flush (lambda (s) (cond ((negative? s) (escaped-output "|")) ((positive? s) (escaped-output "#")))))) (with-color #f Color-ext-syntax (lambda () (escaped-output "#|"))) (with-color #f Color-comment (lambda () (let loop ((c (next-char)) (s 0) (n 0)) (cond ((end-of-input? c) (error "scm2html: unexpected EOF")) ((char=? #\# c) (if (negative? s) (if (positive? n) (begin (syntax-color) (escaped-output "|#") (comment-color) (loop (next-char) 0 (- n 1)))) (begin (flush s) (loop (next-char) 1 n)))) ((char=? #\| c) (if (positive? s) (begin (syntax-color) (escaped-output "#|") (comment-color) (loop (next-char) 0 (+ 1 n))) (begin (flush s) (loop (next-char) -1 n)))) (else (flush s) (escaped-output (string c)) (loop (next-char) 0 n)))))) (with-color #f Color-ext-syntax (lambda () (escaped-output "|#"))) (next-char))) (define (print-hash-syntax c q) (let ((c (next-char))) (case c ((#\f) (print-const "#f" q)) ((#\F) (print-const "#F" q)) ((#\t) (print-const "#t" q)) ((#\T) (print-const "#T" q)) ((#\e) (print-name "e" (next-char) q)) ((#\E) (print-name "E" (next-char) q)) ((#\i) (print-name "i" (next-char) q)) ((#\I) (print-name "I" (next-char) q)) ((#\b) (print-name "b" (next-char) q)) ((#\B) (print-name "B" (next-char) q)) ((#\d) (print-name "d" (next-char) q)) ((#\D) (print-name "D" (next-char) q)) ((#\o) (print-name "o" (next-char) q)) ((#\O) (print-name "O" (next-char) q)) ((#\x) (print-name "x" (next-char) q)) ((#\X) (print-name "X" (next-char) q)) ((#\\) (print-name "\\" (next-char) q)) ((#\|) (print-block-comment)) ((#\() (print-vector q)) ((#\<) (print-unreadable c q)) ((#\!) (print-shbang)) (else (error "scm2html: unknown # syntax" c))))) (define (print-quoted-datum q type color) (with-color q color (lambda () (set! *Qtype* (if (eq? q 'quote) 'quote type)) (print-quoted-form (next-char) *Qtype*)))) (define (print-quoted c q type) (with-bold-color q Color-std-syntax (lambda () (output (if (eq? type 'quote) #\' #\`)))) (print-quoted-datum q type Color-constant)) (define (print-unquoted q) (with-bold-color (eq? q 'quote) Color-std-syntax (lambda () (output #\,) (if (char=? (peek-next-char) #\@) (output (next-char))))) (if (not (eq? q 'quote)) (let ((c (print-quoted-form (next-char) #f))) (with-color #f Color-constant (lambda () c))) (next-char))) (define (print-object c q) (cond ((or (char=? c LP) (char=? c LB)) (set! *Parens* (+ 1 *Parens*)) (print-paren c q)) ((or (char=? c RP) (char=? c RB)) (set! *Parens* (- *Parens* 1)) (print-paren c q)) ((char=? c #\#) (print-hash-syntax c q)) ((char=? c #\") (print-string c q)) ((char=? c #\;) (print-comment c)) ((char=? c #\') (print-quoted c q 'quote)) ((char=? c #\`) (print-quoted c q 'quasiquote)) ((char=? c #\,) (print-unquoted q)) ((and tilde-quotes (char=? c #\~)) (print-quoted-datum q 'quote Color-normal-form)) ((symbolic? c) (print-symbol-or-number c q)) (else (error "scm2html: unknown character class" c)))) (define (times n x) (let loop ((n n)) (cond ((positive? n) (output x) (loop (- n 1)))))) (define (skip-spaces c) (let loop ((c c) (n 0)) (cond ((and (char? c) (char=? #\space c)) (loop (next-char) (+ 1 n))) (lout-mode (if (positive? n) (begin (output "{&") (output (number->string n)) (output "s}"))) c) (troff-mode (times n " ") c) (else (times n #\space) c)))) (define (skip-whitespace c) (let loop ((c (skip-spaces c))) (if (and (char? c) (char-whitespace? c)) (begin (if (or (not *input-string*) (not (char=? c #\newline))) (output c)) (loop (skip-spaces (next-char)))) c))) (define (print-vector q) (with-color q Color-constant (lambda () (escaped-output "#"))) (print-object LP q)) (define (print-quoted-list c type) (let ((c (skip-whitespace c))) (cond ((end-of-input? c) c) (else (let ((c (print-object c type))) (if (<= *Parens* (car *Paren-stack*)) (begin (pop! *Paren-stack*) c) (print-quoted-list c type))))))) (define (print-quoted-form c type) (let ((c (skip-whitespace c)) (p0 *Parens*)) (let ((c (print-object c type))) (if (= p0 *Parens*) c (begin (push! p0 *Paren-stack*) (print-quoted-list c type)))))) (define (print-program c q) (let ((c (skip-whitespace c))) (if (end-of-input? c) c (let ((c (print-object c q))) (set! *load-from-library* (if (zero? *load-from-library*) 0 (- *load-from-library* 1))) (print-program c q))))) (define full-html #f) (define lout-mode #f) (define troff-mode #f) (define mark-s9-procs #f) (define mark-s9-extns #f) (define show-matches #f) (define tilde-quotes #f) (define input-string #f) (accept-keywords "scm2html" options '(full-html: input-string: initial-style: lout-mode: troff-mode: mark-s9-procs: mark-s9-extns: show-matches: tilde-quotes: terminate:)) (let ((fh (keyword-value options 'full-html: #f)) (lm (keyword-value options 'lout-mode: #f)) (tm (keyword-value options 'troff-mode: #f)) (is (keyword-value options 'input-string: #f)) (st (keyword-value options 'initial-style: '(#f #f #f 0 ()))) (msp (keyword-value options 'mark-s9-procs: #f)) (msx (keyword-value options 'mark-s9-extns: #f)) (sm (keyword-value options 'show-matches: #f)) (tq (keyword-value options 'tilde-quotes: #f)) (te (keyword-value options 'terminate: #f))) (set! full-html fh) (set! lout-mode lm) (set! troff-mode tm) (set! input-string is) (set! mark-s9-procs msp) (set! mark-s9-extns msx) (set! show-matches sm) (set! tilde-quotes tq) (set! *Color* (car st)) (set! *Bold* (cadr st)) (set! *Parens* (cadddr st)) (set! *Paren-stack* (car (cddddr st))) (set! *Qtype* (if (null? *Paren-stack*) #f (caddr st))) (if (and lout-mode full-html) (error "Lout mode cannot be combined with HTML mode")) (if (and lout-mode show-matches) (error "Lout mode cannot be combined with paren matching")) (cond (te (cond (lout-mode "") (troff-mode "") (else (string-append (if (cadr te) "</B>" "") (if (car te) "</SPAN>" ""))))) (input-string (set! *input-string* (append (string->list input-string) (list #\newline))) (set! *output-string* '()) (if lout-mode (let ((c *Color*) (b *Bold*)) (set! *Color* #f) (set! *Bold* #f) (change-color #f c b))) (let ((c (if (not (null? *Paren-stack*)) (print-quoted-list (next-char) *Qtype*) (next-char)))) (print-program c #f)) (let* ((out (output-string)) (out (if lout-mode (string-append out (if *Bold* "}" "") (if *Color* "}" "")) out))) (list (list *Color* *Bold* *Qtype* *Parens* *Paren-stack*) out))) (else (output* (Prolog)) (print-program (next-char) #f) (output* (Epilog)) (output #\newline)))))