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

46
lib/chibi/doc.scm
View file

@ -483,11 +483,13 @@
(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)
(else '())) (html (head ,@(cond ((assq 'title x) => (lambda (x) (list x)))
"\n" (else '()))
(style (@ (type . "text/css")) "\n"
" (meta (@ (charset . "UTF-8")))
(style (@ (type . "text/css"))
"
body {color: #000; background-color: #FFFFF8;} body {color: #000; background-color: #FFFFF8;}
div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 250px; height: 100%} div#menu {font-size: smaller; position: absolute; top: 50px; left: 0; width: 250px; height: 100%}
div#menu a:link {text-decoration: none} div#menu a:link {text-decoration: none}
@ -505,23 +507,23 @@ h4 { color: #222288; border-top: 1px solid #4588ba; }
.error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px} .error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px}
.command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px} .command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px}
" "
,(highlight-style)) ,(highlight-style))
"\n") "\n")
(body (body
(div (@ (id . "menu")) (div (@ (id . "menu"))
,(let ((contents (get-contents (extract-contents x)))) ,(let ((contents (get-contents (extract-contents x))))
(match contents (match contents
;; flatten if we have only a single heading ;; flatten if we have only a single heading
(('ol (li y sections ...)) (('ol (li y sections ...))
sections) sections)
(else contents)))) (else contents))))
(div (@ (id . "main")) (div (@ (id . "main"))
,@(map (lambda (x) ,@(map (lambda (x)
(if (and (pair? x) (eq? 'title (car x))) (if (and (pair? x) (eq? 'title (car x)))
(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 '()))

57
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)
((and (pair? rest) (cond
(pair? (car rest)) ((eqv? #\! (string-ref (symbol->string tag) 0))
(eq? '@ (caar rest))) (display "<" out) (display tag out)
(display (html-tag->string tag (cdar rest)) out) (for-each (lambda (x) (display " " out) (display x out)) rest)
(for-each lp (cdr rest)) (display ">\n" out))
(display "</" out) (display tag out) (display ">" out)) ((and (eq? '@raw tag)
((and (eq? '@raw tag) (string? (car rest)))
(string? (car rest))) (if (not (null? (cdr rest)))
(display (car rest) out)) (error "@raw takes only one value" sxml))
(else (display (car rest) out))
(display (html-tag->string tag '()) out) ((and (pair? rest)
(for-each lp rest) (pair? (car rest))
(display "</" out) (display tag out) (display ">" out)))) (eq? '@ (caar rest)))
(for-each lp sxml)))) (display (html-tag->string tag (cdar rest)) out)
(for-each lp (cdr rest))
(unless (and (null? (cdr rest)) (memq tag void-elements))
(display "</" out) (display tag out) (display ">" out)))
(else
(display (html-tag->string tag '()) out)
(for-each lp rest)
(unless (and (null? rest) (memq tag void-elements))
(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)))