I added another change regarding the display of self-closing or "bodyless" tags
(don't display a close tag). Using /> here because it's allowed in HTML5 and
required in XHTML and XML.
If there's anything further I can do to help with this egg, please let me know!
My sudden interest in HTML/Markdown comes from the pebble static generator
which I'm hoping to release 1.0.0 for soon.
Thanks,
Diego
Index: html-parser.scm
===================================================================
--- html-parser.scm (revision 46461)
+++ html-parser.scm (working copy)
@@ -1,8 +1,8 @@
;; html-parser.scm -- SSAX-like tree-folding html parser
-;; Copyright (c) 2003-2014 Alex Shinn. All rights reserved.
+;; Copyright (c) 2003-2020 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
-;;> A permissive HTML parser supporting scalable streaming with a
+;;> A permissive HTML parser supporting scalable streaming with a tree
;;> folding interface. This copies the interface of Oleg Kiselyov's
;;> SSAX parser, as well as providing simple convenience utilities.
;;> It correctly handles all invalid HTML, inserting "virtual"
@@ -307,9 +307,11 @@
(if (string=? name "")
(loop attrs)
(let ((name (string->symbol (string-downcase name))))
+ (skip-whitespace in)
(cond
((eqv? (peek-char in) #\=)
(read-char in)
+ (skip-whitespace in)
(let ((value (if (memv (peek-char in) '(#\" #\'))
(apply string-append
(read-quoted in entities))
@@ -380,11 +382,16 @@
(define *tag-levels*
'(html (head body) table (thead tbody) tr (th td) p (b i u s)))
+(define *block*
+ '(div main section article header footer aside h1 h2 h3 h4 h5 h6 p
+ blockquote pre hr address ul ol li dl dt dd table tfoot form
+ fieldset figure figcaption video canvas noscript))
+
(define *unnestables*
- '(p li td tr))
+ '(p li td tr th dt dd rt rp optgroup option))
(define *bodyless*
- '(img hr br meta link))
+ '(img hr br area base col embed input link meta param source track wbr))
(define *literals*
'(script xmp))
@@ -571,6 +578,7 @@
((not (cdr tok)) ;; nameless closing tag
(lp (read-html-token in entities) seed seeds tags))
((and (pair? tags) (eq? (cdr tok) (caar tags)))
+ ;; closing the currently open tag
(lp (read-html-token in entities)
(end (cdr tok) (fix-attrs (cadar tags) seed)
(car seeds) seed #f)
@@ -583,8 +591,12 @@
(tag-level tag-levels (caar tags))
-1)))
(cond
- ((< this-level expected-level)
- ;; higher-level tag, forcefully close preceding tags
+ ((or (< this-level expected-level)
+ (and (memq (cdr tok) *block*)
+ (pair? tags)
+ (memq (caar tags) *block*)))
+ ;; higher-level tag or both block tags,
+ ;; forcefully close preceding tags
(lp tok
(end (caar tags) (fix-attrs (cadar tags) seed)
(car seeds) seed 'parent-closed)
@@ -637,14 +649,33 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; simple conversions
+;; concatenate adjacent top-level strings in ls
+(define (reverse-condensing-strings ls)
+ (let lp1 ((ls ls) (res '()))
+ (cond
+ ((null? ls) res)
+ ((null? (cdr ls)) (cons (car ls) res))
+ ((and (string? (car ls)) (string? (cadr ls)))
+ (let lp2 ((ls (cdr ls)) (strs (list (car ls))))
+ (cond
+ ((null? ls) (cons (apply string-append strs) res))
+ ((string? (car ls)) (lp2 (cdr ls) (cons (car ls) strs)))
+ (else (lp1 ls (cons (apply string-append strs) res))))))
+ (else (lp1 (cdr ls) (cons (car ls) res))))))
+
+;;> \procedure{(html->sxml [port])}
+;;> Returns the SXML representation of the document from \var{port},
+;;> using the default parsing options.
+
(define html->sxml
(let ((parse
(make-html-parser
'start: (lambda (tag attrs seed virtual?) '())
'end: (lambda (tag attrs parent-seed seed virtual?)
- `((,tag ,@(if (pair? attrs)
- `((@ ,@attrs) ,@(reverse seed))
- (reverse seed)))
+ `((,tag
+ ,@(if (pair? attrs)
+ `((@ ,@attrs) ,@(reverse-condensing-strings seed))
+ (reverse-condensing-strings seed)))
,@parent-seed))
'decl: (lambda (tag attrs seed) `((*DECL* ,tag ,@attrs) ,@seed))
'process: (lambda (attrs seed) `((*PI* ,@attrs) ,@seed))
@@ -667,7 +698,7 @@
(define (html-tag->string tag attrs)
(let lp ((ls attrs) (res (list (symbol->string tag) "<")))
(if (null? ls)
- (apply string-append (reverse (cons ">" res)))
+ (apply string-append (reverse (cons (if (memq tag *bodyless*) "/>" ">") res)))
(lp (cdr ls) (cons (html-attr->string (car ls)) (cons " " res))))))
(define html-character-escapes
@@ -726,11 +757,13 @@
(eq? '@ (caar rest)))
(display (html-tag->string tag (cdar rest)) out)
(for-each (lambda (x) (sxml-display-as-html x out)) (cdr rest))
- (display "</" out) (display tag out) (display ">" out))
+ (unless (memq tag *bodyless*)
+ (display "</" out) (display tag out) (display ">" out)))
(else
(display (html-tag->string tag '()) out)
(for-each (lambda (x) (sxml-display-as-html x out)) rest)
- (display "</" out) (display tag out) (display ">" out))))))
+ (unless (memq tag *bodyless*)
+ (display "</" out) (display tag out) (display ">" out)))))))
(for-each (lambda (x) (sxml-display-as-html x out)) sxml))))
((null? sxml))
(else
Index: tests/run.scm
===================================================================
--- tests/run.scm (revision 46461)
+++ tests/run.scm (working copy)
@@ -71,6 +71,18 @@
(test '(*TOP* (br) "\r\n" (br) "\r\n" (div (@ (data "(sxml (@ (attr \"12345\")) body)")) "div body"))
(html->sxml "<br>\r\n<br>\r\n<div data=\"(sxml (@ (attr "12345")) body)\">div body</div>"))
+(test '(*TOP* (p "foo'bar\"baz"))
+ (html->sxml "<p>foo'bar"baz</p>"))
+
+(test '(*TOP* (p "a") (p "b"))
+ (html->sxml "<p>a<p>b"))
+
+(test '(*TOP* (div "a" (p "b")))
+ (html->sxml "<div>a<p>b"))
+
+(test '(*TOP* (li "a") (li) (li (div (p "b"))) (li "c") (li))
+ (html->sxml "<li>a<li><li><div><p>b</div></li><li>c<li>"))
+
(test
'(*TOP*
(meta (@ (charset "utf-8")))
@@ -90,4 +102,9 @@
EOF
)))
+(test-group "display"
+ (test "<br/>" (sxml->html '(br)))
+ (test "<img src=\"/pictures/test.png\"/>"
+ (sxml->html '(img (@ (src "/pictures/test.png"))))))
+
(test-end)
