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

removing dead code

Browse Source 
svn: r13870
This commit is contained in:
Jay McCarthy 2009-02-27 18:07:59 +00:00
parent 51094cb359
commit 20424b47a4
17 changed files with 506 additions and 1663 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

489
collects/html/case.ss
View File

@ -1,489 +0,0 @@
;;This file was generated by genrate-code.ss on Friday, September 1st, 2000 11:09:43am
;; xml-single-content->html : Content (listof Html-content) -> (listof Html-content)
(define (xml-single-content->html x acc)
(cond
((element? x)
(case (element-name x)
((basefont) (cons (make-basefont (element-attributes x)) acc))
((br) (cons (make-br (element-attributes x)) acc))
((area) (cons (make-area (element-attributes x)) acc))
((link) (cons (make-link (element-attributes x)) acc))
((img) (cons (make-img (element-attributes x)) acc))
((param) (cons (make-param (element-attributes x)) acc))
((hr) (cons (make-hr (element-attributes x)) acc))
((input) (cons (make-input (element-attributes x)) acc))
((col) (cons (make-col (element-attributes x)) acc))
((isindex) (cons (make-isindex (element-attributes x)) acc))
((base) (cons (make-base (element-attributes x)) acc))
((meta) (cons (make-meta (element-attributes x)) acc))
((mzscheme)
(cons
(make-mzscheme
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((html)
(cons
(make-html
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((div)
(cons
(make-div
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((center)
(cons
(make-center
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((blockquote)
(cons
(make-blockquote
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((ins)
(cons
(make-ins
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((del)
(cons
(make-del
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dd)
(cons
(make-dd
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((li)
(cons
(make-li
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((th)
(cons
(make-th
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((td)
(cons
(make-td
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((iframe)
(cons
(make-iframe
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((noframes)
(cons
(make-noframes
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((noscript)
(cons
(make-noscript
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((style)
(cons
(make-style
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((script)
(cons
(make-script
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((option)
(cons
(make-option
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((textarea)
(cons
(make-textarea
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((title)
(cons
(make-title
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((head)
(cons
(make-head
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((tr)
(cons
(make-tr
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((colgroup)
(cons
(make-colgroup
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((thead)
(cons
(make-thead
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((tfoot)
(cons
(make-tfoot
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((tbody)
(cons
(make-tbody
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((tt)
(cons
(make-tt
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((i)
(cons
(make-i
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((b)
(cons
(make-b
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((u)
(cons
(make-u
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((s)
(cons
(make-s
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((strike)
(cons
(make-strike
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((big)
(cons
(make-big
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((small)
(cons
(make-small
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((em)
(cons
(make-em
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((strong)
(cons
(make-strong
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dfn)
(cons
(make-dfn
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((code)
(cons
(make-code
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((samp)
(cons
(make-samp
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((kbd)
(cons
(make-kbd
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((var)
(cons
(make-var
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((cite)
(cons
(make-cite
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((abbr)
(cons
(make-abbr
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((acronym)
(cons
(make-acronym
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((sub)
(cons
(make-sub
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((sup)
(cons
(make-sup
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((span)
(cons
(make-span
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((bdo)
(cons
(make-bdo
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((font)
(cons
(make-font
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((p)
(cons
(make-p
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h1)
(cons
(make-h1
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h2)
(cons
(make-h2
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h3)
(cons
(make-h3
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h4)
(cons
(make-h4
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h5)
(cons
(make-h5
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h6)
(cons
(make-h6
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((q)
(cons
(make-q
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dt)
(cons
(make-dt
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((legend)
(cons
(make-legend
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((caption)
(cons
(make-caption
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((table)
(cons
(make-table
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((button)
(cons
(make-button
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((fieldset)
(cons
(make-fieldset
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((optgroup)
(cons
(make-optgroup
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((select)
(cons
(make-select
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((label)
(cons
(make-label
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((form)
(cons
(make-form
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((ol)
(cons
(make-ol
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((ul)
(cons
(make-ul
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dir)
(cons
(make-dir
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((menu)
(cons
(make-menu
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dl)
(cons
(make-dl
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((pre)
(cons
(make-pre
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((object)
(cons
(make-object (element-attributes x)
(xml-contents->html (element-content x)))
acc))
((applet)
(cons
(make-applet
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((map)
(cons
(make--map
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((a)
(cons
(make-a
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((address)
(cons
(make-address
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((body)
(cons
(make-body
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
(else acc)))
((or (pcdata? x) (entity? x)) (cons x acc))
(else acc)))

23
collects/html/dtd-ast.ss
View File

@ -1,23 +0,0 @@
;; copyright by Paul Graunke June 2000 AD
(module dtd-ast mzscheme
(provide (struct dtd-item ())
(struct element-def (name start-optional stop-optional content))
(struct att-list (name junk))
(struct entity-def (name value))
(struct thingy (uh whatever)))
;; Dtd ::= (listof Dtd-item)
;; Dtd-item ::= (make-element-def (listof Symbol) Bool Bool Content-model)
;; | (make-att-list (listof Symbol) String) ;; more here - parse the String
;; | (make-entity-def Symbol String)
;; | (make-thingy String String) ;; more here - what is <![ foo [ bar baz...]]> this?
(define-struct dtd-item ())
(define-struct (element-def struct:dtd-item) (name start-optional stop-optional content))
(define-struct (att-list struct:dtd-item) (name junk))
(define-struct (entity-def struct:dtd-item) (name value))
(define-struct (thingy struct:dtd-item) (uh whatever))
;; Content-model ::= String
;; more here - parse content-models
)

205
collects/html/dtd.ss
View File

@ -1,205 +0,0 @@
; copyright by Paul Graunke June 2000 AD
(module dtd mzscheme
(require "dtd-ast.ss" "entity-expander.ss"
mzlib/list
mzlib/string)
(provide read-sgml-dtd summarize-dtd)
; Note: this library only supports a the subset of SGML used for HTML as descibed in
; http://www.w3.org/TR/html401/intro/sgmltut.html
; Spec = (listof (cons (listof Symbol) (listof Symbol)))
; read-sgml-dtd : Input-port -> Dtd
(define (read-sgml-dtd in)
(parameterize ([read-case-sensitive #t])
(let ([in (filter-comments in)])
(let read-items ()
(let skip-entity-refs ()
(skip-whitespace in)
(when (eq? (peek-char in) #\%)
(skip-until (lambda (c) (eq? c #\;)) in)
(skip-entity-refs)))
(cond
[(eof-object? (peek-char in)) null]
[else
(unless (and (eq? (read-char in) #\<)
(eq? (read-char in) #\!))
(error 'read-sgml-dtd "unknown junk in dtd at ~a" (file-position in)))
(case (peek-char in)
[(#\>) (read-char in) (read-items)]
[(#\[) (read-char in)
(skip-whitespace in)
(let ([uh (read-id in)])
(skip-until (lambda (c) (eq? c #\[)) in)
(cons (begin0 (make-thingy uh (read-until (lambda (c) (eq? c #\])) in))
(unless (and (eq? (read-char in) #\]) (eq? (read-char in) #\>))
(error 'read-sgml-dtd "Invalid <![ uh [ whatever ]]> thingy.")))
(read-items)))]
[else (cons (let ([name (read-id in)])
(case name
[(entity) (skip-until (lambda (c) (eq? c #\%)) in)
(skip-whitespace in)
(begin0 (make-entity-def (read-until char-whitespace? in); more here check case sensitivity ; (read-id in)
(begin (skip-until quote? in) (read-until quote? in)))
(skip-until gt? in))]
[(element)
(make-element-def (read-names in)
(read-required/optional in)
(read-required/optional in)
(read-until gt? in))]
[(attlist)
(make-att-list (read-names in) (read-until gt? in))]
[else (error 'read-sgml-dtd "Unknown name: <!~s ...>" name)]))
(read-items))])])))))
; quote? : Char -> Bool
(define (quote? c) (eq? c #\"))
; gt? : Char -> Bool
(define (gt? c) (eq? c #\>))
; read-names : Input-port -> (listof Symbol)
(define (read-names in)
(skip-whitespace in)
(case (peek-char in)
[(#\() (read-char in)
(skip-whitespace in)
(cons (read-id in)
(let loop ()
(skip-whitespace in)
(case (read-char in)
[(#\| #\,) (skip-whitespace in) (cons (read-id in) (loop))]
[(#\)) null]
[else (error 'read-names "unexpected character in element names '~a'" (read-line in))])))]
[else (list (read-id in))]))
; read-required/optional : Input-port -> Bool
(define (read-required/optional in)
(skip-whitespace in)
(eq? (char-downcase (read-char in)) #\o))
; read-id : Input-port -> Symbol
(define (read-id in)
(string->symbol
(list->string
(let loop ()
(let ([c (peek-char in)])
(if (and (not (eof-object? c))
(or (char-id? c)
; this is a hack - allowing % and ; characters accepts parameter entities.
(memq c '(#\% #\;))))
(cons (char-downcase c) (begin (read-char in) (loop)))
null))))))
; char-id? : Char -> Bool
; Note: the & is not legal, really, but SEC's Edgar format uses it. Yuck.
; Nope. & messes up SGML dtds - remove it.
(define (char-id? c)
(or (char-alphabetic? c) (char-numeric? c) (memq c '(#\_ #\- #\: #\.))))
; skip-whitespace : Input-port -> Void
(define (skip-whitespace in) (skip-past char-whitespace? in))
; skip-past : (Char -> Bool) Input-port -> Void
(define (skip-past skip? in)
(let loop ()
(when (let ([c (peek-char in)])
(and (not (eof-object? c)) (skip? c)))
(read-char in)
(loop))))
; skip-until : (Char -> Bool) Input-port -> Void
(define (skip-until delimiter? in)
(let loop ()
(unless (delimiter? (read-char in))
(loop))))
; read-until : (Char -> Bool) Input-port -> String
; skips delimiter
(define (read-until delimiter? in)
(list->string
(let loop ()
(let ([c (read-char in)])
(if (delimiter? c)
null
(cons c (loop)))))))
; filter-comments : Input-port -> Input-port
; Note: <!-- blah --> comments come out <!>, which need to be removed later.
(define (filter-comments in)
(make-input-port
(lambda ()
(let ([char (read-char in)])
(if (and (eq? char #\-) (eq? (peek-char in) #\-))
(let loop ()
(if (and (eq? (read-char in) #\-) (eq? (read-char in) #\-))
(read-char in)
(loop)))
char)))
(lambda ()
; more here - this is broken if the next char is #\- and starts a comment and more chars
; aren't ready after the comment.
(char-ready? in))
(lambda () (close-input-port in))))
; summarize-dtd : Dtd -> Spec
(define (summarize-dtd dtd)
(let ([expander
(foldr (lambda (x acc)
(extend-entity-expander (entity-def-name x) (entity-def-value x) acc))
empty-entity-expander
(filter entity-def? dtd))]
[hack-content ;: String -> (listof Symbol)
(lambda (content)
(let* ([stripped (filter (lambda (x) (not (char-whitespace? x))) (string->list content))]
[cludged (map (lambda (c)
(cond
[(char-id? c) c]
[else #\space]))
stripped)]
[symbols (read-from-string-all (list->string cludged))]
[nix (memq '- symbols)])
(cond
[nix (filter (lambda (s) (not (memq s nix))) symbols)]
[(and (pair? symbols) (null? (cdr symbols)) (eq? (car symbols) 'empty)) null]
[else symbols])))])
(merge-contents
(map (lambda (x)
(cons (foldr (lambda (s acc)
(let ([in (open-input-string
(format "(~a)" (expand-entities expander (symbol->string s))))])
(append (read-names in) acc)))
null
(element-def-name x))
(sort (hack-content (expand-entities expander (element-def-content x)))
(lambda (a b)
(string<=? (symbol->string a)
(symbol->string b))))))
(filter element-def? dtd)))))
; merge-contents : Spec -> Spec
(define merge-contents
(letrec ([comb
(lambda (x rst)
(cond
[(null? rst) (list x)]
[else (cond
[(equal? (cdr x) (cdar rst))
(cons (cons (append (car x) (caar rst))
(cdr x))
(cdr rst))]
[else (cons (car rst) (comb x (cdr rst)))])]))])
(lambda (lst)
(cond
[(null? lst) null]
[else (comb (car lst)
(merge-contents (cdr lst)))])))))
; loosedtd.txt is from www.w3c.org's html4.0.1 spec.
;(define dtd (call-with-input-file "/home/ptg/world/junk/loosedtd.txt" read-sgml-dtd))
;(call-with-output-file "html-spec"
; (lambda (out) (write (cons '((mzscheme) pcdata) (summarize-dtd dtd)) out))
; 'truncate)

192
collects/html/dtdr.ss
View File

@ -1,192 +0,0 @@
;; copyright by Paul Graunke June 2000 AD
(unit/sig dtd^
(import dtd-ast^ entity-expander^ mzlib:function^ mzlib:string^)
;; Note: this library only supports a the subset of SGML used for HTML as descibed in
;; http://www.w3.org/TR/html401/intro/sgmltut.html
;; Spec = (listof (cons (listof Symbol) (listof Symbol)))
;; read-sgml-dtd : Input-port -> Dtd
(define (read-sgml-dtd in)
(parameterize ([read-case-sensitive #t])
(let ([in (filter-comments in)])
(let read-items ()
(let skip-entity-refs ()
(skip-whitespace in)
(when (eq? (peek-char in) #\%)
(skip-until (lambda (c) (eq? c #\;)) in)
(skip-entity-refs)))
(cond
[(eof-object? (peek-char in)) null]
[else
(unless (and (eq? (read-char in) #\<)
(eq? (read-char in) #\!))
(error 'read-sgml-dtd "unknown junk in dtd at ~a" (file-position in)))
(case (peek-char in)
[(#\>) (read-char in) (read-items)]
[(#\[) (read-char in)
(skip-whitespace in)
(let ([uh (read-id in)])
(skip-until (lambda (c) (eq? c #\[)) in)
(cons (begin0 (make-thingy uh (read-until (lambda (c) (eq? c #\])) in))
(unless (and (eq? (read-char in) #\]) (eq? (read-char in) #\>))
(error 'read-sgml-dtd "Invalid <![ uh [ whatever ]]> thingy.")))
(read-items)))]
[else (cons (let ([name (read-id in)])
(case name
[(entity) (skip-until (lambda (c) (eq? c #\%)) in)
(skip-whitespace in)
(begin0 (make-entity-def (read-until char-whitespace? in); more here check case sensitivity ; (read-id in)
(begin (skip-until quote? in) (read-until quote? in)))
(skip-until gt? in))]
[(element)
(make-element-def (read-names in)
(read-required/optional in)
(read-required/optional in)
(read-until gt? in))]
[(attlist)
(make-att-list (read-names in) (read-until gt? in))]
[else (error 'read-sgml-dtd "Unknown name: <!~s ...>" name)]))
(read-items))])])))))
;; quote? : Char -> Bool
(define (quote? c) (eq? c #\"))
;; gt? : Char -> Bool
(define (gt? c) (eq? c #\>))
;; read-names : Input-port -> (listof Symbol)
(define (read-names in)
(skip-whitespace in)
(case (peek-char in)
[(#\() (read-char in)
(skip-whitespace in)
(cons (read-id in)
(let loop ()
(skip-whitespace in)
(case (read-char in)
[(#\| #\,) (skip-whitespace in) (cons (read-id in) (loop))]
[(#\)) null]
[else (error 'read-names "unexpected character in element names '~a'" (read-line in))])))]
[else (list (read-id in))]))
;; read-required/optional : Input-port -> Bool
(define (read-required/optional in)
(skip-whitespace in)
(eq? (char-downcase (read-char in)) #\o))
;; read-id : Input-port -> Symbol
(define (read-id in)
(string->symbol
(list->string
(let loop ()
(let ([c (peek-char in)])
(if (and (not (eof-object? c))
(or (char-id? c)
;; this is a hack - allowing % and ; characters accepts parameter entities.
(memq c '(#\% #\;))))
(cons (char-downcase c) (begin (read-char in) (loop)))
null))))))
;; char-id? : Char -> Bool
;; Note: the & is not legal, really, but SEC's Edgar format uses it. Yuck.
;; Nope. & messes up SGML dtds - remove it.
(define (char-id? c)
(or (char-alphabetic? c) (char-numeric? c) (memq c '(#\_ #\- #\: #\.))))
;; skip-whitespace : Input-port -> Void
(define (skip-whitespace in) (skip-past char-whitespace? in))
;; skip-past : (Char -> Bool) Input-port -> Void
(define (skip-past skip? in)
(let loop ()
(when (let ([c (peek-char in)])
(and (not (eof-object? c)) (skip? c)))
(read-char in)
(loop))))
;; skip-until : (Char -> Bool) Input-port -> Void
(define (skip-until delimiter? in)
(let loop ()
(unless (delimiter? (read-char in))
(loop))))
;; read-until : (Char -> Bool) Input-port -> String
;; skips delimiter
(define (read-until delimiter? in)
(list->string
(let loop ()
(let ([c (read-char in)])
(if (delimiter? c)
null
(cons c (loop)))))))
;; filter-comments : Input-port -> Input-port
;; Note: <!-- blah --> comments come out <!>, which need to be removed later.
(define (filter-comments in)
(make-input-port
(lambda ()
(let ([char (read-char in)])
(if (and (eq? char #\-) (eq? (peek-char in) #\-))
(let loop ()
(if (and (eq? (read-char in) #\-) (eq? (read-char in) #\-))
(read-char in)
(loop)))
char)))
(lambda ()
;; more here - this is broken if the next char is #\- and starts a comment and more chars
;; aren't ready after the comment.
(char-ready? in))
(lambda () (close-input-port in))))
;; summarize-dtd : Dtd -> Spec
(define (summarize-dtd dtd)
(let ([expander
(foldr (lambda (x acc)
(extend-entity-expander (entity-def-name x) (entity-def-value x) acc))
empty-entity-expander
(filter entity-def? dtd))]
[hack-content ;: String -> (listof Symbol)
(lambda (content)
(let* ([stripped (filter (lambda (x) (not (char-whitespace? x))) (string->list content))]
[cludged (map (lambda (c)
(cond
[(char-id? c) c]
[else #\space]))
stripped)]
[symbols (read-from-string-all (list->string cludged))]
[nix (memq '- symbols)])
(cond
[nix (filter (lambda (s) (not (memq s nix))) symbols)]
[(and (pair? symbols) (null? (cdr symbols)) (eq? (car symbols) 'empty)) null]
[else symbols])))])
(merge-contents
(map (lambda (x)
(cons (foldr (lambda (s acc)
(let ([in (open-input-string
(format "(~a)" (expand-entities expander (symbol->string s))))])
(append (read-names in) acc)))
null
(element-def-name x))
(sort (hack-content (expand-entities expander (element-def-content x)))
(lambda (a b)
(string<=? (symbol->string a)
(symbol->string b))))))
(filter element-def? dtd)))))
;; merge-contents : Spec -> Spec
(define merge-contents
(letrec ([comb
(lambda (x rst)
(cond
[(null? rst) (list x)]
[else (cond
[(equal? (cdr x) (cdar rst))
(cons (cons (append (car x) (caar rst))
(cdr x))
(cdr rst))]
[else (cons (car rst) (comb x (cdr rst)))])]))])
(lambda (lst)
(cond
[(null? lst) null]
[else (comb (car lst)
(merge-contents (cdr lst)))])))))

13
collects/html/dtds.ss
View File

@ -1,13 +0,0 @@
;; copyright by Paul Graunke June 2000 AD
(define-signature dtd-ast^
((struct dtd-item ())
(struct element-def (name start-optional stop-optional content))
(struct att-list (name junk))
(struct entity-def (name value))
(struct thingy (uh whatever))))
(define-signature dtd^ (read-sgml-dtd summarize-dtd))
(define-signature entity-expander^ (empty-entity-expander extend-entity-expander expand-entities))
(require-library "functios.ss")
(require-library "strings.ss")

27
collects/html/entity-expander.ss
View File

@ -1,27 +0,0 @@
;; copyright by Paul Graunke June 2000 AD
(module entity-expander mzscheme
(provide empty-entity-expander extend-entity-expander expand-entities)
;; warning - this is a really inefficient implementation of a nice interface.
;; building one dfa would be much better
;; Entity-expander : String -> String
;; empty-entity-expander : Entity-expander
(define (empty-entity-expander x) x)
;; extend-entity-expander : Symbol String Entity-expander -> Entity-expander
(define extend-entity-expander
(let ([fix-rhs (regexp "&")])
(lambda (name rhs to-extend)
(let ([pattern (regexp (format "%~a;?" name))]
[rhs (regexp-replace* fix-rhs rhs "\\\\&")])
(lambda (input)
(to-extend (regexp-replace* pattern input rhs)))))))
;; expand-entities : Entity-expander String -> String
(define (expand-entities expander string)
(let loop ([prev string])
(let ([new (expander prev)])
(if (string=? new prev)
new
(loop new))))))

71
collects/html/generate-code.ss
View File

@ -1,71 +0,0 @@
; copyright by Paul Graunke June 2000 AD
(require mzlib/pretty
mzlib/date
mzlib/list
mzlib/etc
"html-spec.ss")
; date-string : -> String
(define (date-string) (date->string (seconds->date (current-seconds)) 'seconds-please))
(define (empty-name? x) (null? (cdr x)))
(define empty-names
(apply append (map car (filter empty-name? html-spec))))
(define non-empty-names
(apply append (map car (filter (compose not empty-name?) html-spec))))
; generate-structs : -> Void
(define (generate-structs)
(let ([file (build-path (collection-path "html") "html-structs.ss")])
(printf "building ~a~n" file)
(call-with-output-file file
(lambda (out)
(fprintf out "; This code was machine generated by generate-code.ss ~a~n" (date-string))
(for-each
(lambda (x) (pretty-print x out))
(append
(list
'(define-struct html-element (attributes))
`(define-struct (html-full html-element) (content)))
(map (lambda (x) `(define-struct (,x html-full) ()))
non-empty-names)
(map (lambda (x)
`(define-struct (,x html-element) ()))
empty-names))))
'text 'truncate)))
; generate-case : -> Void
(define (generate-case)
(let ([file (build-path (collection-path "html") "case.ss")])
(printf "building ~a~n" file)
(call-with-output-file file
(lambda (out)
(fprintf out ";This file was generated by genrate-code.ss on ~a~n" (date-string))
(fprintf out "~n; xml-single-content->html : Content (listof Html-content) -> (listof Html-content)~n")
(pretty-print
`(define (xml-single-content->html x acc)
(cond
[(element? x)
(case (element-name x)
,@(append
(map (lambda (name)
`[(,name) (cons (,(string->symbol (string-append "make-" (symbol->string name)))
(element-attributes x))
acc)])
empty-names)
(map (lambda (name)
`[(,name) (cons (,(string->symbol (string-append "make-" (symbol->string name)))
(element-attributes x)
(xml-contents->html (element-content x)))
acc)])
non-empty-names))
[else acc])]
[(or (pcdata? x) (entity? x)) (cons x acc)]
[else acc]))
out))
'truncate 'text)))
(generate-structs)
(generate-case)

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

@ -1,21 +1,506 @@
#lang scheme #lang scheme
;; copyright by Paul Graunke June 2000 AD ;; copyright by Paul Graunke June 2000 AD
(require mzlib/file (require "html-structs.ss"
mzlib/list
mzlib/etc
mzlib/include
"html-spec.ss" "html-spec.ss"
"html-sig.ss"
(prefix-in sgml: "sgml-reader.ss") (prefix-in sgml: "sgml-reader.ss")
xml) xml)
(provide-signature-elements html^) (provide (all-from-out "html-structs.ss")
read-xhtml
read-html
read-html-as-xml
use-html-spec)
;; Html-content = Html-element | Pc-data | Entity ;; Html-content = Html-element | Pc-data | Entity
(include "html-structs.ss") ;; xml-single-content->html : Content (listof Html-content) -> (listof Html-content)
(include "case.ss") (define (xml-single-content->html x acc)
(cond
((element? x)
(case (element-name x)
((basefont) (cons (make-basefont (element-attributes x)) acc))
((br) (cons (make-br (element-attributes x)) acc))
((area) (cons (make-area (element-attributes x)) acc))
((link) (cons (make-link (element-attributes x)) acc))
((img) (cons (make-img (element-attributes x)) acc))
((param) (cons (make-param (element-attributes x)) acc))
((hr) (cons (make-hr (element-attributes x)) acc))
((input) (cons (make-input (element-attributes x)) acc))
((col) (cons (make-col (element-attributes x)) acc))
((isindex) (cons (make-isindex (element-attributes x)) acc))
((base) (cons (make-base (element-attributes x)) acc))
((meta) (cons (make-meta (element-attributes x)) acc))
((mzscheme)
(cons
(make-mzscheme
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((html)
(cons
(make-html
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((div)
(cons
(make-div
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((center)
(cons
(make-center
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((blockquote)
(cons
(make-blockquote
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((ins)
(cons
(make-ins
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((del)
(cons
(make-del
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dd)
(cons
(make-dd
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((li)
(cons
(make-li
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((th)
(cons
(make-th
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((td)
(cons
(make-td
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((iframe)
(cons
(make-iframe
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((noframes)
(cons
(make-noframes
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((noscript)
(cons
(make-noscript
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((style)
(cons
(make-style
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((script)
(cons
(make-script
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((option)
(cons
(make-option
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((textarea)
(cons
(make-textarea
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((title)
(cons
(make-title
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((head)
(cons
(make-head
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((tr)
(cons
(make-tr
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((colgroup)
(cons
(make-colgroup
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((thead)
(cons
(make-thead
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((tfoot)
(cons
(make-tfoot
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((tbody)
(cons
(make-tbody
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((tt)
(cons
(make-tt
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((i)
(cons
(make-i
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((b)
(cons
(make-b
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((u)
(cons
(make-u
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((s)
(cons
(make-s
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((strike)
(cons
(make-strike
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((big)
(cons
(make-big
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((small)
(cons
(make-small
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((em)
(cons
(make-em
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((strong)
(cons
(make-strong
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dfn)
(cons
(make-dfn
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((code)
(cons
(make-code
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((samp)
(cons
(make-samp
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((kbd)
(cons
(make-kbd
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((var)
(cons
(make-var
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((cite)
(cons
(make-cite
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((abbr)
(cons
(make-abbr
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((acronym)
(cons
(make-acronym
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((sub)
(cons
(make-sub
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((sup)
(cons
(make-sup
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((span)
(cons
(make-span
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((bdo)
(cons
(make-bdo
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((font)
(cons
(make-font
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((p)
(cons
(make-p
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h1)
(cons
(make-h1
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h2)
(cons
(make-h2
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h3)
(cons
(make-h3
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h4)
(cons
(make-h4
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h5)
(cons
(make-h5
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((h6)
(cons
(make-h6
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((q)
(cons
(make-q
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dt)
(cons
(make-dt
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((legend)
(cons
(make-legend
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((caption)
(cons
(make-caption
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((table)
(cons
(make-table
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((button)
(cons
(make-button
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((fieldset)
(cons
(make-fieldset
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((optgroup)
(cons
(make-optgroup
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((select)
(cons
(make-select
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((label)
(cons
(make-label
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((form)
(cons
(make-form
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((ol)
(cons
(make-ol
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((ul)
(cons
(make-ul
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dir)
(cons
(make-dir
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((menu)
(cons
(make-menu
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((dl)
(cons
(make-dl
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((pre)
(cons
(make-pre
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((object)
(cons
(make-object (element-attributes x)
(xml-contents->html (element-content x)))
acc))
((applet)
(cons
(make-applet
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((map)
(cons
(make--map
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((a)
(cons
(make-a
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((address)
(cons
(make-address
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
((body)
(cons
(make-body
(element-attributes x)
(xml-contents->html (element-content x)))
acc))
(else acc)))
((or (pcdata? x) (entity? x)) (cons x acc))
(else acc)))
;; xml->html : Document -> Html ;; xml->html : Document -> Html
(define (xml->html doc) (define (xml->html doc)

9
collects/html/html-sig.ss
View File

@ -1,9 +0,0 @@
;; copyright by Paul Graunke June 2000 AD
#lang scheme
(define-signature html-structs^ ((struct html-element (attributes)) (struct html-full (content)) (struct html ()) (struct div ()) (struct center ()) (struct blockquote ()) (struct ins ()) (struct del ()) (struct dd ()) (struct li ()) (struct th ()) (struct td ()) (struct iframe ()) (struct noframes ()) (struct noscript ()) (struct style ()) (struct script ()) (struct basefont ()) (struct br ()) (struct area ()) (struct link ()) (struct img ()) (struct param ()) (struct hr ()) (struct input ()) (struct col ()) (struct isindex ()) (struct base ()) (struct meta ()) (struct option ()) (struct textarea ()) (struct title ()) (struct head ()) (struct tr ()) (struct colgroup ()) (struct thead ()) (struct tfoot ()) (struct tbody ()) (struct tt ()) (struct i ()) (struct b ()) (struct u ()) (struct s ()) (struct strike ()) (struct big ()) (struct small ()) (struct em ()) (struct strong ()) (struct dfn ()) (struct code ()) (struct samp ()) (struct kbd ()) (struct var ()) (struct cite ()) (struct abbr ()) (struct acronym ()) (struct sub ()) (struct sup ()) (struct span ()) (struct bdo ()) (struct font ()) (struct p ()) (struct h1 ()) (struct h2 ()) (struct h3 ()) (struct h4 ()) (struct h5 ()) (struct h6 ()) (struct q ()) (struct dt ()) (struct legend ()) (struct caption ()) (struct table ()) (struct button ()) (struct fieldset ()) (struct optgroup ()) (struct select ()) (struct label ()) (struct form ()) (struct ol ()) (struct ul ()) (struct dir ()) (struct menu ()) (struct dl ()) (struct pre ()) (struct object ()) (struct applet ()) (struct -map ()) (struct a ()) (struct address ()) (struct body ())))
(define-signature html^ (read-xhtml read-html read-html-as-xml (open html-structs^)
use-html-spec))
(provide html^)

4
collects/html/html-structs.ss
View File

@ -1,4 +1,6 @@
;; This code was machine generated by generate-code.ss Friday, September 1st, 2000 11:09:43am #lang scheme
(provide (all-defined-out))
(define-struct html-element (attributes)) (define-struct html-element (attributes))
(define-struct (html-full html-element) (content)) (define-struct (html-full html-element) (content))
(define-struct (mzscheme html-full) ()) (define-struct (mzscheme html-full) ())

141
collects/html/html-unit.ss
View File

@ -1,141 +0,0 @@
#lang scheme
;; copyright by Paul Graunke June 2000 AD
(require mzlib/file
mzlib/list
mzlib/etc
mzlib/include
"html-spec.ss"
"html-sig.ss"
"sgml-reader-sig.ss"
xml/private/sig)
(provide html@)
(define-unit html@
(import xml-structs^ reader^ (prefix sgml: sgml-reader^))
(export html^)
;; Html-content = Html-element | Pc-data | Entity
(include "html-structs.ss")
(include "case.ss")
;; xml->html : Document -> Html
(define (xml->html doc)
(let ([root (document-element doc)])
(unless (eq? 'html (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)))))
;; xml-content->html : (listof Content) -> (listof Html-element)
(define (xml-contents->html contents)
(foldr xml-single-content->html
null
contents))
;; read-xhtml : [Input-port] -> Html
(define read-xhtml (compose xml->html read-xml))
;; peel-f : (Html-content -> Bool) (listof Html-content) (listof Html-content) -> (listof Html-content)
(define (peel-f toss? to-toss acc0)
(foldr (lambda (x acc)
(if (toss? x)
(append (html-full-content x) acc)
(cons x acc)))
acc0
to-toss))
;; repackage-html : (listof Html-content) -> Html
(define (repackage-html contents)
(let* ([html (memf html? contents)]
[peeled (peel-f html? contents null)]
[body (memf body? peeled)])
(make-html (if html
(html-element-attributes (car html))
null)
(append (filter head? peeled)
(list (make-body (if body
(html-element-attributes (car body))
null)
(filter (compose not head?) (peel-f body? peeled null))))))))
;; clean-up-pcdata : (listof Content) -> (listof Content)
;; 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
;; b) prepended to the front of the next subelement, if that subelement may contain pcdata
;; c) discarded
;; unknown tags may contain pcdata
;; the top level may contain pcdata
(define clean-up-pcdata
;; clean-up-pcdata : (listof Content) -> (listof Content)
(letrec ([clean-up-pcdata
(lambda (content)
(map (lambda (to-fix)
(cond
[(element? to-fix)
(recontent-xml to-fix
(let ([possible (may-contain (element-name to-fix))]
[content (element-content to-fix)])
(if (or (not possible) (memq 'pcdata possible))
(clean-up-pcdata content)
(eliminate-pcdata content))))]
[else to-fix]))
content))]
[eliminate-pcdata
;: (listof Content) -> (listof Content)
(lambda (content)
(let ([non-elements (first-non-elements content)]
[more (memf element? content)])
(if more
(let* ([el (car more)]
[possible (may-contain (element-name el))])
(if (or (not possible) (memq 'pcdata possible))
(cons (recontent-xml el (append non-elements (clean-up-pcdata (element-content el)) (eliminate-pcdata (first-non-elements (cdr more)))))
(or (memf element? (cdr more)) null))
(cons (recontent-xml el (eliminate-pcdata (element-content el)))
(eliminate-pcdata (cdr more)))))
null)))])
clean-up-pcdata))
;; first-non-elements : (listof Content) -> (listof Content)
(define (first-non-elements content)
(cond
[(null? content) null]
[else (if (element? (car content))
null
(cons (car content) (first-non-elements (cdr content))))]))
;; recontent-xml : Element (listof Content) -> Element
(define (recontent-xml e c)
(make-element (source-start e) (source-stop e) (element-name e) (element-attributes e) c))
;; implicit-starts : Symbol Symbol -> (U #f Symbol)
(define (implicit-starts parent child)
(or (and (eq? child 'tr) (eq? parent 'table) 'tbody)
(and (eq? child 'td) (memq parent '(table tbody tfoot thead)) 'tr)))
;; may-contain : Kid-lister
(define may-contain
(sgml:gen-may-contain html-spec))
(define may-contain-anything
(sgml:gen-may-contain null))
(define use-html-spec (make-parameter #t))
;; read-html-as-xml : [Input-port] -> (listof Content)
(define read-html-as-xml
(case-lambda
[(port)
((if (use-html-spec) clean-up-pcdata values)
((sgml:gen-read-sgml (if (use-html-spec)
may-contain
may-contain-anything)
implicit-starts) port))]
[() (read-html-as-xml (current-input-port))]))
;; read-html : [Input-port] -> Html
(define read-html
(compose repackage-html xml-contents->html read-html-as-xml)))

22
collects/html/html.ss
View File

@ -1,22 +1,6 @@
#lang scheme #lang scheme
;; copyright by Paul Graunke June 2000 AD ;; copyright by Paul Graunke June 2000 AD
(require "html-mod.ss" "html-sig.ss" "sgml-reader.ss") (require "html-mod.ss" "sgml-reader.ss")
(provide (all-from-out "html-mod.ss")
#;(require "html-sig.ss" read-html-comments)
"html-unit.ss"
"sgml-reader-sig.ss"
"sgml-reader-unit.ss"
xml/private/structures
xml/private/reader
xml/private/sig)
#;(define-compound-unit/infer the-html@
(import)
(export html^ sgml-reader^)
(link html@ sgml-reader@ xml-structs@ reader@))
#;(define-values/invoke-unit/infer the-html@)
(provide-signature-elements html^)
(provide read-html-comments)

3
collects/html/info.ss
View File

@ -1,6 +1,3 @@
#lang setup/infotab #lang setup/infotab
(define scribblings '(("html.scrbl" () (parsing-library)))) (define scribblings '(("html.scrbl" () (parsing-library))))
(define compile-omit-paths
'("dtd.ss" "dtdr.ss" "dtds.ss" "dtd-ast.ss" "case.ss" "html-structs.ss"
"entity-expander.ss" "generate-code.ss" "sgml.ss"))

6
collects/html/sgml-reader-sig.ss
View File

@ -1,6 +0,0 @@
;; copyright by Paul Graunke June 2000 AD
#lang scheme
(define-signature sgml-reader^ (read-html-comments trim-whitespace gen-may-contain gen-read-sgml))
(provide sgml-reader^)

433
collects/html/sgml-reader-unit.ss
View File

@ -1,433 +0,0 @@
;; copyright by Paul Graunke June 2000 AD
;; warning - this was copied from the XML collection.
;; It needs to be abstracted back in.
#lang scheme
(require mzlib/list
mzlib/string
"sgml-reader-sig.ss"
xml/private/sig)
(provide sgml-reader@)
(define-unit sgml-reader@
(import xml-structs^)
(export sgml-reader^)
;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
(define-struct (start-tag source) (name attrs))
;; End-tag ::= (make-end-tag Location Location Symbol)
(define-struct (end-tag source) (name))
;; Token ::= Contents | Start-tag | End-tag | Eof
(define read-html-comments (make-parameter #f))
(define trim-whitespace (make-parameter #f))
;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
;; gen-may-contain : Spec -> Kid-lister
(define (gen-may-contain spec)
(let ([table (make-hash)])
(for-each (lambda (def)
(let ([rhs (cdr def)])
(for-each (lambda (name) (hash-set! table name rhs))
(car def))))
spec)
(lambda (name)
(hash-ref table name (lambda () #f)))))
;; gen-read-sgml : Kid-lister (Symbol Symbol -> (U #f Symbol)) -> [Input-port] -> (listof Content)
(define (gen-read-sgml may-contain auto-insert)
(case-lambda
[(in) (read-from-port may-contain auto-insert in)]
[() (read-from-port may-contain auto-insert (current-input-port))]))
;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content)
(define (read-from-port may-contain auto-insert in)
(let loop ([tokens (let read-tokens ()
(let ([tok (lex in)])
(cond
[(eof-object? tok) null]
[else (cons tok (read-tokens))])))])
(cond
[(null? tokens) null]
[else
(let ([tok (car tokens)] [rest-tokens (cdr tokens)])
(cond
[(start-tag? tok)
(let-values ([(el more-tokens) (read-element tok null may-contain auto-insert rest-tokens)])
(cons el (loop more-tokens)))]
[(end-tag? tok) (loop rest-tokens)]
[else (let ([rest-contents (loop rest-tokens)])
(expand-content tok rest-contents))]))])))
;; 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.
;; If a kind of element can't contain anything, then its start tags are implicitly ended, and
;; end tags are implicitly started.
;; Unknown elements can contain anything and can go inside anything.
;; 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.
;; 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
;; 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.
(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* ([start-name (start-tag-name start-tag)]
[ok-kids (may-contain start-name)])
(let-values ([(content remaining)
(cond
[(null? ok-kids) (values null tokens)]
[else
;; read-content : (listof Token) -> (listof Content) (listof Token)
(let read-content ([tokens tokens])
(cond
[(null? tokens) (values null tokens)]
[else
(let ([tok (car tokens)] [next-tokens (cdr tokens)])
(cond
[(start-tag? tok)
(let* ([name (start-tag-name tok)]
[auto-start (auto-insert start-name name)])
(if auto-start
(read-content (cons (make-start-tag (source-start tok) (source-stop tok) auto-start null) tokens))
(if (and ok-kids
(not (memq name ok-kids))
(may-contain name))
(values null tokens)
(let*-values ([(element post-element)
(read-el tok (cons name context) next-tokens)]
[(more-contents left-overs) (read-content post-element)])
(values (cons element more-contents) left-overs)))))]
[(end-tag? tok)
(let ([name (end-tag-name tok)])
(if (eq? name start-name)
(values null next-tokens)
(if (memq name context)
(values null tokens)
(read-content next-tokens))))]
[else ;; content
(let-values ([(more-contents left-overs) (read-content next-tokens)])
(values
(expand-content tok more-contents)
left-overs))]))]))])])
(values (make-element (source-start start-tag)
(source-stop start-tag)
start-name
(start-tag-attrs start-tag)
content)
remaining)))))
;; expand-content : Content (listof Content) -> (listof Content)
(define (expand-content x lst)
(cond
[(entity? x) (cons (expand-entity x) lst)]
[(comment? x) (if (read-html-comments)
(cons x lst)
lst)]
[else (cons x lst)]))
;; expand-entity : Entity -> (U Entity Pcdata)
;; more here - allow expansion of user defined entities
(define (expand-entity x)
(let ([expanded (default-entity-table (entity-text x))])
(if expanded
(make-pcdata (source-start x) (source-stop x) expanded)
x)))
;; default-entity-table : Symbol -> (U #f String)
(define (default-entity-table name)
(case name
[(amp) "&"]
[(lt) "<"]
[(gt) ">"]
[(quot) "\""]
[(apos) "'"]
[else #f]))
;; lex : Input-port -> Token
(define (lex in)
(when (trim-whitespace)
(skip-space in))
(let ([c (peek-char in)])
(cond
[(eof-object? c) c]
[(eq? c #\&) (lex-entity in)]
[(eq? c #\<) (lex-tag-cdata-pi-comment in)]
[else (lex-pcdata in)])))
;; lex-entity : Input-port -> Token
;; This might not return an entity if it doesn't look like one afterall.
(define (lex-entity in)
(let ([start (file-position in)])
(read-char in)
(case (peek-char in)
;; more here - read while it's numeric (or hex) not until #\;
[(#\#)
(read-char in)
(let* ([hex? (if (equal? #\x (peek-char in))
(and (read-char in) #t)
#f)]
[str (read-until #\; in)]
[n (cond
[hex?
(string->number str 16)]
[else (string->number str)])])
(if (number? n)
(make-entity start (file-position in) n)
(make-pcdata start (file-position in) (string-append "&#" str))))]
[else
(let ([name (lex-name/case-sensitive in)]
[c (peek-char in)])
(if (eq? c #\;)
(begin (read-char in) (make-entity start (file-position in) 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
(define (lex-tag-cdata-pi-comment in)
(let ([start (file-position in)])
(read-char in)
(case (peek-char in)
[(#\!)
(read-char in)
(case (peek-char in)
[(#\-) (read-char in)
(let ([c (read-char in)])
(cond
[(eq? c #\-)
(let ([data (lex-comment-contents in)])
(make-comment data))]
[else (make-pcdata start (file-position in) (format "<!-~a" c))]))]
[(#\[) (read-char in)
(let ([s (read-string 6 in)])
(if (string=? s "CDATA[")
(let ([data (lex-cdata-contents in)])
(make-pcdata start (file-position in) data))
(make-pcdata start (file-position in) (format "<[~a" s))))]
[else (skip-dtd in) (lex in)])]
[(#\?) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(let ([data (lex-pi-data in)])
(make-pi start (file-position in) name data)))]
[(#\/) (read-char in)
(let ([name (lex-name in)])
(skip-space in)
(read-char in) ;; skip #\> or whatever else is there
(make-end-tag start (file-position in) name))]
[else
(let ([name (lex-name in)]
[attrs (lex-attributes in)])
(skip-space in)
(case (read-char in)
[(#\/)
(read-char in) ;; skip #\> or something
(make-element start (file-position in) name attrs null)]
[else (make-start-tag start (file-position in) name attrs)]))])))
;; lex-attributes : Input-port -> (listof Attribute)
(define (lex-attributes in)
(sort (let loop ()
(skip-space in)
(cond [(name-start? (peek-char in))
(cons (lex-attribute in) (loop))]
[else null]))
(lambda (a b)
(string<? (symbol->string (attribute-name a))
(symbol->string (attribute-name b))))))
;; lex-attribute : Input-port -> Attribute
;; Note: entities in attributes are ignored, since defacto html uses & in them for URL syntax
(define (lex-attribute in)
(let ([start (file-position in)]
[name (lex-name in)])
(skip-space in)
(cond
[(eq? (peek-char in) #\=)
(read-char in)
(skip-space in)
(let* ([delimiter (read-char in)]
[value (list->string
(case delimiter
[(#\' #\")
(let read-more ()
(let ([c (read-char in)])
(cond
[(or (eq? c delimiter) (eof-object? c)) null]
[else (cons c (read-more))])))]
[else (cons delimiter (read-up-to (lambda (c) (or (char-whitespace? c) (eq? c #\>))) in))]))])
(make-attribute start (file-position in) name value))]
[else (make-attribute start (file-position in) name (symbol->string name))])))
;; skip-space : Input-port -> Void
;; deviation - should sometimes insist on at least one space
(define (skip-space in)
(let loop ()
(let ([c (peek-char in)])
(when (and (not (eof-object? c)) (char-whitespace? c))
(read-char in)
(loop)))))
;; lex-pcdata : Input-port -> Pcdata
;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec
(define (lex-pcdata in)
(let ([start (file-position in)])
;; The following regexp match must use bytes, not chars, because
;; `in' might not be a well-formed UTF-8 sequence. If it isn't,
;; and it goes wrong with the first byte sequence, then a char-based
;; pattern would match 0 characters. Meanwhile, the caller of this function
;; expects characters to be read.
(let ([s (regexp-match #rx#"^[^&<]*" in)])
(make-pcdata start
(file-position in)
(bytes->string/utf-8
(if (trim-whitespace)
(regexp-replace* #rx#"[ \t\v\r\n]+" (car s) #"")
(car s))
#\?)))))
#|
;; Original slow version:
(define (lex-pcdata in)
(let ([start (file-position in)]
[data (let loop ([c (read-char in)])
(let ([next (peek-char in)])
(cond
[(or (eof-object? next) (eq? next #\&) (eq? next #\<))
(list c)]
[(and (char-whitespace? next) (trim-whitespace))
(skip-space in)
(let ([lst (loop #\space)])
(cond
[(null? (cdr lst)) (list c)]
[else (cons c lst)]))]
[else (cons c (loop (read-char in)))])))])
(make-pcdata start
(file-position in)
(list->string data))))
|#
;; lex-name : Input-port -> Symbol
(define (lex-name in)
(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
(string->symbol
;; Common case: string is already lowercased
(if (regexp-match-positions #rx"[A-Z]" s)
(begin
(string-lowercase! s)
s)
s))))
;; lex-name/case-sensitive : Input-port -> Symbol
(define (lex-name/case-sensitive in)
(let ([s (bytes->string/utf-8 (car (regexp-match #rx"^[a-zA-Z_:0-9&.-]*" in)))])
(string->symbol s)))
#|
(define (lex-name in)
(string->symbol
(list->string
(let lex-rest ()
(cond
[(name-char? (peek-char in))
(cons (char-downcase (read-char in)) (lex-rest))]
[else null])))))
|#
;; skip-dtd : Input-port -> Void
(define (skip-dtd in)
(let skip ()
(let ([c (read-char in)])
(if (eof-object? c)
(void)
(case c
[(#\') (read-until #\' in) (skip)]
[(#\") (read-until #\" in) (skip)]
[(#\<)
(case (read-char in)
[(#\!) (case (read-char in)
[(#\-) (read-char in) (lex-comment-contents in) (skip)]
[else (skip) (skip)])]
[(#\?) (lex-pi-data in) (skip)]
[else (skip) (skip)])]
[(#\>) (void)]
[else (skip)])))))
;; name-start? : TST -> Bool
(define (name-start? ch)
(and (char? ch) (char-name-start? ch)))
;; char-name-start? : Char -> Bool
(define (char-name-start? ch)
(or (char-alphabetic? ch)
(eq? ch #\_)
(eq? ch #\:)))
;; name-char? : TST -> Bool
(define (name-char? ch)
(and (char? ch)
(or (char-name-start? ch)
(char-numeric? ch)
(eq? ch #\&) ; ugly illegal junk for SEC's EDGAR database
(eq? ch #\.)
(eq? ch #\-))))
;; read-up-to : (Char -> Bool) Input-port -> (listof Char)
;; abstract this with read-until
(define (read-up-to p? in)
(let loop ()
(let ([c (peek-char in)])
(cond
[(or (eof-object? c) (p? c)) null]
[else (cons (read-char in) (loop))]))))
;; read-until : Char Input-port -> String
;; discards the stop character, too
(define (read-until char in)
(list->string
(let read-more ()
(let ([c (read-char in)])
(cond
[(or (eof-object? c) (eq? c char)) null]
[else (cons c (read-more))])))))
;; gen-read-until-string : String -> Input-port -> String
;; uses Knuth-Morris-Pratt from
;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
;; discards stop from input
(define (gen-read-until-string stop)
(let* ([len (string-length stop)]
[prefix (make-vector len 0)]
[fall-back
(lambda (k c)
(let ([k (let loop ([k k])
(cond
[(and (> k 0) (not (eq? (string-ref stop k) c)))
(loop (vector-ref prefix (sub1 k)))]
[else k]))])
(if (eq? (string-ref stop k) c)
(add1 k)
k)))])
(let init ([k 0] [q 1])
(when (< q len)
(let ([k (fall-back k (string-ref stop q))])
(vector-set! prefix q k)
(init k (add1 q)))))
;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
(lambda (in)
(list->string
(let/ec out
(let loop ([matched 0] [out out])
(let* ([c (read-char in)]
[matched (fall-back matched c)])
(cond
[(or (eof-object? c) (= matched len)) (out null)]
[(zero? matched) (cons c (let/ec out (loop matched out)))]
[else (cons c (loop matched out))]))))))))
;; "-->" makes more sense, but "--" follows the spec, but this isn't XML anymore.
(define lex-comment-contents (gen-read-until-string "-->"))
(define lex-pi-data (gen-read-until-string "?>"))
(define lex-cdata-contents (gen-read-until-string "]]>")))

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

@ -2,12 +2,12 @@
;; warning - this was copied from the XML collection. ;; warning - this was copied from the XML collection.
;; It needs to be abstracted back in. ;; It needs to be abstracted back in.
#lang scheme #lang scheme
(require mzlib/list (require xml)
mzlib/string (provide
"sgml-reader-sig.ss" read-html-comments
xml) trim-whitespace
gen-may-contain
(provide-signature-elements sgml-reader^) gen-read-sgml)
;; 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))
@ -312,9 +312,7 @@
(string->symbol (string->symbol
;; Common case: string is already lowercased ;; Common case: string is already lowercased
(if (regexp-match-positions #rx"[A-Z]" s) (if (regexp-match-positions #rx"[A-Z]" s)
(begin (string-downcase s)
(string-lowercase! 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)

14
collects/html/sgml.ss
View File

@ -1,14 +0,0 @@
;; copyright by Paul Graunke June 2000 AD
(require-library "sgmls.ss" "html")
(require-library "xmls.ss" "xml")
(require-library "invoke.ss")
(define-values/invoke-unit/sig
((open xml^) (unit sgml : sgml-reader^))
(compound-unit/sig
(import)
(link
(FUN : mzlib:function^ ((require-library "functior.ss")))
(X : xml^ ((require-library "xmlr.ss" "xml") FUN))
(S : sgml-reader^ ((require-library "sgml-reader.ss" "html") (X : xml-structs^) FUN)))
(export (open X) (unit S sgml))))