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

specify encoding meta for docs, include doctype

Browse source
This commit is contained in:
Alex Shinn 2020-09-02 15:52:20 +09:00
parent 8597c3eda5
commit d0bd93822e
2 changed files with 61 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
lib/chibi/doc.scm
View file

@ -483,9 +483,11 @@
(lp (cdr ls) (caar ls) (cadr (car ls)) '() (collect))))))) (lp (cdr ls) (caar ls) (cadr (car ls)) '() (collect)))))))
(define (fix-header x) (define (fix-header x)
`(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x))) `((!DOCTYPE html)
(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
(else '())) (else '()))
"\n" "\n"
(meta (@ (charset . "UTF-8")))
(style (@ (type . "text/css")) (style (@ (type . "text/css"))
" "
body {color: #000; background-color: #FFFFF8;} body {color: #000; background-color: #FFFFF8;}
@ -521,7 +523,7 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
(cons 'h1 (cdr x)) (cons 'h1 (cdr x))
x)) x))
x) x)
(div (@ (id . "footer"))))))) (div (@ (id . "footer"))))))))
(define (fix-paragraphs x) (define (fix-paragraphs x)
(let lp ((ls x) (p '()) (res '())) (let lp ((ls x) (p '()) (res '()))

39
lib/chibi/sxml.scm
View file

@ -52,6 +52,9 @@
(apply string-append (reverse (cons ">" res))) (apply string-append (reverse (cons ">" res)))
(lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res)))))) (lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
(define void-elements
'(area base br col embed hr img input keygen link meta param source track wbr))
(define (html-display-escaped-string x . o) (define (html-display-escaped-string x . o)
(let* ((str (display-to-string x)) (let* ((str (display-to-string x))
(start 0) (start 0)
@ -81,27 +84,39 @@
;;> \var{@raw} tag is considered safe text and not processed or escaped. ;;> \var{@raw} tag is considered safe text and not processed or escaped.
(define (sxml-display-as-html sxml . o) (define (sxml-display-as-html sxml . o)
(let ((out (if (pair? o) (car o) (current-output-port)))) (let ((out (if (pair? o) (car o) (current-output-port))))
(let lp ((sxml sxml)) (let lp ((sxml (if (and (pair? sxml) (eq? '*TOP* (car sxml)))
(cdr sxml)
sxml)))
(cond (cond
((pair? sxml) ((pair? sxml)
(let ((tag (car sxml))) (let ((tag (car sxml))
(if (symbol? tag) (rest (cdr sxml)))
(let ((rest (cdr sxml)))
(cond (cond
((symbol? tag)
(cond
((eqv? #\! (string-ref (symbol->string tag) 0))
(display "<" out) (display tag out)
(for-each (lambda (x) (display " " out) (display x out)) rest)
(display ">\n" out))
((and (eq? '@raw tag)
(string? (car rest)))
(if (not (null? (cdr rest)))
(error "@raw takes only one value" sxml))
(display (car rest) out))
((and (pair? rest) ((and (pair? rest)
(pair? (car rest)) (pair? (car rest))
(eq? '@ (caar rest))) (eq? '@ (caar rest)))
(display (html-tag->string tag (cdar rest)) out) (display (html-tag->string tag (cdar rest)) out)
(for-each lp (cdr rest)) (for-each lp (cdr rest))
(display "</" out) (display tag out) (display ">" out)) (unless (and (null? (cdr rest)) (memq tag void-elements))
((and (eq? '@raw tag) (display "</" out) (display tag out) (display ">" out)))
(string? (car rest)))
(display (car rest) out))
(else (else
(display (html-tag->string tag '()) out) (display (html-tag->string tag '()) out)
(for-each lp rest) (for-each lp rest)
(display "</" out) (display tag out) (display ">" out)))) (unless (and (null? rest) (memq tag void-elements))
(for-each lp sxml)))) (display "</" out) (display tag out) (display ">" out)))))
(else
(for-each lp sxml)))))
((null? sxml)) ((null? sxml))
(else (html-display-escaped-string sxml out)))))) (else (html-display-escaped-string sxml out))))))
@ -127,7 +142,9 @@
;;> Render \var{sxml} as text for viewing in a terminal. ;;> Render \var{sxml} as text for viewing in a terminal.
(define (sxml-display-as-text sxml . o) (define (sxml-display-as-text sxml . o)
(let ((out (if (pair? o) (car o) (current-output-port)))) (let ((out (if (pair? o) (car o) (current-output-port))))
(let lp ((sxml sxml)) (let lp ((sxml (if (and (pair? sxml) (eq? '*TOP* (car sxml)))
(cdr sxml)
sxml)))
(cond (cond
((pair? sxml) ((pair? sxml)
(let ((tag (car sxml))) (let ((tag (car sxml)))