suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

indent

Browse Source 
svn: r13855
This commit is contained in:
Jay McCarthy 2009-02-26 17:15:44 +00:00
parent 196ec00f16
commit 243fb2f0e4
2 changed files with 512 additions and 512 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/html/html-mod.ss
View File

@ -12,30 +12,30 @@
(provide-signature-elements html^) (provide-signature-elements html^)
;; Html-content = Html-element | Pc-data | Entity ;; Html-content = Html-element | Pc-data | Entity
(include "html-structs.ss") (include "html-structs.ss")
(include "case.ss") (include "case.ss")
;; xml->html : Document -> Html ;; xml->html : Document -> Html
(define (xml->html doc) (define (xml->html doc)
(let ([root (document-element doc)]) (let ([root (document-element doc)])
(unless (eq? 'html (element-name root)) (unless (eq? 'html (element-name root))
(error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root))) (error 'xml->html "This is not an html document. Expected 'html, given ~a" (element-name root)))
(make-html (element-attributes root) (xml-contents->html (element-content root))))) (make-html (element-attributes root) (xml-contents->html (element-content root)))))
;; xml-content->html : (listof Content) -> (listof Html-element) ;; xml-content->html : (listof Content) -> (listof Html-element)
(define (xml-contents->html contents) (define (xml-contents->html contents)
(foldr xml-single-content->html (foldr xml-single-content->html
null null
contents)) contents))
;; read-xhtml : [Input-port] -> Html ;; read-xhtml : [Input-port] -> Html
(define read-xhtml (compose xml->html read-xml)) (define read-xhtml (compose xml->html read-xml))
;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content) ;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content)
(define (peel-f toss? to-toss acc0) (define (peel-f toss? to-toss acc0)
(foldr (lambda (x acc) (foldr (lambda (x acc)
(if (toss? x) (if (toss? x)
(append (html-full-content x) acc) (append (html-full-content x) acc)
@ -43,8 +43,8 @@
acc0 acc0
to-toss)) to-toss))
;; repackage-html : (listof Html-content) -> Html ;; repackage-html : (listof Html-content) -> Html
(define (repackage-html contents) (define (repackage-html contents)
(let* ([html (memf html? contents)] (let* ([html (memf html? contents)]
[peeled (peel-f html? contents null)] [peeled (peel-f html? contents null)]
[body (memf body? peeled)]) [body (memf body? peeled)])
@ -57,14 +57,14 @@
null) null)
(filter (compose not head?) (peel-f body? peeled null)))))))) (filter (compose not head?) (peel-f body? peeled null))))))))
;; clean-up-pcdata : (listof Content) -> (listof Content) ;; clean-up-pcdata : (listof Content) -> (listof Content)
;; Each pcdata inside a tag that isn't supposed to contain pcdata is either ;; Each pcdata inside a tag that isn't supposed to contain pcdata is either
;; a) appended to the end of the previous subelement, if that subelement may contain pcdata ;; a) appended to the end of the previous subelement, if that subelement may contain pcdata
;; b) prepended to the front of the next subelement, if that subelement may contain pcdata ;; b) prepended to the front of the next subelement, if that subelement may contain pcdata
;; c) discarded ;; c) discarded
;; unknown tags may contain pcdata ;; unknown tags may contain pcdata
;; the top level may contain pcdata ;; the top level may contain pcdata
(define clean-up-pcdata (define clean-up-pcdata
;; clean-up-pcdata : (listof Content) -> (listof Content) ;; clean-up-pcdata : (listof Content) -> (listof Content)
(letrec ([clean-up-pcdata (letrec ([clean-up-pcdata
(lambda (content) (lambda (content)
@ -95,34 +95,34 @@
null)))]) null)))])
clean-up-pcdata)) clean-up-pcdata))
;; first-non-elements : (listof Content) -> (listof Content) ;; first-non-elements : (listof Content) -> (listof Content)
(define (first-non-elements content) (define (first-non-elements content)
(cond (cond
[(null? content) null] [(null? content) null]
[else (if (element? (car content)) [else (if (element? (car content))
null null
(cons (car content) (first-non-elements (cdr content))))])) (cons (car content) (first-non-elements (cdr content))))]))
;; recontent-xml : Element (listof Content) -> Element ;; recontent-xml : Element (listof Content) -> Element
(define (recontent-xml e c) (define (recontent-xml e c)
(make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c)) (make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c))
;; implicit-starts : Symbol Symbol -> (U #f Symbol) ;; implicit-starts : Symbol Symbol -> (U #f Symbol)
(define (implicit-starts parent child) (define (implicit-starts parent child)
(or (and (eq? child 'tr) (eq? parent 'table) 'tbody) (or (and (eq? child 'tr) (eq? parent 'table) 'tbody)
(and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr))) (and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr)))
;; may-contain : Kid-lister ;; may-contain : Kid-lister
(define may-contain (define may-contain
(sgml:gen-may-contain html-spec)) (sgml:gen-may-contain html-spec))
(define may-contain-anything (define may-contain-anything
(sgml:gen-may-contain null)) (sgml:gen-may-contain null))
(define use-html-spec (make-parameter #t)) (define use-html-spec (make-parameter #t))
;; read-html-as-xml : [Input-port] -> (listof Content) ;; read-html-as-xml : [Input-port] -> (listof Content)
(define read-html-as-xml (define read-html-as-xml
(case-lambda (case-lambda
[(port) [(port)
((if (use-html-spec) clean-up-pcdata values) ((if (use-html-spec) clean-up-pcdata values)
@ -132,6 +132,6 @@
implicit-starts) port))] implicit-starts) port))]
[() (read-html-as-xml (current-input-port))])) [() (read-html-as-xml (current-input-port))]))
;; read-html : [Input-port] -> Html ;; read-html : [Input-port] -> Html
(define read-html (define read-html
(compose repackage-html xml-contents->html read-html-as-xml)) (compose repackage-html xml-contents->html read-html-as-xml))

160
collects/html/sgml-reader.ss
View File

@ -9,21 +9,21 @@
(provide-signature-elements sgml-reader^) (provide-signature-elements sgml-reader^)
;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
(define-struct (start-tag source) (name attrs)) (define-struct (start-tag source) (name attrs))
;; End-tag ::= (make-end-tag Location Location Symbol) ;; End-tag ::= (make-end-tag Location Location Symbol)
(define-struct (end-tag source) (name)) (define-struct (end-tag source) (name))
;; Token ::= Contents | Start-tag | End-tag | Eof ;; Token ::= Contents | Start-tag | End-tag | Eof
(define read-html-comments (make-parameter #f)) (define read-html-comments (make-parameter #f))
(define trim-whitespace (make-parameter #f)) (define trim-whitespace (make-parameter #f))
;; Kid-lister : (Symbol -> (U (listof Symbol) #f)) ;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
;; gen-may-contain : Spec -> Kid-lister ;; gen-may-contain : Spec -> Kid-lister
(define (gen-may-contain spec) (define (gen-may-contain spec)
(let ([table (make-hash)]) (let ([table (make-hash)])
(for-each (lambda (def) (for-each (lambda (def)
(let ([rhs (cdr def)]) (let ([rhs (cdr def)])
@ -33,14 +33,14 @@
(lambda (name) (lambda (name)
(hash-ref table name (lambda () #f))))) (hash-ref table name (lambda () #f)))))
;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content) ;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content)
(define (gen-read-sgml may-contain auto-insert) (define (gen-read-sgml may-contain auto-insert)
(case-lambda (case-lambda
[(in) (read-from-port may-contain auto-insert in)] [(in) (read-from-port may-contain auto-insert in)]
[() (read-from-port may-contain auto-insert (current-input-port))])) [() (read-from-port may-contain auto-insert (current-input-port))]))
;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content) ;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content)
(define (read-from-port may-contain auto-insert in) (define (read-from-port may-contain auto-insert in)
(let loop ([tokens (let read-tokens () (let loop ([tokens (let read-tokens ()
(let ([tok (lex in)]) (let ([tok (lex in)])
(cond (cond
@ -58,18 +58,18 @@
[else (let ([rest-contents (loop rest-tokens)]) [else (let ([rest-contents (loop rest-tokens)])
(expand-content tok rest-contents))]))]))) (expand-content tok rest-contents))]))])))
;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token) ;; read-element : Start-tag (listof Symbol) Kid-lister (Symbol Symbol -> (U #f Symbol)) (listof Token) -> Element (listof Token)
;; Note: How elements nest depends on their content model. ;; Note: How elements nest depends on their content model.
;; If a kind of element can't contain anything, then its start tags are implicitly ended, and ;; If a kind of element can't contain anything, then its start tags are implicitly ended, and
;; end tags are implicitly started. ;; end tags are implicitly started.
;; Unknown elements can contain anything and can go inside anything. ;; Unknown elements can contain anything and can go inside anything.
;; Otherwise, only the subelements listed in the content model can go inside an element. ;; Otherwise, only the subelements listed in the content model can go inside an element.
;; more here - may-contain shouldn't be used to decide if an element is known or not. ;; more here - may-contain shouldn't be used to decide if an element is known or not.
;; The edgar dtd puts tags in may-contain's range that aren't in its domain. ;; The edgar dtd puts tags in may-contain's range that aren't in its domain.
;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the ;; more here (or not) - the (memq name context) test leaks for a worst case of O(n^2) in the
;; tag nesting depth. However, this only should be a problem when the tag is there, ;; tag nesting depth. However, this only should be a problem when the tag is there,
;; but far back. That shouldn't happen often. I'm guessing n will be about 3. ;; but far back. That shouldn't happen often. I'm guessing n will be about 3.
(define (read-element start-tag context may-contain auto-insert tokens) (define (read-element start-tag context may-contain auto-insert tokens)
(let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens]) (let read-el ([start-tag start-tag] [context (cons (start-tag-name start-tag) context)] [tokens tokens])
(let* ([start-name (start-tag-name start-tag)] (let* ([start-name (start-tag-name start-tag)]
[ok-kids (may-contain start-name)]) [ok-kids (may-contain start-name)])
@ -116,8 +116,8 @@
content) content)
remaining))))) remaining)))))
;; expand-content : Content (listof Content) -> (listof Content) ;; expand-content : Content (listof Content) -> (listof Content)
(define (expand-content x lst) (define (expand-content x lst)
(cond (cond
[(entity? x) (cons (expand-entity x) lst)] [(entity? x) (cons (expand-entity x) lst)]
[(comment? x) (if (read-html-comments) [(comment? x) (if (read-html-comments)
@ -125,16 +125,16 @@
lst)] lst)]
[else (cons x lst)])) [else (cons x lst)]))
;; expand-entity : Entity -> (U Entity Pcdata) ;; expand-entity : Entity -> (U Entity Pcdata)
;; more here - allow expansion of user defined entities ;; more here - allow expansion of user defined entities
(define (expand-entity x) (define (expand-entity x)
(let ([expanded (default-entity-table (entity-text x))]) (let ([expanded (default-entity-table (entity-text x))])
(if expanded (if expanded
(make-pcdata (source-start x) (source-stop x) expanded) (make-pcdata (source-start x) (source-stop x) expanded)
x))) x)))
;; default-entity-table : Symbol -> (U #f String) ;; default-entity-table : Symbol -> (U #f String)
(define (default-entity-table name) (define (default-entity-table name)
(case name (case name
[(amp) "&"] [(amp) "&"]
[(lt) "<"] [(lt) "<"]
@ -143,8 +143,8 @@
[(apos) "'"] [(apos) "'"]
[else #f])) [else #f]))
;; lex : Input-port -> Token ;; lex : Input-port -> Token
(define (lex in) (define (lex in)
(when (trim-whitespace) (when (trim-whitespace)
(skip-space in)) (skip-space in))
(let ([c (peek-char in)]) (let ([c (peek-char in)])
@ -154,9 +154,9 @@
[(eq? c #\<) (lex-tag-cdata-pi-comment in)] [(eq? c #\<) (lex-tag-cdata-pi-comment in)]
[else (lex-pcdata in)]))) [else (lex-pcdata in)])))
;; lex-entity : Input-port -> Token ;; lex-entity : Input-port -> Token
;; This might not return an entity if it doesn't look like one afterall. ;; This might not return an entity if it doesn't look like one afterall.
(define (lex-entity in) (define (lex-entity in)
(let ([start (file-position in)]) (let ([start (file-position in)])
(read-char in) (read-char in)
(case (peek-char in) (case (peek-char in)
@ -181,8 +181,8 @@
(begin (read-char in) (make-entity start (file-position in) name)) (begin (read-char in) (make-entity start (file-position in) name))
(make-pcdata start (file-position in) (format "&~a" name))))]))) (make-pcdata start (file-position in) (format "&~a" name))))])))
;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment ;; lex-tag-cdata-pi-comment : Input-port -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
(define (lex-tag-cdata-pi-comment in) (define (lex-tag-cdata-pi-comment in)
(let ([start (file-position in)]) (let ([start (file-position in)])
(read-char in) (read-char in)
(case (peek-char in) (case (peek-char in)
@ -224,8 +224,8 @@
[else (make-start-tag start (file-position in) name attrs)]))]))) [else (make-start-tag start (file-position in) name attrs)]))])))
;; lex-attributes : Input-port -> (listof Attribute) ;; lex-attributes : Input-port -> (listof Attribute)
(define (lex-attributes in) (define (lex-attributes in)
(sort (let loop () (sort (let loop ()
(skip-space in) (skip-space in)
(cond [(name-start? (peek-char in)) (cond [(name-start? (peek-char in))
@ -235,9 +235,9 @@
(string<? (symbol->string (attribute-name a)) (string<? (symbol->string (attribute-name a))
(symbol->string (attribute-name b)))))) (symbol->string (attribute-name b))))))
;; lex-attribute : Input-port -> Attribute ;; lex-attribute : Input-port -> Attribute
;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax ;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax
(define (lex-attribute in) (define (lex-attribute in)
(let ([start (file-position in)] (let ([start (file-position in)]
[name (lex-name in)]) [name (lex-name in)])
(skip-space in) (skip-space in)
@ -258,18 +258,18 @@
(make-attribute start (file-position in) name value))] (make-attribute start (file-position in) name value))]
[else (make-attribute start (file-position in) name (symbol->string name))]))) [else (make-attribute start (file-position in) name (symbol->string name))])))
;; skip-space : Input-port -> Void ;; skip-space : Input-port -> Void
;; deviation - should sometimes insist on at least one space ;; deviation - should sometimes insist on at least one space
(define (skip-space in) (define (skip-space in)
(let loop () (let loop ()
(let ([c (peek-char in)]) (let ([c (peek-char in)])
(when (and (not (eof-object? c)) (char-whitespace? c)) (when (and (not (eof-object? c)) (char-whitespace? c))
(read-char in) (read-char in)
(loop))))) (loop)))))
;; lex-pcdata : Input-port -> Pcdata ;; lex-pcdata : Input-port -> Pcdata
;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec
(define (lex-pcdata in) (define (lex-pcdata in)
(let ([start (file-position in)]) (let ([start (file-position in)])
;; The following regexp match must use bytes, not chars, because ;; The following regexp match must use bytes, not chars, because
;; `in' might not be a well-formed UTF-8 sequence. If it isn't, ;; `in' might not be a well-formed UTF-8 sequence. If it isn't,
@ -284,7 +284,7 @@
(regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"") (regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"")
(car s)) (car s))
#\?))))) #\?)))))
#| #|
;; Original slow version: ;; Original slow version:
(define (lex-pcdata in) (define (lex-pcdata in)
(let ([start (file-position in)] (let ([start (file-position in)]
@ -306,8 +306,8 @@
|# |#
;; lex-name : Input-port -> Symbol ;; lex-name : Input-port -> Symbol
(define (lex-name in) (define (lex-name in)
(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
(string->symbol (string->symbol
;; Common case: string is already lowercased ;; Common case: string is already lowercased
@ -316,11 +316,11 @@
(string-lowercase! s) (string-lowercase! s)
s) s)
s)))) s))))
;; lex-name/case-sensitive : Input-port -> Symbol ;; lex-name/case-sensitive : Input-port -> Symbol
(define (lex-name/case-sensitive in) (define (lex-name/case-sensitive in)
(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))]) (let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
(string->symbol s))) (string->symbol s)))
#| #|
(define (lex-name in) (define (lex-name in)
(string->symbol (string->symbol
(list->string (list->string
@ -332,8 +332,8 @@
|# |#
;; skip-dtd : Input-port -> Void ;; skip-dtd : Input-port -> Void
(define (skip-dtd in) (define (skip-dtd in)
(let skip () (let skip ()
(let ([c (read-char in)]) (let ([c (read-char in)])
(if (eof-object? c) (if (eof-object? c)
@ -351,18 +351,18 @@
[(#\>) (void)] [(#\>) (void)]
[else (skip)]))))) [else (skip)])))))
;; name-start? : TST -> Bool ;; name-start? : TST -> Bool
(define (name-start? ch) (define (name-start? ch)
(and (char? ch) (char-name-start? ch))) (and (char? ch) (char-name-start? ch)))
;; char-name-start? : Char -> Bool ;; char-name-start? : Char -> Bool
(define (char-name-start? ch) (define (char-name-start? ch)
(or (char-alphabetic? ch) (or (char-alphabetic? ch)
(eq? ch #\_) (eq? ch #\_)
(eq? ch #\:))) (eq? ch #\:)))
;; name-char? : TST -> Bool ;; name-char? : TST -> Bool
(define (name-char? ch) (define (name-char? ch)
(and (char? ch) (and (char? ch)
(or (char-name-start? ch) (or (char-name-start? ch)
(char-numeric? ch) (char-numeric? ch)
@ -370,18 +370,18 @@
(eq? ch #\.) (eq? ch #\.)
(eq? ch #\-)))) (eq? ch #\-))))
;; read-up-to : (Char -> Bool) Input-port -> (listof Char) ;; read-up-to : (Char -> Bool) Input-port -> (listof Char)
;; abstract this with read-until ;; abstract this with read-until
(define (read-up-to p? in) (define (read-up-to p? in)
(let loop () (let loop ()
(let ([c (peek-char in)]) (let ([c (peek-char in)])
(cond (cond
[(or (eof-object? c) (p? c)) null] [(or (eof-object? c) (p? c)) null]
[else (cons (read-char in) (loop))])))) [else (cons (read-char in) (loop))]))))
;; read-until : Char Input-port -> String ;; read-until : Char Input-port -> String
;; discards the stop character, too ;; discards the stop character, too
(define (read-until char in) (define (read-until char in)
(list->string (list->string
(let read-more () (let read-more ()
(let ([c (read-char in)]) (let ([c (read-char in)])
@ -389,11 +389,11 @@
[(or (eof-object? c) (eq? c char)) null] [(or (eof-object? c) (eq? c char)) null]
[else (cons c (read-more))]))))) [else (cons c (read-more))])))))
;; gen-read-until-string : String -> Input-port -> String ;; gen-read-until-string : String -> Input-port -> String
;; uses Knuth-Morris-Pratt from ;; uses Knuth-Morris-Pratt from
;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
;; discards stop from input ;; discards stop from input
(define (gen-read-until-string stop) (define (gen-read-until-string stop)
(let* ([len (string-length stop)] (let* ([len (string-length stop)]
[prefix (make-vector len 0)] [prefix (make-vector len 0)]
[fall-back [fall-back
@ -423,7 +423,7 @@
[(zero? matched) (cons c (let/ec out (loop matched out)))] [(zero? matched) (cons c (let/ec out (loop matched out)))]
[else (cons c (loop matched out))])))))))) [else (cons c (loop matched out))]))))))))
;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore. ;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore.
(define lex-comment-contents (gen-read-until-string "-->")) (define lex-comment-contents (gen-read-until-string "-->"))
(define lex-pi-data (gen-read-until-string "?>")) (define lex-pi-data (gen-read-until-string "?>"))
(define lex-cdata-contents (gen-read-until-string "]]>")) (define lex-cdata-contents (gen-read-until-string "]]>"))