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

sync to trunk

Browse Source 
svn: r13900
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-02 23:50:40 +00:00
commit 86bd9e914a
84 changed files with 2809 additions and 3705 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/browser/private/html.ss
View File

@ -6,7 +6,7 @@
mzlib/port
net/url-sig
(only-in html read-html-as-xml read-html-comments use-html-spec)
(except-in xml/xml read-comments)
(except-in xml read-comments)
mzlib/class
"bullet.ss"
"option-snip.ss"
@ -492,7 +492,7 @@
(fixup-whitespace content leading-ok?))
(values "" leading-ok?)))
(values "" leading-ok?)))]
[(pi? c) (values "" leading-ok?)] ;; processing instruction
[(p-i? c) (values "" leading-ok?)] ;; processing instruction
[else (let ([tag (car c)])
(if (memq tag exact-whitespace-tags)
(let-values ([(s done?) (remove-leading-newline c)])
@ -879,7 +879,7 @@
(values void 0))))]
[(number? e)
(values (translate-number e) 0)]
[(or (comment? e) (pi? e)) (values void forced-lines)]
[(or (comment? e) (p-i? e)) (values void forced-lines)]
[else (let* ([tag (car e)]
[rest/base/depth/form/fl
(lambda (para-base enum-depth form forced-lines)

25
collects/drscheme/syncheck.ss
View File

@ -21,8 +21,8 @@ If the namespace does not, they are colored the unbound color.
scheme/unit
scheme/contract
scheme/class
scheme/list
drscheme/tool
mzlib/list
syntax/toplevel
syntax/boundmap
mrlib/switchable-button
@ -2574,7 +2574,8 @@ If the namespace does not, they are colored the unbound color.
(when path
(let ([index-entry (xref-tag->index-entry xref definition-tag)])
(when index-entry
(send defs-text syncheck:add-background-color source-editor "navajowhite" start fin (syntax-e stx))
(send defs-text syncheck:add-background-color
source-editor "navajowhite" start fin (syntax-e stx))
(send defs-text syncheck:add-menu
source-editor
start
@ -2583,7 +2584,7 @@ If the namespace does not, they are colored the unbound color.
(λ (menu)
(instantiate menu-item% ()
(parent menu)
(label (fw:gui-utils:format-literal-label (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry))))
(label (build-docs-label (entry-desc index-entry)))
(callback
(λ (x y)
(let* ([url (path->url path)]
@ -2599,6 +2600,24 @@ If the namespace does not, they are colored the unbound color.
url)])
(send-url (url->string url2))))))))))))))))))))))
(define (build-docs-label desc)
(let ([libs (exported-index-desc-from-libs desc)])
(cond
[(null? libs)
(fw:gui-utils:format-literal-label
(string-constant cs-view-docs)
(exported-index-desc-name desc))]
[else
(fw:gui-utils:format-literal-label
(string-constant cs-view-docs-from)
(format
(string-constant cs-view-docs)
(exported-index-desc-name desc))
(apply string-append
(add-between
(map (λ (x) (format "~s" x)) libs)
", ")))])))
;

51
collects/htdp/servlet.ss
View File

@ -4,10 +4,20 @@
web-server/servlet
htdp/error
xml
scheme/contract
mzlib/etc)
(provide (all-from web-server/servlet-env)
(all-from web-server/servlet)
(rename wrapped-build-suspender build-suspender))
(all-from web-server/servlet))
(provide/contract
[build-suspender
(((listof xexpr/c)
(listof xexpr/c))
((listof (list/c symbol? string?))
(listof (list/c symbol? string?)))
. ->* .
(string?
. -> .
xexpr/c))])
; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
(define build-suspender
@ -20,39 +30,4 @@
(title . ,title))
(body ,body-attributes
(form ([action ,k-url] [method "post"])
,@content))))))
(define wrapped-build-suspender
(case-lambda
[(title content)
(check-suspender2 title content)
(build-suspender title content)]
[(title content body-attributes)
(check-suspender3 title content body-attributes)
(build-suspender title content body-attributes)]
[(title content body-attributes head-attributes)
(check-suspender4 title content body-attributes head-attributes)
(build-suspender title content body-attributes head-attributes)]))
; : tst tst -> void
(define (check-suspender2 title content)
(check-arg 'build-suspender (listof? xexpr? title) "(listof xexpr[HTML])" "1st" title)
(check-arg 'build-suspender (listof? xexpr? content) "(listof xexpr[HTML])" "2nd" content))
; : tst tst tst -> void
(define (check-suspender3 title content body-attributes)
(check-suspender2 title content)
(check-arg 'build-suspender (listof? attribute-pair? body-attributes)
"(listof (cons sym str))" "3rd" body-attributes))
; : tst tst tst tst -> void
(define (check-suspender4 title content body-attributes head-attributes)
(check-suspender3 title content body-attributes)
(check-arg 'build-suspender (listof? attribute-pair? head-attributes)
"(listof (cons sym str))" "4th" head-attributes))
; : tst -> bool
(define (attribute-pair? b)
(and (pair? b)
(symbol? (car b))
(string? (cdr b)))))
,@content)))))))

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)

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

@ -1,137 +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"
(prefix-in sgml: "sgml-reader.ss")
xml)
(provide-signature-elements 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))

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^)

35
collects/html/html-spec.ss
View File

@ -1,6 +1,33 @@
#lang scheme/base
(provide html-spec)
#lang scheme
(require "sgml-reader.ss")
(provide/contract
[html-spec spec/c])
(define html-spec
'(((mzscheme) pcdata) ((html) body head) ((div center blockquote ins del dd li th td iframe noframes noscript) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((style script) cdata) ((basefont br area link img param hr input col isindex base meta)) ((option textarea title) pcdata) ((head) base isindex link meta object script style title) ((tr) td th) ((colgroup) col) ((thead tfoot tbody) tr) ((tt i b u s strike big small em strong dfn code samp kbd var cite abbr acronym sub sup span bdo font p h1 h2 h3 h4 h5 h6 q dt legend caption) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((table) caption col colgroup tbody tfoot thead) ((button) abbr acronym address applet b basefont bdo big blockquote br center cite code dfn dir div dl em font h1 h2 h3 h4 h5 h6 hr i img kbd map menu noframes noscript object ol p pcdata pre q s samp script small span strike strong sub sup table tt u ul var) ((fieldset) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label legend map menu noframes noscript object ol p pcdata pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((optgroup) option) ((select) optgroup option) ((label) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((form) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((ol ul dir menu) li) ((dl) dd dt) ((pre) a abbr acronym b bdo br button cite code dfn em i iframe input kbd label map pcdata q s samp script select span strike strong textarea tt u var) ((object applet) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p param pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((map) address area blockquote center dir div dl fieldset form h1 h2 h3 h4 h5 h6 hr isindex menu noframes noscript ol p pre table ul) ((a) abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((address) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object p pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((body) a abbr acronym address applet b basefont bdo big blockquote br button center cite code del dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input ins isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var)))
'(((mzscheme) pcdata)
((html) body head)
((div center blockquote ins del dd li th td iframe noframes noscript) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var)
((style script) cdata)
((basefont br area link img param hr input col isindex base meta))
((option textarea title) pcdata)
((head) base isindex link meta object script style title)
((tr) td th)
((colgroup) col)
((thead tfoot tbody) tr)
((tt i b u s strike big small em strong dfn code samp kbd var cite abbr acronym sub sup span bdo font p h1 h2 h3 h4 h5 h6 q dt legend caption) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var)
((table) caption col colgroup tbody tfoot thead)
((button) abbr acronym address applet b basefont bdo big blockquote br center cite code dfn dir div dl em font h1 h2 h3 h4 h5 h6 hr i img kbd map menu noframes noscript object ol p pcdata pre q s samp script small span strike strong sub sup table tt u ul var)
((fieldset) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label legend map menu noframes noscript object ol p pcdata pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var)
((optgroup) option)
((select) optgroup option)
((label) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd map object pcdata q s samp script select small span strike strong sub sup textarea tt u var)
((form) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var)
((ol ul dir menu) li)
((dl) dd dt)
((pre) a abbr acronym b bdo br button cite code dfn em i iframe input kbd label map pcdata q s samp script select span strike strong textarea tt u var)
((object applet) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p param pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var)
((map) address area blockquote center dir div dl fieldset form h1 h2 h3 h4 h5 h6 hr isindex menu noframes noscript ol p pre table ul)
((a) abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var)
((address) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object p pcdata q s samp script select small span strike strong sub sup textarea tt u var)
((body) a abbr acronym address applet b basefont bdo big blockquote br button center cite code del dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input ins isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var)
))

275
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
(require xml)
(define-struct html-element (attributes))
(define-struct (html-full html-element) (content))
(define-struct (mzscheme html-full) ())
@ -82,7 +84,7 @@
(define-struct (basefont html-element) ())
(define-struct (br html-element) ())
(define-struct (area html-element) ())
(define-struct (link html-element) ())
(define-struct (alink html-element) ())
(define-struct (img html-element) ())
(define-struct (param html-element) ())
(define-struct (hr html-element) ())
@ -91,3 +93,272 @@
(define-struct (isindex html-element) ())
(define-struct (base html-element) ())
(define-struct (meta html-element) ())
;; Html-content = Html-element | Pc-data | Entity
(define html-content/c
(or/c html-element? pcdata? entity?))
(provide/contract
[html-content/c contract?]
[struct html-element ([attributes (listof attribute?)])]
[struct (html-full html-element)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (mzscheme html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (html html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (div html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (center html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (blockquote html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (ins html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (del html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (dd html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (li html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (th html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (td html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (iframe html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (noframes html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (noscript html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (style html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (script html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (option html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (textarea html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (title html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (head html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (tr html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (colgroup html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (thead html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (tfoot html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (tbody html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (tt html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (i html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (b html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (u html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (s html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (strike html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (big html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (small html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (em html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (strong html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (dfn html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (code html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (samp html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (kbd html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (var html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (cite html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (abbr html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (acronym html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (sub html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (sup html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (span html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (bdo html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (font html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (p html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (h1 html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (h2 html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (h3 html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (h4 html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (h5 html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (h6 html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (q html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (dt html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (legend html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (caption html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (table html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (button html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (fieldset html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (optgroup html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (select html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (label html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (form html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (ol html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (ul html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (dir html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (menu html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (dl html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (pre html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (object html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (applet html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (-map html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (a html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (address html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (body html-full)
([attributes (listof attribute?)]
[content (listof html-content/c)])]
[struct (basefont html-element)
([attributes (listof attribute?)])]
[struct (br html-element)
([attributes (listof attribute?)])]
[struct (area html-element)
([attributes (listof attribute?)])]
[struct (alink html-element)
([attributes (listof attribute?)])]
[struct (img html-element)
([attributes (listof attribute?)])]
[struct (param html-element)
([attributes (listof attribute?)])]
[struct (hr html-element)
([attributes (listof attribute?)])]
[struct (input html-element)
([attributes (listof attribute?)])]
[struct (col html-element)
([attributes (listof attribute?)])]
[struct (isindex html-element)
([attributes (listof attribute?)])]
[struct (base html-element)
([attributes (listof attribute?)])]
[struct (meta html-element)
([attributes (listof attribute?)])])

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)))

6
collects/html/html.scrbl
View File

@ -24,10 +24,10 @@ Reads (X)HTML from a port, producing an @scheme[html] instance.}
@defproc[(read-html-as-xml [port input-port?])
(listof content?)]{
(listof content/c)]{
Reads HTML from a port, producing an @xexpr compatible with the
@schememodname[xml] library (which defines @scheme[content?]).}
@schememodname[xml] library (which defines @scheme[content/c]).}
@defboolparam[read-html-comments v]{
If @scheme[v] is not @scheme[#f], then comments are read and returned. Defaults to @scheme[#f].
@ -287,7 +287,7 @@ A @scheme[Contents-of-head] is either
@itemize[
@item[@scheme[base]]
@item[@scheme[isindex]]
@item[@scheme[link]]
@item[@scheme[alink]]
@item[@scheme[meta]]
@item[@scheme[object]]
@item[@scheme[script]]

627
collects/html/html.ss
View File

@ -1,22 +1,619 @@
#lang scheme
;; copyright by Paul Graunke June 2000 AD
(require "html-mod.ss" "html-sig.ss" "sgml-reader.ss")
(require "html-structs.ss"
"html-spec.ss"
"sgml-reader.ss"
xml)
#;(require "html-sig.ss"
"html-unit.ss"
"sgml-reader-sig.ss"
"sgml-reader-unit.ss"
xml/private/structures
xml/private/reader
xml/private/sig)
(provide (all-from-out "html-structs.ss")
read-html-comments)
(provide/contract
[use-html-spec (parameter/c boolean?)]
[read-html (() (input-port?) . ->* . html?)]
[read-xhtml (() (input-port?) . ->* . html?)]
[read-html-as-xml (() (input-port?) . ->* . (listof content/c))])
#;(define-compound-unit/infer the-html@
(import)
(export html^ sgml-reader^)
(link html@ sgml-reader@ xml-structs@ reader@))
;; 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-alink (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)))
#;(define-values/invoke-unit/infer the-html@)
;; 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)))))
(provide-signature-elements html^)
(provide read-html-comments)
;; 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
(gen-may-contain html-spec))
(define may-contain-anything
(gen-may-contain null))
(define use-html-spec (make-parameter #t))
;; read-html-as-xml : [Input-port] -> (listof Content)
(define (read-html-as-xml [port (current-input-port)])
((if (use-html-spec) clean-up-pcdata values)
((gen-read-sgml (if (use-html-spec)
may-contain
may-contain-anything)
implicit-starts) port)))
;; read-html : [Input-port] -> Html
(define read-html
(compose repackage-html xml-contents->html read-html-as-xml))

3
collects/html/info.ss
View File

@ -1,6 +1,3 @@
#lang setup/infotab
(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"))

7
collects/html/main.ss
View File

@ -1,9 +1,4 @@
#lang scheme/base
(require "html.ss")
(provide (except-out (all-from-out "html.ss")
link struct:link make-link link?)
(rename-out [link alink]
[struct:link struct:alink]
[make-link make-alink]
[link? alink?]))
(provide (all-from-out "html.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 "]]>")))

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

@ -2,12 +2,25 @@
;; 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)
(require xml
(prefix-in scheme: scheme))
(provide-signature-elements sgml-reader^)
;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
(define kid-lister/c
(symbol? . -> . (or/c (listof symbol?) false/c)))
(define spec/c
(listof (cons/c (listof symbol?) (listof symbol?))))
(provide/contract
[spec/c contract?]
[read-html-comments (parameter/c boolean?)]
[trim-whitespace (parameter/c boolean?)]
[gen-may-contain (spec/c . -> . kid-lister/c)]
[gen-read-sgml (kid-lister/c (symbol? symbol? . -> . (or/c symbol? false/c)) . -> . (() (input-port?) . ->* . (listof content/c)))])
(define (file-position in)
(make-location 0 0 (scheme:file-position in)))
;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
(define-struct (start-tag source) (name attrs))
@ -20,8 +33,6 @@
(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)])
@ -34,10 +45,8 @@
(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))]))
(define ((gen-read-sgml may-contain auto-insert) [in (current-input-port)])
(read-from-port may-contain auto-insert in))
;; read-from-port : Kid-lister (Symbol Symbol -> (U #f Symbol)) Input-port -> (listof Content)
(define (read-from-port may-contain auto-insert in)
@ -312,9 +321,7 @@
(string->symbol
;; Common case: string is already lowercased
(if (regexp-match-positions #rx"[A-Z]" s)
(begin
(string-lowercase! s)
s)
(string-downcase s)
s))))
;; lex-name/case-sensitive : Input-port -> Symbol
(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))))

101
collects/mzlib/private/unit-contract.ss
View File

@ -13,44 +13,6 @@
(provide (for-syntax unit/c/core) unit/c)
#|
We want to think of the contract as sitting between the outside world
and the unit in question. In the case where the signature in question
is contracted, we have:
pos unit/c neg
|
--- |
| | |
<---- | i | <-----|------ (v, o)
| | |
--- |
| | |
(v, u) ----> | e | ------|----->
| | |
--- |
|
So for an import, we start out with (v, o) coming in when the
import is being set. We need to first check the contract
(sig-ctc, o, neg), to make sure what's coming in appropriately
satisfies that contract (since it already has given us the
positive blame for the value incoming). Then we need to check
(ctc, neg, pos) (i.e. apply the projection with the blame
"switched"). That leaves pos as the appropriate thing to pack
with the value for the sig-ctc check inside the unit. When
the unit pulls it out (which isn't affected by the unit/c
contract combinator), it'll have the correct party to blame as
far as it knows.
For an export, we start on the other side, so we don't need to do
anything to the setting function as the unit will handle that. So for
the accessing function, we need to grab what's in the box,
check (sig-ctc, u, pos), then check (ctc, pos, neg) via projection
application, then last, but not least, return the resulting value
packed with the neg blame.
|#
(define-for-syntax (contract-imports/exports import?)
(λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name)
(define def-table (make-bound-identifier-mapping))
@ -69,63 +31,36 @@ packed with the neg blame.
#,name)
#,stx)))])
(if ctc
#`(cons
#,(if import?
#`(car #,vref)
#`(λ ()
(let* ([old-v
#,(if sig-ctc
#`(let ([old-v/c ((car #,vref))])
(cons #,(wrap-with-proj
ctc
(with-syntax ([sig-ctc-stx
(syntax-property sig-ctc
'inferred-name
var)])
#`(contract sig-ctc-stx (car old-v/c)
(cdr old-v/c) #,pos
#,(id->contract-src-info var))))
#,neg))
(wrap-with-proj ctc #`((car #,vref))))])
old-v)))
#,(if import?
#`(λ (v)
(let* ([new-v
#,(if sig-ctc
#`(cons #,(wrap-with-proj
ctc
(with-syntax ([sig-ctc-stx
(syntax-property sig-ctc
'inferred-name
var)])
#`(contract sig-ctc-stx (car v)
(cdr v) #,neg
#,(id->contract-src-info var))))
#,pos)
(wrap-with-proj ctc #'v))])
((cdr #,vref) new-v)))
#`(cdr #,vref)))
#`(λ ()
#,(if sig-ctc
#`(cons #,(wrap-with-proj
ctc
(with-syntax ([sig-ctc-stx
(syntax-property sig-ctc
'inferred-name
var)])
#`(let ([old-v/c (#,vref)])
(contract sig-ctc-stx (car old-v/c)
(cdr old-v/c) #,pos
#,(id->contract-src-info var)))))
#,neg)
(wrap-with-proj ctc #`(#,vref))))
vref)))
(for ([tagged-info (in-list import-tagged-infos)]
[sig (in-list import-sigs)])
(let ([v #`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info)))])
(for ([int/ext-name (in-list (car sig))]
[index (in-list (build-list (length (car sig)) values))])
(bound-identifier-mapping-put! def-table
(car int/ext-name)
(bound-identifier-mapping-put! def-table (car int/ext-name)
#`(vector-ref #,v #,index)))))
(with-syntax ((((eloc ...) ...)
(for/list ([target-sig import-sigs])
(let ([rename-bindings
(get-member-bindings def-table target-sig pos)])
(let ([rename-bindings (get-member-bindings def-table target-sig pos)])
(for/list ([target-int/ext-name (in-list (car target-sig))]
[sig-ctc (in-list (cadddr target-sig))])
(let* ([var (car target-int/ext-name)]
[vref
(bound-identifier-mapping-get def-table var)]
[ctc
(bound-identifier-mapping-get
ctc-table var (λ () #f))])
[vref (bound-identifier-mapping-get def-table var)]
[ctc (bound-identifier-mapping-get ctc-table var (λ () #f))])
(convert-reference var vref ctc sig-ctc rename-bindings))))))
(((export-keys ...) ...)
(map tagged-info->keys import-tagged-infos)))

4
collects/mzlib/private/unit-utils.ss
View File

@ -46,10 +46,10 @@
(λ (v stx)
(if c
(with-syntax ([c-stx (syntax-property c 'inferred-name v)])
#`(let ([v/c ((car #,stx))])
#`(let ([v/c (#,stx)])
(contract c-stx (car v/c) (cdr v/c) #,blame
#,(id->contract-src-info v))))
#`((car #,stx))))])
#`(#,stx)))])
#`[#,i
(make-set!-transformer
(λ (stx)

76
collects/mzlib/unit.ss
View File

@ -461,12 +461,12 @@
(if ctc
(with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)])
(quasisyntax/loc (error-syntax)
(quote-syntax (let ([v/c ((car #,loc))])
(quote-syntax (let ([v/c (#,loc)])
(contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info var))))))
(quasisyntax/loc (error-syntax)
(quote-syntax ((car #,loc))))))
(quote-syntax (#,loc)))))
;; build-unit : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier))
@ -546,10 +546,7 @@
(list (cons 'dept depr) ...)
(syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
(lambda ()
(let ([eloc (let ([loc (box undefined)])
(cons
(λ () (unbox loc))
(λ (v) (set-box! loc v))))] ... ...)
(let ([eloc (box undefined)] ... ...)
(values
(lambda (import-table)
(let-values ([(iloc ...)
@ -576,7 +573,7 @@
(eloc ... ...)
(ectc ... ...)
. body)))))
(unit-export ((export-key ...) (vector-immutable eloc ...)) ...)))))))
(unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...)))))))
import-tagged-sigids
export-tagged-sigids
dep-tagged-sigids))))))
@ -723,12 +720,10 @@
(current-contract-region)
'cant-happen
#,(id->contract-src-info id))
((cdr #,export-loc)
(let ([#,id #,tmp])
(cons #,id (current-contract-region))))))
(set-box! #,export-loc
(cons #,tmp (current-contract-region)))))
(quasisyntax/loc defn-or-expr
((cdr #,export-loc)
(let ([#,id #,tmp]) #,id))))
(set-box! #,export-loc #,tmp)))
(quasisyntax/loc defn-or-expr
(define-syntax #,id
(make-id-mapper (quote-syntax #,tmp)))))))]
@ -795,27 +790,22 @@
#`(letrec-syntax #,rename-bindings #,ctc)
'inferred-name var)
ctc)])
(if (or target-ctc ctc)
#`(cons
(λ ()
(let ([old-v #,(if ctc
#`(let ([old-v/c ((car #,vref))])
(contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var)))
#`((car #,vref)))])
#,(if target-ctc
#'(cons old-v (current-contract-region))
#'old-v)))
(λ (v) (let ([new-v #,(if ctc
#`(contract ctc-stx (car v)
(current-contract-region) (cdr v)
#,(id->contract-src-info var))
#'v)])
#,(if target-ctc
#`((cdr #,vref) (cons new-v (current-contract-region)))
#`((cdr #,vref) new-v)))))
vref))))
(if target-ctc
#`(λ ()
(cons #,(if ctc
#`(let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var)))
#`(#,vref))
(current-contract-region)))
(if ctc
#`(λ ()
(let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var))))
vref)))))
(car target-sig)
(cadddr target-sig)))
target-import-sigs))
@ -1277,16 +1267,16 @@
(define rename-bindings
(get-member-bindings def-table os #'(#%variable-reference)))
(map (λ (tb i v c)
#`(let ([v/c ((car #,tb))])
#,(if c
(with-syntax ([ctc-stx
(syntax-property
#`(letrec-syntax #,rename-bindings #,c)
'inferred-name v)])
#`(contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info v)))
#'v/c)))
(if c
(with-syntax ([ctc-stx
(syntax-property
#`(letrec-syntax #,rename-bindings #,c)
'inferred-name v)])
#`(let ([v/c (#,tb)])
(contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info v))))
#`(#,tb)))
tbs
(iota (length (car os)))
(map car (car os))

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "26feb2009")
#lang scheme/base (provide stamp) (define stamp "2mar2009")

3
collects/scheme/private/stxloc.ss
View File

@ -21,7 +21,8 @@
(syntax (syntax-case** _ #f stxe kl free-identifier=? clause ...))])))
(-define (relocate loc stx)
(if (syntax-source loc)
(if (or (syntax-source loc)
(syntax-position loc))
(datum->syntax stx
(syntax-e stx)
loc

22
collects/scribble/base-render.ss
View File

@ -47,11 +47,17 @@
;; ----------------------------------------
(define/public (extract-part-style-files d tag stop-at-part?)
(let loop ([p d])
(define/public (extract-part-style-files d ri tag stop-at-part?)
(let loop ([p d][up? #t][only-up? #f])
(let ([s (part-style p)])
(apply
append
(if up?
(let ([p (collected-info-parent (part-collected-info p ri))])
(if p
(loop p #t #t)
null))
null)
(if (list? s)
(filter
values
@ -63,11 +69,13 @@
(cadr s)))
s))
null)
(map (lambda (p)
(if (stop-at-part? p)
null
(loop p)))
(part-parts p))))))
(if only-up?
null
(map (lambda (p)
(if (stop-at-part? p)
null
(loop p #f #f)))
(part-parts p)))))))
;; ----------------------------------------

22
collects/scribble/html-render.ss
View File

@ -614,6 +614,7 @@
(append style-extra-files
(extract-part-style-files
d
ri
'css
(lambda (p) (part-whole-page? p ri)))))
,(scribble-js-contents script-file script-path))
@ -1120,12 +1121,21 @@
(blockquote-paragraphs t)))))
(define/override (render-itemization t part ri)
`((ul ,(if (and (styled-itemization? t)
(string? (styled-itemization-style t)))
`([class ,(styled-itemization-style t)])
`())
,@(map (lambda (flow) `(li ,@(render-flow flow part ri #t)))
(itemization-flows t)))))
(let ([style-str (and (styled-itemization? t)
(string? (styled-itemization-style t))
(styled-itemization-style t))])
`((,(if (and (styled-itemization? t)
(eq? (styled-itemization-style t) 'ordered))
'ol
'ul)
,(if style-str
`([class ,style-str])
`())
,@(map (lambda (flow) `(li ,(if style-str
`([class ,(string-append style-str "Item")])
`())
,@(render-flow flow part ri #t)))
(itemization-flows t))))))
(define/override (render-other i part ri)
(cond

47
collects/scribble/latex-render.ss
View File

@ -52,6 +52,7 @@
(append style-extra-files
(extract-part-style-files
d
ri
'tex
(lambda (p) #f)))))
(printf "\\begin{document}\n\\preDoc\n")
@ -165,16 +166,16 @@
(with-attributes-style s)
s)))]
[wrap (lambda (e s tt?)
(printf "{\\~a{" s)
(printf "\\~a{" s)
(parameterize ([rendering-tt (or tt? (rendering-tt))])
(super render-element e part ri))
(printf "}}"))])
(printf "}"))])
(cond
[(symbol? style)
(case style
[(italic) (wrap e "textit" #f)]
[(bold) (wrap e "textbf" #f)]
[(tt) (wrap e "mytexttt" #t)]
[(tt) (wrap e "Scribtexttt" #t)]
[(no-break) (super render-element e part ri)]
[(sf) (wrap e "textsf" #f)]
[(subscript) (wrap e "textsub" #f)]
@ -184,7 +185,7 @@
(case (string-length s)
[(0) (void)]
[else
(printf "\\mbox{\\hphantom{\\mytexttt{~a}}}"
(printf "\\mbox{\\hphantom{\\Scribtexttt{~a}}}"
(regexp-replace* #rx"." s "x"))]))]
[(newline) (printf "\\\\")]
[else (error 'latex-render
@ -272,7 +273,10 @@
[index? (printf "\\begin{list}{}{\\parsep=0pt \\itemsep=1pt \\leftmargin=2ex \\itemindent=-2ex}\n")]
[inline? (void)]
[else
(printf "\n\n\\begin{~a}~a{@{}~a}\n~a"
(printf "\n\n~a\\begin{~a}~a{@{}~a}\n~a"
(if (string? (table-style t))
(format "\\begin{~a}" (table-style t))
"")
tableform
opt
(string-append*
@ -324,9 +328,12 @@
(unless (null? (cdr flowss))
(loop (cdr flowss) (cdr row-styles)))))
(unless inline?
(printf "~a\n\n\\end{~a}\n"
"" ; (if (equal? tableform "bigtabular") "\n\\\\" "")
tableform)))))
(printf "~a\n\n\\end{~a}~a\n"
""
tableform
(if (string? (table-style t))
(format "\\end{~a}" (table-style t))
""))))))
null)
(define/private (render-table-flow p part ri twidth vstyle)
@ -365,12 +372,24 @@
null))
(define/override (render-itemization t part ri)
(printf "\n\n\\begin{itemize}\n")
(for ([flow (itemization-flows t)])
(printf "\n\n\\item ")
(render-flow flow part ri #t))
(printf "\n\n\\end{itemize}\n")
null)
(let* ([style-str (and (styled-itemization? t)
(string? (styled-itemization-style t))
(styled-itemization-style t))]
[mode (or style-str
(if (and (styled-itemization? t)
(eq? (styled-itemization-style t) 'ordered))
"enumerate"
"itemize"))])
(printf "\n\n\\begin{~a}\n" mode)
(for ([flow (itemization-flows t)])
(printf "\n\n\\~a" (if style-str
(format "~aItem{" style-str)
"item "))
(render-flow flow part ri #t)
(when style-str
(printf "}")))
(printf "\n\n\\end{~a}\n" mode)
null))
(define/override (render-blockquote t part ri)
(let ([kind (or (blockquote-style t) "quote")])

2
collects/scribble/private/manual-bib.ss
View File

@ -64,7 +64,7 @@
(make-flow
(list
(make-table
"bibliography"
"SBibliography"
(map (lambda (c)
(let ([key (a-bib-entry-key c)]
[val (a-bib-entry-val c)])

37
collects/scribble/private/manual-mod.ss
View File

@ -17,24 +17,37 @@
(define spacer (hspace 1))
(define-syntax-rule (defmodule*/no-declare (name ...) . content)
(*defmodule (list (schememodname name) ...)
#f
(list . content)))
(define-syntax defmodule*/no-declare
(syntax-rules ()
[(_ #:require-form req (name ...) . content)
(*defmodule (list (schememodname name) ...)
#f
(list . content)
req)]
[(_ (name ...) . content)
(defmodule*/no-declare #:require-form (scheme require) (name ...) . content)]))
(define-syntax defmodule*
(syntax-rules ()
[(_ (name ...) #:use-sources (pname ...) . content)
[(_ #:require-form req (name ...) #:use-sources (pname ...) . content)
(begin (declare-exporting name ... #:use-sources (pname ...))
(defmodule*/no-declare (name ...) . content))]
(defmodule*/no-declare #:require-form req (name ...) . content))]
[(_ #:require-form req (name ...) . content)
(defmodule* #:require-form req (name ...) #:use-sources () . content)]
[(_ (name ...) #:use-sources (pname ...) . content)
(defmodule* #:require-form (scheme require) (name ...) #:use-sources (pname ...) . content)]
[(_ (name ...) . content)
(defmodule* (name ...) #:use-sources () . content)]))
(define-syntax-rule (defmodule name . content)
(defmodule* (name) . content))
(define-syntax defmodule
(syntax-rules ()
[(_ #:require-form req name . content)
(defmodule* #:require-form req (name) . content)]
[(_ name . content)
(defmodule* (name) . content)]))
(define-syntax-rule (defmodulelang*/no-declare (lang ...) . content)
(*defmodule (list (schememodname lang) ...) #t (list . content)))
(*defmodule (list (schememodname lang) ...) #t (list . content) #f))
(define-syntax defmodulelang*
(syntax-rules ()
@ -48,7 +61,7 @@
(defmodulelang* (lang) . content))
(define-syntax-rule (defmodulereader*/no-declare (lang ...) . content)
(*defmodule (list (schememodname lang) ...) 'reader (list . content)))
(*defmodule (list (schememodname lang) ...) 'reader (list . content) #f))
(define-syntax defmodulereader*
(syntax-rules ()
@ -61,7 +74,7 @@
(define-syntax-rule (defmodulereader lang . content)
(defmodulereader* (lang) . content))
(define (*defmodule names lang content)
(define (*defmodule names lang content req)
(make-splice
(cons
(make-table
@ -78,7 +91,7 @@
(if (eq? lang 'reader)
(list (schememetafont "#reader") spacer (make-defschememodname name))
(list (hash-lang) spacer (make-defschememodname name)))
(list (scheme (require #,(make-defschememodname name)))))))))))
(list (scheme (#,req #,(make-defschememodname name)))))))))))
names))
(append (map (lambda (name)
(make-part-tag-decl `(mod-path ,(element->string name))))

9
collects/scribble/private/manual-scheme.ss
View File

@ -96,8 +96,13 @@
(define-code schemeid to-element/id unsyntax keep-s-expr add-sq-prop)
(define-code *schememodname to-element unsyntax keep-s-expr add-sq-prop)
(define-syntax-rule (schememodname n)
(as-modname-link 'n (*schememodname n)))
(define-syntax schememodname
(syntax-rules (unsyntax)
[(schememodname #,n)
(let ([sym n])
(as-modname-link sym (to-element sym)))]
[(schememodname n)
(as-modname-link 'n (*schememodname n))]))
(define (as-modname-link s e)
(if (symbol? s)

40
collects/scribble/private/run-pdflatex.ss Normal file
View File

@ -0,0 +1,40 @@
#lang scheme/base
(require scheme/system scheme/port scheme/promise)
(provide run-pdflatex)
(define (run-pdflatex file [notify void])
(define (err fmt . args) (apply error 'run-pdflatex fmt args))
(define cmd
(list (or (find-executable-path "pdflatex")
(err "could not find a `pdflatex' executable"))
"-interaction=batchmode"
(format "~a" file)))
(define logfile (path-replace-suffix file #".log"))
(define (run)
(unless (parameterize ([current-output-port (open-output-nowhere)])
(apply system* cmd))
(unless (file-exists? logfile)
(err "did not generate a log file at ~a" logfile))
(call-with-input-file* logfile
(lambda (log) (copy-port log (current-error-port))))
(err "got error exit code")))
(let loop ([n 0])
(when (= n 5)
(err "didn't get a stable result after ~a runs" n))
(if (zero? n)
(notify "running pdflatex on ~a" file)
(notify " re-running ~a~a time"
(add1 n) (case (add1 n) [(2) 'nd] [(3) 'rd] [else 'th])))
(run)
;; see if we get a "Rerun" note, these seem to come in two flavors
;; * Label(s) may have changed. Rerun to get cross-references right.
;; * Package longtable Warning: Table widths have changed. Rerun LaTeX.
(cond [(call-with-input-file* logfile
(lambda (log) (regexp-match? #px#"changed\\.\\s+Rerun" log)))
(loop (add1 n))]
[(zero? n)
(notify "WARNING: no \"Rerun\" found in first run of pdflatex for ~a"
file)]))
(path-replace-suffix file #".pdf"))

2
collects/scribble/scribble.css
View File

@ -506,7 +506,7 @@ i {
.techinside:hover { color: blue; }
.techoutside:hover>.techinside { color: inherit; }
.bibliography td {
.SBibliography td {
vertical-align: text-top;
}

20
collects/scribble/scribble.tex
View File

@ -9,7 +9,7 @@
\usepackage[usenames,dvipsnames]{color}
\hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true}
\newcommand{\inColor}[2]{{\mytexttt{\color{#1}{#2}}}}
\newcommand{\inColor}[2]{{\Scribtexttt{\color{#1}{#2}}}}
\definecolor{CommentColor}{rgb}{0.76,0.45,0.12}
\definecolor{ParenColor}{rgb}{0.52,0.24,0.14}
\definecolor{IdentifierColor}{rgb}{0.15,0.15,0.50}
@ -19,9 +19,9 @@
\definecolor{PaleBlue}{rgb}{0.90,0.90,1.0}
\definecolor{LightGray}{rgb}{0.90,0.90,0.90}
\newcommand{\mytexttt}[1]{{\texttt{#1}}}
\newcommand{\Scribtexttt}[1]{{\texttt{#1}}}
\newcommand{\schemeplain}[1]{\inColor{black}{#1}}
\newcommand{\schemekeyword}[1]{{\color{black}{\mytexttt{\textbf{#1}}}}}
\newcommand{\schemekeyword}[1]{{\color{black}{\Scribtexttt{\textbf{#1}}}}}
\newcommand{\schemesyntaxlink}[1]{\schemekeyword{#1}}
\newcommand{\schemecomment}[1]{\inColor{CommentColor}{#1}}
\newcommand{\schemeparen}[1]{\inColor{ParenColor}{#1}}
@ -40,8 +40,8 @@
\newcommand{\schemeerrorcol}[1]{\inColor{red}{#1}}
\newcommand{\schemeerror}[1]{{\schemeerrorcol{\textrm{\textit{#1}}}}}
\newcommand{\schemeopt}[1]{#1}
\newcommand{\textsub}[1]{$_{#1}$}
\newcommand{\textsuper}[1]{$^{#1}$}
\newcommand{\textsub}[1]{$_{\hbox{\textsmaller{#1}}}$}
\newcommand{\textsuper}[1]{$^{\hbox{\textsmaller{#1}}}$}
\newcommand{\refcolumn}[1]{#1}
\newcommand{\refcontent}[1]{#1}
\newcommand{\intextcolor}[2]{\textcolor{#1}{#2}}
@ -78,6 +78,16 @@
\newenvironment{bigtabular}{\begin{longtable}}{\end{longtable}\vspace{-3ex}}
\newenvironment{schemeblock}{}{}
\newenvironment{defmodule}{}{}
\newenvironment{prototype}{}{}
\newenvironment{argcontract}{}{}
\newenvironment{together}{}{}
\newenvironment{SBibliography}{}{}
\newenvironment{compact}{\begin{itemize}}{\end{itemize}}
\newcommand{\compactItem}[1]{\item #1}
\newcommand{\SecRef}[2]{\S#1 ``#2''}
\newcommand{\sectionhidden}[1]{\section{#1}}

14
collects/scribblings/drscheme/files.scrbl
View File

@ -56,13 +56,13 @@ original file's name:
}
When a file in an active DrScheme editor is modified but not saved,
DrScheme saves the file to a special autosave file after five minutes
(in case of a power failure or catastrophic error). If the file is
later saved, or if the user exists DrScheme without saving the file,
the autosave file is removed. The autosave file is saved in the same
directory as the original file, and the autosave file's name is
generated from the original file's name:
Every five minutes, DrScheme checks each open file. If any file is
modified and not saved, DrScheme saves the file to a special autosave
file (just in case there is a power failure or some other catastrophic
error). If the file is later saved, or if the user exists DrScheme
without saving the file, the autosave file is removed. The autosave
file is saved in the same directory as the original file, and the
autosave file's name is generated from the original file's name:
@itemize{

3
collects/scribblings/quick/info.ss
View File

@ -1,3 +1,4 @@
#lang setup/infotab
(define scribblings '(("quick.scrbl" () (getting-started 9))))
(define scribblings '(("quick.scrbl" () (getting-started 9))
("mreval.scrbl")))

21
collects/scribblings/quick/mreval.scrbl Normal file
View File

@ -0,0 +1,21 @@
#lang scribble/manual
@(require (for-label scribble/eval "mreval.ss"))
@title{Writing Examples with Pict Results}
@defmodule[scribblings/quick/mreval]{The
@schememodname[scribblings/quick/mreval] library support example
evaluations with results that are @schememodname[slideshow] picts.}
@defform[(mr-interaction datum ...)]{
Like @scheme[interaction], but using an evaluator that includes
@schememodname[scheme/gui/base] and @schememodname[slideshow].
The trick is that @schememodname[scheme/gui] is not generally
available when rendering documentation, because it requires a GUI
context. The picture output is rendered to an image file when the
@envvar{MREVAL} environment variable is set, so run the enclosing
document once with the environment varibale to generate the
images. Future runs (with the environment variable unset) use the
generated image.}

2
collects/scribblings/reference/filesystem.scrbl
View File

@ -423,7 +423,7 @@ absolute path; it is an absolute path when adding the
platform-specific shared-library extension --- as produced by
@scheme[(system-type 'so-suffix)] --- and then searching in the
PLT-specific shared-object library directories (as determined by
@scheme[find-dll-dirs]) locates the path. In this way, shared-object
@scheme[get-lib-search-dirs]) locates the path. In this way, shared-object
libraries that are installed specifically for PLT Scheme get carried
along in distributions.

3
collects/scribblings/reference/stx-patterns.scrbl
View File

@ -348,7 +348,8 @@ for use only with a @scheme[quasisyntax] template.}
Like @scheme[syntax], except that the immediate resulting syntax
object takes its source-location information from the result of
@scheme[stx-expr] (which must produce a syntax object), unless the
@scheme[template] is just a pattern variable.}
@scheme[template] is just a pattern variable or both the source and
position of @scheme[stx-expr] are @scheme[#f].}
@defform[(quasisyntax/loc stx-expr template)]{

10
collects/scribblings/scribble/basic.scrbl
View File

@ -102,11 +102,13 @@ removed.}
unnumbered section heading (for when the nesting gets too deep to
include in a table of contents).}
@defproc[(itemize [itm (or/c whitespace? an-item?)] ...) itemization?]{
@defproc[(itemize [itm (or/c whitespace? an-item?)] ...
[#:style style any/c #f]) itemization?]{
Constructs an itemization given a sequence of items constructed by
@scheme[item]. Whitespace strings among the @scheme[itm]s are
ignored.
Constructs an @scheme[itemization] or (when @scheme[style] is not
@scheme[#f]) @scheme[styled-itemization] given a sequence of items
constructed by @scheme[item]. Whitespace strings among the
@scheme[itm]s are ignored.
}

12
collects/scribblings/scribble/config.scrbl
View File

@ -40,9 +40,15 @@ extend or configure Scribble fall into two groups:
#:style `((css "inbox.css") (tex "inbox.tex"))]{Adding a Style}
When a string is uses as a style in an @scheme[element],
@scheme[styled-paragraph], or @scheme[blockquote], it corresponds to a
CSS class for HTML output or a Tex macro (or Latex environment, in the
case of @scheme[blockquote]) for Latex output.
@scheme[styled-paragraph], @scheme[table],
@scheme[styled-itemization], or @scheme[blockquote], it corresponds to
a CSS class for HTML output or a Tex macro/environment for Latex
output. In Latex output, the string is used as a macro name for a
@scheme[styled-paragraph] and an environment name for a
@scheme[table], @scheme[itemization], or @scheme[blockquote]. In
addition, for an itemization, the style string is suffixed with
@scheme["Item"] and used as a CSS class or Tex macro name to use for
the itemization's items (in place of @tt{item} in the case of Latex).
Scribble includes a number of predefined styles that are used by the
exports of @scheme[scribble/manual], but they are not generally

21
collects/scribblings/scribble/manual.scrbl
View File

@ -141,8 +141,10 @@ as a REPL value (i.e., a single color with no hyperlinks).}
@defform[(schemeid datum ...)]{Like @scheme[scheme], but typeset
as an unbound identifier (i.e., no coloring or hyperlinks).}
@defform[(schememodname datum)]{Like @scheme[scheme], but typeset as a
module path. If @scheme[datum] is an identifier, then it is
@defform*[((schememodname datum)
(schememodname ((unsyntax (scheme unsyntax)) expr)))]{
Like @scheme[scheme], but typeset as a module path. If @scheme[datum]
is an identifier or @scheme[expr] produces a symbol, then it is
hyperlinked to the module path's definition as created by
@scheme[defmodule].}
@ -246,8 +248,10 @@ because the @"@"-reader would drop comments within the
@; ------------------------------------------------------------------------
@section[#:tag "doc-modules"]{Documenting Modules}
@defform/subs[(defmodule id maybe-sources pre-flow ...)
([maybe-sources code:blank
@defform/subs[(defmodule maybe-req id maybe-sources pre-flow ...)
([maybe-req code:blank
(code:line #:require-form expr)]
[maybe-sources code:blank
(code:line #:use-sources (mod-path ...))])]{
Produces a sequence of flow elements (encaptured in a @scheme[splice])
@ -262,6 +266,11 @@ Besides generating text, this form expands to a use of
used at most once in a section, though it can be shadowed with
@scheme[defmodule]s in sub-sections.
If a @scheme[#:require-form] clause is provided, the given expression
produces an element to use instead of @scheme[(scheme require)] for
the declaration of the module. This is useful to suggest a different
way of accessing the module instead of through @scheme[require].
Hyperlinks created by @scheme[schememodname] are associated with the
enclosing section, rather than the local @scheme[id] text.}
@ -279,7 +288,7 @@ suitable for use with @schememetafont{#reader}.}
@deftogether[(
@defform[(defmodule* (id ...+) maybe-sources pre-flow ...)]
@defform[(defmodule* maybe-req (id ...+) maybe-sources pre-flow ...)]
@defform[(defmodulelang* (id ...+) maybe-sources pre-flow ...)]
@defform[(defmodulereader* (id ...+) maybe-sources pre-flow ...)]
)]{
@ -288,7 +297,7 @@ Like @scheme[defmodule], etc., but introduces multiple module paths instead
of just one.}
@deftogether[(
@defform[(defmodule*/no-declare (id ...) pre-flow ...)]
@defform[(defmodule*/no-declare maybe-req (id ...) pre-flow ...)]
@defform[(defmodulelang*/no-declare (id ...) pre-flow ...)]
@defform[(defmodulereader*/no-declare (id ...) pre-flow ...)]
)]{

6
collects/scribblings/scribble/reader.scrbl
View File

@ -16,7 +16,7 @@ The Scribble @"@"-reader is designed to be a convenient facility for
using free-form text in Scheme code, where ``@"@"'' is chosen as one of
the least-used characters in Scheme code.
You can use the reader via MzScheme's @schemefont{#reader} form:
You can use the reader via Scheme's @schemefont{#reader} form:
@schemeblock[
#, @schemefont|{
@ -29,7 +29,7 @@ or use the @scheme[at-exp] meta-language as described in
Note that the Scribble reader reads @"@"-forms as S-expressions. This
means that it is up to you to give meanings for these expressions in
the usual way: use Scheme functions, define your functions, or require
functions. For example, typing the above into MzScheme is likely
functions. For example, typing the above into @exec{mzscheme} is likely
going to produce a ``reference to undefined identifier'' error, unless
@scheme[foo] is defined. You can use @scheme[string-append] instead,
or you can define @scheme[foo] as a function (with variable arity).
@ -41,7 +41,7 @@ text is likely to start with
@schememod[scribble/doc]
which installs the @"@" reader starting in ``text mode,'' wraps the
file content afterward into a MzScheme module where many useful Scheme
file content afterward into a Scheme module where many useful Scheme
and documentation related functions are available, and parses the body
into a document using @schememodname[scribble/decode]. See
@secref["docreader"] for more information.

21
collects/scribblings/scribble/struct.scrbl
View File

@ -399,8 +399,8 @@ The @scheme[style] can be any of the following:
@itemize[
@item{A string that corresponds to a CSS class for
HTML output (see @secref["extra-style"]).}
@item{A string that corresponds to a CSS class for HTML output or an
environment for Latex output (see @secref["extra-style"]).}
@item{@scheme['boxed] to render as a definition.}
@ -443,6 +443,23 @@ A @techlink{itemization} has a list of flows.
}
@defstruct[(styled-itemization itemization) ([style any/c])]{
The @scheme[style] can be
@itemize[
@item{A string that corresponds to a CSS class for HTML output or a
macro for Latex output (see @secref["extra-style"]).}
@item{The symbol @scheme['ordered], which generates @tt{<ol>} HTML
output instead of @tt{<li>} or an Latex enumeration instead of
an itemization.}
]}
@defstruct[blockquote ([style any/c]
[paragraphs (listof flow-element?)])]{

10
collects/scribblings/slideshow/picts.scrbl
View File

@ -305,7 +305,8 @@ argument for consistency with the other functions.}
[#:line-width line-width (or/c #f real?) #f]
[#:color color (or/c #f string? (is-a/c? color%)) #f]
[#:under? under? any/c #f]
[#:solid? solid? any/c #t])
[#:solid? solid? any/c #t]
[#:hide-arrowhead? any/c #f])
pict?]
[(pin-arrows-line [arrow-size real?] [pict pict?]
[src pict-path?]
@ -319,7 +320,8 @@ argument for consistency with the other functions.}
[#:line-width line-width (or/c #f real?) #f]
[#:color color (or/c #f string? (is-a/c? color%)) #f]
[#:under? under? any/c #f]
[#:solid? solid? any/c #t])
[#:solid? solid? any/c #t]
[#:hide-arrowhead? any/c #f])
pict?])]{
Adds a line or line-with-arrows onto @scheme[pict], using one of the
@ -347,6 +349,10 @@ The @scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and
]
When the @scheme[hide-arrowhead?] argument is a true value, then
space for the arrowhead is left behind, but the arrowhead itself
is not drawn.
The defaults produce a straight line.}
@defthing[text-style/c contract?]{

47
collects/slideshow/pict.ss
View File

@ -59,24 +59,26 @@
(pin-curve* #f #f p src src-find dest dest-find
sa ea sp ep sz col lw under? #t)))
(define (pin-arrow-line sz p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t])
(if (not (or sa ea))
(finish-pin (launder (t:pin-arrow-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?))
p lw col under?)
(pin-curve* #f #t p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?)))
(define (pin-arrow-line sz p
src src-find
dest dest-find
#:start-angle [sa #f] #:end-angle [ea #f]
#:start-pull [sp #f] #:end-pull [ep #f]
#:color [col #f]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not (or sa ea))
(finish-pin (launder (t:pin-arrow-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?
#:hide-arrowhead? hide-arrowhead?))
p lw col under?)
(pin-curve* #f (not hide-arrowhead?) p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?)))
(define (pin-arrows-line sz p
src src-find
dest dest-find
@ -85,14 +87,17 @@
#:color [col #f]
#:line-width [lw #f]
#:under? [under? #f]
#:solid? [solid? #t])
#:solid? [solid? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
(if (not sa ea)
(finish-pin (launder (t:pin-arrows-line sz (ghost p)
src src-find
dest dest-find
#f #f #f solid?))
#f #f #f solid?
#:hide-arrowhead? hide-arrowhead?))
p lw col under?)
(pin-curve* #t #t p src src-find dest dest-find
(pin-curve* (not hide-arrowhead?) (not hide-arrowhead?)
p src src-find dest dest-find
sa ea sp ep sz col lw under? solid?)))
(define (pin-curve* start-arrow? end-arrow? p

1
collects/string-constants/english-string-constants.ss
View File

@ -192,6 +192,7 @@ please adhere to these guidelines:
(cs-status-loading-docs-index "Check Syntax: loading documentation index")
(cs-mouse-over-import "binding ~s imported from ~s")
(cs-view-docs "View documentation for ~a")
(cs-view-docs-from "~a from ~a") ;; a completed version of the line above (cs-view-docs) is put into the first ~a and a list of modules (separated by commas) is put into the second ~a. Use check syntax and right-click on a documented variable (eg, 'require') to see this in use
(cs-lexical-variable "lexical variable")
(cs-imported-variable "imported variable")

2
collects/string-constants/german-string-constants.ss
View File

@ -946,6 +946,8 @@
(module-language-one-line-summary "Start erzeugt eine REPL im Kontext des Moduls inklusive der deklarierten Sprache des Moduls.")
(module-language-auto-text "Automatisch Zeile mit #lang") ;; shows up in the details section of the module language
;;; from the `not a language language' used initially in drscheme.
(must-choose-language "DrScheme kann keine Programme verarbeiten, bis Sie eine Sprache auswählen.")

9
collects/teachpack/2htdp/scribblings/shared.ss
View File

@ -1,10 +1,5 @@
#lang scheme/base
(require scribble/manual)
(require "../../htdp/scribblings/shared.ss")
(provide teachpack)
(define (teachpack tp . name)
(apply title #:tag tp
`(,@name ": " ,(filepath (format "~a.ss" tp))
,(index (format "~a teachpack" tp)))))
(provide teachpack beginner-require)

24
collects/teachpack/2htdp/scribblings/universe.scrbl
View File

@ -25,7 +25,7 @@
@author{Matthias Felleisen}
@defmodule[2htdp/universe #:use-sources (teachpack/htdp/image)]
@defmodule[#:require-form beginner-require 2htdp/universe #:use-sources (teachpack/htdp/image)]
@;{FIXME: the following paragraph uses `defterm' instead of `deftech',
because the words "world" and "universe" are used as datatypes, and
@ -91,10 +91,13 @@ The simplest kind of animated @tech{world} program is a time-based
@defproc[(run-simulation [create-image (-> natural-number/c scene)])
true]{
opens a canvas and starts a clock that tick 28 times per second.
Every time the clock ticks, DrScheme applies
@scheme[create-image] to the number of ticks passed since this function
call. The results of these applications are displayed in the canvas.
opens a canvas and starts a clock that tick 28 times per second. Every
time the clock ticks, DrScheme applies @scheme[create-image] to the
number of ticks passed since this function call. The results of these
function calls are displayed in the canvas. The simulation runs until you
click the @tt{Stop} button in DrScheme or close the window. At that
point, @scheme[run-simulation] returns the number of ticks that have
passed.
}
Example:
@ -183,7 +186,11 @@ The design of a world program demands that you come up with a data
itself as a scene; when the program must shut down; where to register the
world with a universe; and whether to record the stream of events. A world
specification may not contain more than one @scheme[on-tick],
@scheme[on-draw], or @scheme[register] clause.}
@scheme[on-draw], or @scheme[register] clause. A @scheme[big-bang]
expression returns the last world when the stop condition is satisfied
(see below) or when the programmer clicks on the @tt{Stop} button or
closes the canvas.
}
@itemize[
@ -328,9 +335,10 @@ All @tech{MouseEvent}s are represented via symbols:
([last-world? (-> (unsyntax @tech{WorldState}) boolean?)])]{
tell DrScheme to call the @scheme[last-world?] function whenever the canvas is
drawn. If this call produces @scheme[true], the world program is shut
down. Specifically, the clock is stopped; no more
down. Specifically, the clock is stopped; no more
tick events, @tech{KeyEvent}s, or @tech{MouseEvent}s are forwarded to
the respective handlers.
the respective handlers. The @scheme[big-bang] expression returns this
last world.
}}
@item{

3
collects/teachpack/htdp/scribblings/image.scrbl
View File

@ -7,8 +7,7 @@
@teachpack["image"]{Manipulating Images}
@declare-exporting[teachpack/htdp/image #:use-sources (htdp/image)]
@defmodule[#:require-form beginner-require htdp/image]
The teachpack provides primitives for constructing and manipulating
images. Basic, colored images are created as outlines or solid

10
collects/teachpack/htdp/scribblings/shared.ss
View File

@ -2,9 +2,17 @@
(require scribble/manual)
(provide teachpack)
(provide teachpack
beginner-require)
(define (teachpack tp . name)
(apply title #:tag tp
`(,@name ": " ,(filepath (format "~a.ss" tp))
,(index (format "~a teachpack" tp)))))
(define-syntax-rule (def-req beg-require)
(begin
(require (for-label lang/htdp-beginner))
(define beg-require (scheme require))))
(def-req beginner-require)

4
collects/teachpack/htdp/scribblings/world.scrbl
View File

@ -10,6 +10,8 @@
@teachpack["world"]{Simulations and Animations}
@defmodule[#:require-form beginner-require htdp/world #:use-sources (htdp/image)]
@emph{Note}: For a quick and educational introduction to the teachpack, see
@link["http://www.ccs.neu.edu/home/matthias/HtDP/Prologue/book.html"]{How
to Design Programs, Second Edition: Prologue}. As of August 2008, we also
@ -26,8 +28,6 @@ The teachpack provides two sets of tools. The first allows students to
create and display a series of animated scenes, i.e., a simulation. The
second one generalizes the first by adding interactive GUI features.
@declare-exporting[teachpack/htdp/world #:use-sources (teachpack/htdp/image)]
@; -----------------------------------------------------------------------------
@section[#:tag "basics"]{Basics}

11
collects/tests/html/test.ss
View File

@ -1,6 +1,7 @@
#lang scheme
(require (planet schematics/schemeunit:3)
(planet schematics/schemeunit:3/text-ui)
net/url
(prefix-in h: html)
(prefix-in x: xml))
@ -40,6 +41,12 @@
'()]))]
(check-equal? (extract-pcdata an-html)
' ("My title" "Hello world" "Testing" "!"))))))
' ("My title" "Hello world" "Testing" "!"))))
(test-case "Eli - March 1"
(check-not-false (lambda () (h:read-html-as-xml (get-pure-port (string->url "http://list.cs.brown.edu/pipermail/plt-scheme/"))))))
))
(run-tests html-tests)
(run-tests html-tests)

2
collects/tests/info.ss
View File

@ -25,4 +25,6 @@
"syntax-color"
"typed-scheme"
"units"
"xml"
"html"
"web-server"))

161
collects/tests/units/test-unit-contracts.ss
View File

@ -2,6 +2,60 @@
scheme/unit
scheme/contract)
(define temp-unit-blame #rx"(unit temp[0-9]*)")
(define top-level "top-level")
(define (get-blame msg)
(cond
[(regexp-match #rx"(^| )(.*) broke" msg)
=>
(λ (x) (caddr x))]
[else (error 'test-contract-error
(format "no blame in error message: \"~a\"" msg))]))
(define (get-obj msg)
(cond
[(regexp-match #rx"(^| )on (.*);" msg)
=>
(λ (x) (caddr x))]
[else (error 'test-contract-error
(format "no object in error message: \"~a\"" msg))]))
(define (get-ctc-err msg)
(cond
[(regexp-match #rx";[ ]*(.*)" msg)
=>
(λ (x) (cadr x))]
[else (error 'test-contract-error
(format "no specific error in message: \"~a\"" msg))]))
(define-syntax test-contract-error
(syntax-rules ()
((_ blame obj err expr)
(with-handlers ((exn:fail:contract?
(lambda (exn)
(let ([exn-blame (get-blame (exn-message exn))]
[exn-obj (get-obj (exn-message exn))])
(cond
[(and (string? blame)
(not (equal? blame exn-blame)))
(error 'test-contract-error "expected blame ~a, got ~a"
blame exn-blame)]
[(and (regexp? blame)
(not (regexp-match blame exn-blame)))
(error 'test-contract-error "expected blame ~a, got ~a"
blame exn-blame)]
[(not (equal? obj exn-obj))
(error 'test-contract-error "expected object ~a, got ~a"
obj exn-obj)]
[else
(printf "contract error \"~a\" on ~a blaming ~a: ok\n\t\"~a\"\n\n"
err obj exn-blame (get-ctc-err (exn-message exn)))])))))
expr
(error 'test-contract-error
"expected contract error \"~a\" on ~a, got none"
err 'expr)))))
(define-signature sig1
((contracted [x number?])))
(define-signature sig2
@ -55,13 +109,14 @@
(define g zero?)
(define (b t) (if t 3 0))))
(test-runtime-error exn:fail:contract? "x exported by unit1 not a number"
(test-contract-error "(unit unit1)" "x" "not a number"
(invoke-unit unit1))
(test-runtime-error exn:fail:contract? "x exported by unit1 not a number"
(test-contract-error "(unit unit1)" "x" "not a number"
(invoke-unit (compound-unit (import) (export)
(link (((S1 : sig1)) unit1)
(() unit2 S1)))))
(test-runtime-error exn:fail:contract? "a provided by anonymous unit not a number"
(test-contract-error temp-unit-blame "a" "not a number"
(invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4)
@ -71,7 +126,7 @@
(define (b t) (if t 3 0))))
(() unit3 S3 S4)))))
(test-runtime-error exn:fail:contract? "g provided by anonymous unit returns the wrong value"
(test-contract-error temp-unit-blame "g" "not a boolean"
(invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4)
@ -81,7 +136,7 @@
(define (b t) (if t 3 0))))
(() unit3 S3 S4)))))
(test-runtime-error exn:fail:contract? "unit4 misuses function b"
(test-contract-error "(unit unit4)" "b" "not a boolean"
(invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4)
@ -91,7 +146,7 @@
(define (b t) (if t 3 0))))
(() unit4 S3 S4)))))
(test-runtime-error exn:fail:contract? "unit5 provides bad value for d"
(test-contract-error "(unit unit5)" "d" "not a symbol"
(invoke-unit unit5))
(define-unit unit6
@ -121,7 +176,7 @@
(import)
(export sig1)))
(test-runtime-error exn:fail:contract? "unit7 reexports x with different (wrong) contract"
(test-contract-error "(unit unit7)" "x" "not a boolean"
(invoke-unit unit7))
(define-unit unit8
@ -136,7 +191,7 @@
(export sig2))
(f #t))
(test-runtime-error exn:fail:contract? "unit8 misuses f from internal unit"
(test-contract-error "(unit unit8)" "f" "not a number"
(invoke-unit unit8))
(define-unit unit9
@ -151,7 +206,7 @@
(export sig2))
(f 3))
(test-runtime-error exn:fail:contract? "unit9-1 provides wrong value for function f"
(test-contract-error "(unit unit9-1)" "f" "not a number"
(invoke-unit unit9))
(define-values/invoke-unit
@ -161,7 +216,7 @@
(import)
(export sig2))
(test-runtime-error exn:fail:contract? "top-level misuses f"
(test-contract-error top-level "f" "not a number"
(f #t))
(define-unit unit10
@ -173,13 +228,13 @@
(let ()
(define x 0)
(define f (lambda (x) #t))
(test-runtime-error exn:fail:contract? "top-level (via anonymous unit) provides improper f"
(test-contract-error "(unit u)" "f" "not a number"
(invoke-unit unit10 (import sig1 sig2))))
(let ()
(define x 1)
(define f values)
(test-runtime-error exn:fail:contract? "unit10 misuses f from top-level"
(test-contract-error "(unit unit10)" "f" "not a number"
(invoke-unit unit10 (import sig1 sig2))))
;; testing that contracts from extended signatures are checked properly
@ -192,9 +247,9 @@
(define-values/invoke-unit unit11
(import)
(export sig3))
(test-runtime-error exn:fail:contract? "unit11 provides improper f"
(test-contract-error "(unit unit11)" "f" "not a number"
(f 3))
(test-runtime-error exn:fail:contract? "top-level misuses f"
(test-contract-error top-level "f" "not a number"
(f #t)))
;; unit/new-import-export tests
@ -259,7 +314,7 @@
(export)
(link [((S : sig8)) unit19]
[() unit20 S]))
(test-runtime-error exn:fail:contract? "unit19 provides bad f"
(test-contract-error "(unit unit19)" "f" "not a number"
(invoke-unit unit22)))
;; contracted import -> uncontracted import
@ -280,7 +335,7 @@
(export)
(link [((S : sig7)) unit18]
[() unit23 S]))
(test-runtime-error exn:fail:contract? "unit23 provides f with no protection into a bad context"
(test-contract-error "(unit unit23)" "f" "not a number"
(invoke-unit unit25)))
;; contracted import -> contracted import
@ -309,7 +364,7 @@
(export)
(link [((S : sig9)) unit28-1]
[() unit26 S]))
(test-runtime-error exn:fail:contract? "unit28-1 broke contract on f"
(test-contract-error "(unit unit28-1)" "f" "not a number"
(invoke-unit unit28-2)))
;; uncontracted export -> contracted export
@ -330,7 +385,7 @@
(export)
(link [((S : sig8)) unit29]
[() unit17 S]))
(test-runtime-error exn:fail:contract? "unit17 misuses f"
(test-contract-error "(unit unit17)" "f" "not a number"
(invoke-unit unit31)))
;; contracted export -> uncontracted export
@ -351,7 +406,7 @@
(export)
(link [((S : sig7)) unit32]
[() unit16 S]))
(test-runtime-error exn:fail:contract? "unit32 provides f with no protection into bad context"
(test-contract-error "(unit unit32)" "f" "not a number"
(invoke-unit unit34)))
;; contracted export -> contracted export
@ -380,7 +435,7 @@
(export)
(link [((S : sig9)) unit35]
[() unit37-1 S]))
(test-runtime-error exn:fail:contract? "unit37-1 broke contract on f"
(test-contract-error "(unit unit37-1)" "f" "not a number"
(invoke-unit unit37-2)))
;; Converting units with internal contract violations
@ -396,7 +451,7 @@
(export)
(link [((S : sig8)) unit15]
[() unit38 S]))
(test-runtime-error exn:fail:contract? "unit38 allowed f to flow into uncontracted bad context"
(test-contract-error "(unit unit38)" "f" "not a number"
(invoke-unit unit39)))
(let ()
(define-compound-unit unit40
@ -404,7 +459,7 @@
(export)
(link [((S : sig8)) unit19]
[() unit38 S]))
(test-runtime-error exn:fail:contract? "unit38 allowed f to flow into uncontracted bad context"
(test-contract-error "(unit unit38)" "f" "not a number"
(invoke-unit unit40)))
;; contracted import -> uncontracted import
@ -418,7 +473,7 @@
(export)
(link [((S : sig7)) unit14]
[() unit41 S]))
(test-runtime-error exn:fail:contract? "unit17 misuses f"
(test-contract-error "(unit unit17)" "f" "not a number"
(invoke-unit unit42)))
(let ()
(define-compound-unit unit43
@ -426,7 +481,7 @@
(export)
(link [((S : sig7)) unit18]
[() unit41 S]))
(test-runtime-error exn:fail:contract? "unit17 misuses f"
(test-contract-error "(unit unit17)" "f" "not a number"
(invoke-unit unit43)))
;; contracted import -> contracted import
@ -444,7 +499,7 @@
(export)
(link [((S : sig9)) unit45-1]
[() unit44 S]))
(test-runtime-error exn:fail:contract? "unit17 misuses f"
(test-contract-error "(unit unit17)" "f" "not a number"
(invoke-unit unit45-2)))
(let ()
(define-unit unit46-1
@ -456,7 +511,7 @@
(export)
(link [((S : sig9)) unit46-1]
[() unit44 S]))
(test-runtime-error exn:fail:contract? "unit17 misuses f"
(test-contract-error "(unit unit17)" "f" "not a number"
(invoke-unit unit46-2)))
;; uncontracted export -> contracted export
@ -470,7 +525,7 @@
(export)
(link [((S : sig8)) unit47]
[() unit13 S]))
(test-runtime-error exn:fail:contract? "unit47 provided bad f"
(test-contract-error "(unit unit47)" "f" "not a number"
(invoke-unit unit48)))
(let ()
(define-compound-unit unit49
@ -478,7 +533,7 @@
(export)
(link [((S : sig8)) unit47]
[() unit17 S]))
(test-runtime-error exn:fail:contract? "unit17 misuses f"
(test-contract-error "(unit unit17)" "f" "not a number"
(invoke-unit unit49)))
;; contracted import -> uncontracted import
@ -492,7 +547,7 @@
(export)
(link [((S : sig7)) unit50]
[() unit12 S]))
(test-runtime-error exn:fail:contract? "unit19 provides bad f"
(test-contract-error "(unit unit19)" "f" "not a number"
(invoke-unit unit51)))
(let ()
(define-compound-unit unit52
@ -500,7 +555,7 @@
(export)
(link [((S : sig7)) unit50]
[() unit16 S]))
(test-runtime-error exn:fail:contract? "unit50 provides unprotected f into bad context"
(test-contract-error "(unit unit50)" "f" "not a number"
(invoke-unit unit52)))
;; contracted export -> contracted export
@ -518,7 +573,7 @@
(export)
(link [((S : sig9)) unit53]
[() unit54-1 S]))
(test-runtime-error exn:fail:contract? "unit19 provides bad f"
(test-contract-error "(unit unit19)" "f" "not a number"
(invoke-unit unit54-2)))
(let ()
(define-unit unit55-1
@ -530,7 +585,7 @@
(export)
(link [((S : sig9)) unit53]
[() unit55-1 S]))
(test-runtime-error exn:fail:contract? "unit55-1 misuses f"
(test-contract-error "(unit unit55-1)" "f" "not a number"
(invoke-unit unit55-2)))
(module m1 scheme
@ -568,8 +623,8 @@
(require (prefix-in m2: 'm2))
(m2:z)
(test-runtime-error exn:fail:contract? "m2 broke the contract on U@ (string, not symbol)" (m2:w))
(test-runtime-error exn:fail:contract? "m1 broke the contract on U@ (number, not string)" (m2:v))
(test-contract-error "'m2" "U@" "not a symbol" (m2:w))
(test-contract-error "'m1" "U@" "not a string" (m2:v))
(test-syntax-error "no y in sig1"
(unit/c (import (sig1 [y number?]))
@ -580,21 +635,21 @@
(test-syntax-error "no sig called faux^, so import description matching fails"
(unit/c (import faux^) (export)))
(test-runtime-error exn:fail:contract? "unit bad-export@ does not export sig1"
(test-contract-error "(definition bad-export@)" "bad-export@" "unit must export sig1"
(let ()
(define/contract bad-export@
(unit/c (import) (export sig1))
(unit (import) (export)))
bad-export@))
(test-runtime-error exn:fail:contract? "contract on bad-import@ does not export sig1"
(test-contract-error "(definition bad-import@)" "bad-import@" "contract must import sig1"
(let ()
(define/contract bad-import@
(unit/c (import) (export))
(unit (import sig1) (export) (+ x 1)))
bad-import@))
(test-runtime-error exn:fail:contract? "value is not a unit"
(test-contract-error "(definition not-a-unit)" "not-a-unit" "not a unit"
(let ()
(define/contract not-a-unit
(unit/c (import) (export))
@ -642,12 +697,12 @@
(require (prefix-in m4: 'm4))
(test-runtime-error exn:fail:contract? "misuse of f by 'm4 (leaked uncontracted to top-level)"
(test-contract-error "'m4" "f" "not an x"
(m4:f 3))
(require (prefix-in m3: 'm3))
(test-runtime-error exn:fail:contract? "misuse of build-toys by top-level"
(test-contract-error top-level "build-toys" "not a integer"
(let ()
(define-values/invoke-unit/infer m3:simple-factory@)
(build-toys #f)))
@ -675,7 +730,7 @@
(m5:f 0)
(test-runtime-error exn:fail:contract? "misuse of f exported by U@ by the top level"
(test-contract-error top-level "U@" "not an x"
(m5:f 3))
(let ()
@ -696,7 +751,7 @@
(define-values/invoke-unit/infer V@)
(f 0)
(test-runtime-error exn:fail:contract? "top-level broke contract on f"
(test-contract-error top-level "f" "not an x"
(f 3)))
(let ()
@ -717,7 +772,7 @@
(define-values/invoke-unit/infer V@)
(f 0)
(test-runtime-error exn:fail:contract? "V@ broke contract on f"
(test-contract-error "(unit V@)" "f" "not an x"
(f 3)))
(let ()
@ -735,11 +790,11 @@
(import) (export) (link U@ V@))
(define-values/invoke-unit/infer U@)
y
(test-runtime-error exn:fail:contract? "top-level broke contract on x"
(test-contract-error top-level "U@" "not a number"
(x #t))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(test-contract-error "(unit U@)" "U@" "not a number"
(x 3))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(test-contract-error "(unit U@)" "U@" "not a number"
(invoke-unit W@)))
(let ()
@ -753,16 +808,16 @@
(define-unit V@
(import foo^)
(export)
(test-runtime-error exn:fail:contract? "top-level broke contract on x"
(test-contract-error top-level "U@" "not an x"
(f 2))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(test-contract-error "(unit U@)" "U@" "not an number"
(f 3)))
(define-compound-unit/infer W@
(import) (export) (link U@ V@))
(define-values/invoke-unit/infer U@)
(test-runtime-error exn:fail:contract? "top-level broke contract on x"
(test-contract-error top-level "U@" "not an x"
(f 4))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(test-contract-error "(unit U@)" "U@" "not a number"
(f 3))
(invoke-unit W@))
@ -782,7 +837,7 @@
(define-values/invoke-unit/infer foo@)
(f 0)
(test-runtime-error exn:fail:contract? "top-level broke the contract on x"
(test-contract-error top-level "f" "not an x"
(f 4))
;; This is a weird one. The definition for foo@ has two conflicting
;; contracts. Who gets blamed? Still the top-level, since foo@ can't
@ -791,7 +846,7 @@
;; just be an "overriding" contract, but a) that won't really work and
;; b) what about other units that might link with foo@, that expect
;; the stronger contract?
(test-runtime-error exn:fail:contract? "top-level broke the contract on x"
(test-contract-error top-level "x?" "not a number"
(f #t)))
(let ()
@ -803,7 +858,7 @@
(define-struct student (name id)))
(define-values/invoke-unit/infer student@)
(make-student "foo" 3)
(test-runtime-error exn:fail:contract? "top-level broke contract on make-student"
(test-contract-error top-level "make-student" "not a string"
(make-student 4 3))
(test-runtime-error exn:fail:contract? "top-level broke contract on student-id"
(test-contract-error top-level "student-id" "not a student"
(student-id 'a)))

2
collects/tests/xml/test-clark.ss
View File

@ -87,4 +87,4 @@
(directory->test-suite
clark-tests-dir))
(run-tests clark-tests)
(run-tests clark-tests)

36
collects/tests/xml/test.ss
View File

@ -48,6 +48,13 @@
(define (test-not-xexpr? xe)
(test-false (format "~S" xe) (xexpr? xe)))
(define (contract->predicate c)
(lambda (v)
(with-handlers ([exn:fail:contract?
(lambda (x) #f)])
(contract c v 'pos 'neg)
#t)))
(define xml-tests
(test-suite
"XML"
@ -79,7 +86,7 @@ END
"DOCTYPE dropping" result-string expected-string)))
(local
[(define a-pi (make-p-i #f #f "foo" "bar"))
[(define a-pi (make-p-i #f #f 'foo "bar"))
(define a-p (make-prolog empty #f empty))
(define a-p/pi (make-prolog (list a-pi) #f (list)))
(define a-d0
@ -137,11 +144,14 @@ END
(test-not-false "element" (element? (make-element #f #f 'br empty empty)))
(test-not-false "content? pcdata" (content? (make-pcdata #f #f "pcdata")))
(test-not-false "content? element" (content? (make-element #f #f 'br empty empty)))
(test-not-false "content? entity" (content? (make-entity #f #f 'nbsp)))
(test-not-false "content? comment" (content? (make-comment "string")))
(test-not-false "content? cdata" (content? (make-cdata #f #f "cdata")))
(local [(define content? (contract->predicate content/c))]
(test-suite
"content?"
(test-not-false "content? pcdata" (content? (make-pcdata #f #f "pcdata")))
(test-not-false "content? element" (content? (make-element #f #f 'br empty empty)))
(test-not-false "content? entity" (content? (make-entity #f #f 'nbsp)))
(test-not-false "content? comment" (content? (make-comment "string")))
(test-not-false "content? cdata" (content? (make-cdata #f #f "cdata")))))
(test-not-false "attribute" (attribute? (make-attribute #f #f 'name "value")))
@ -152,16 +162,14 @@ END
(test-not-false "cdata" (cdata? (make-cdata #f #f "string")))
(test-not-false "p-i" (p-i? (make-p-i #f #f "target" "instruction")))
(test-not-false "p-i" (p-i? (make-p-i #f #f 'target "instruction")))
(test-not-false "comment" (comment? (make-comment "text")))
(test-not-false "source" (source? (make-source 'start 'stop)))
(test-not-false "source" (source? (make-source (make-location 1 2 3) 'stop)))
(test-not-false "source" (source? (make-source 'start (make-location 1 2 3))))
(test-not-false "source" (source? (make-source (make-location 1 2 3) (make-location 4 5 6))))
(test-not-false "exn:invalid-xexpr" (exn:invalid-xexpr? (make-exn:invalid-xexpr "string" (current-continuation-marks) 'nbsp))))
(test-not-false "source" (source? (make-source (make-location 1 2 3) (make-location 4 5 6)))))
(test-suite
"Reading and Writing XML"
@ -543,7 +551,7 @@ END
(test-validate-xexpr (make-pcdata #f #f "pcdata"))
(test-validate-xexpr (make-cdata #f #f "cdata"))
(test-validate-xexpr (make-comment "comment"))
(test-validate-xexpr (make-p-i #f #f "s1" "s2"))
(test-validate-xexpr (make-p-i #f #f 's1 "s2"))
(test-validate-xexpr '(br))
(test-validate-xexpr '(br ()))
(test-validate-xexpr '(a ([href "#"]) "string"))
@ -561,7 +569,7 @@ END
"Non-permissive"
(lambda (exn)
(and (exn? exn)
(regexp-match #rx"Expected content," (exn-message exn))))
(regexp-match #rx"not in permissive mode" (exn-message exn))))
(lambda ()
(xml->xexpr #f)))
@ -596,7 +604,7 @@ END
(test-empty-tag-shorthand '(html) "<html>Hey</html>" "<html>Hey</html>")
(test-empty-tag-shorthand '(p) "<html></html>" "<html></html>")
(test-empty-tag-shorthand '(p) "<html>Hey</html>" "<html>Hey</html>"))
(test-equal? "html-empty-tags"
html-empty-tags
'(param meta link isindex input img hr frame col br basefont base area))
@ -615,7 +623,7 @@ END
"read-comments"
(test-read-comments #f "<html><!-- Foo --></html>" "<html />")
(test-read-comments #t "<html><!-- Foo --></html>" "<html><!-- Foo --></html>"))
(local
[(define (test-xexpr-drop-empty-attributes v istr xe)
(test-equal? (format "~S" (list v istr))

45
collects/texpict/utils.ss
View File

@ -72,7 +72,8 @@
((or/c false/c number?)
(or/c false/c string?)
boolean?
boolean?)
boolean?
#:hide-arrowhead? any/c)
pict?)]
[pin-arrows-line (->* (number? pict?
pict? (-> pict? pict? (values number? number?))
@ -80,7 +81,8 @@
((or/c false/c number?)
(or/c false/c string?)
boolean?
boolean?)
boolean?
#:hide-arrowhead? any/c)
pict?)])
@ -184,7 +186,7 @@
(send dc set-pen (send the-pen-list
find-or-create-pen
(send p get-color)
0
(if solid? 0 (send p get-width))
'solid))
(send dc set-brush (send the-brush-list
find-or-create-brush
@ -774,7 +776,8 @@
(send dc set-brush old-brush)))
w h)))
(define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head?)
(define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head?
#:hide-arrowhead? [hide-arrowhead? #f])
(let-values ([(sx sy) (find-src base src)]
[(dx dy) (find-dest base dest)])
(let ([arrows
@ -790,7 +793,8 @@
[dsx (* (or arrow2-size 0) 0.5 (- cosa))]
[dsy (* (or arrow2-size 0) 0.5 (- sina))])
`(connect ,(+ sx dsx) ,(+ sy dsy) ,(+ dx ddx) ,(+ dy ddy)))
,@(if arrow-size
,@(if (and arrow-size
(not hide-arrowhead?))
(let-values ([(arrow xo yo)
(arrowhead/delta
(or thickness 0)
@ -800,7 +804,8 @@
solid-head?)])
`((place ,(+ dx xo) ,(+ dy yo) ,arrow)))
null)
,@(if arrow2-size
,@(if (and arrow2-size
(not hide-arrowhead?))
(let-values ([(arrow xo yo)
(arrowhead/delta
(or thickness 0)
@ -827,12 +832,16 @@
(-add-line base src find-src dest find-dest thickness color #f #f under? #t)))
(define add-arrow-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
(-add-line base src find-src dest find-dest thickness color arrow-size #f under? #t)))
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(-add-line base src find-src dest find-dest thickness color arrow-size #f under? #t
#:hide-arrowhead? hide-arrowhead?)))
(define add-arrows-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
(-add-line base src find-src dest find-dest thickness color arrow-size arrow-size under? #t)))
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]
#:hide-arrowhead? [hide-arrowhead? #f])
(-add-line base src find-src dest find-dest thickness color arrow-size arrow-size under? #t
#:hide-arrowhead? hide-arrowhead?)))
(define (flip-find-y find-)
(lambda (base path)
@ -842,17 +851,21 @@
(define pin-line
(lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
(-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color #f #f under? #t)))
thickness color #f #f under? #t)))
(define pin-arrow-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t])
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
(-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color arrow-size #f under? solid-head?)))
thickness color arrow-size #f under? solid-head?
#:hide-arrowhead? hide-arrowhead?)))
(define pin-arrows-line
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t])
(lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t]
#:hide-arrowhead? [hide-arrowhead? #f])
(-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color arrow-size arrow-size under? solid-head?)))
thickness color arrow-size arrow-size under? solid-head?
#:hide-arrowhead? hide-arrowhead?)))
(define black-color (make-object color% 0 0 0))

6
collects/web-server/configuration/responders.ss
View File

@ -1,8 +1,8 @@
#lang scheme
(require scheme/runtime-path
net/url
web-server/http/response-structs
web-server/private/xexpr
web-server/http/response-structs
web-server/http/request-structs)
(define (format-stack-trace trace)
@ -33,7 +33,9 @@
(div ([class "title"]) "Exception")
(p
"The application raised an exception with the message:"
(pre ,(reformat-xexpr-exn (exn-message exn))))
(pre ,(if (exn:pretty? exn)
(exn:pretty-xexpr exn)
(exn-message exn))))
(p
"Stack trace:"
,(format-stack-trace

5
collects/web-server/default-web-root/htdocs/servlets/examples/bad-xexpr.ss Normal file
View File

@ -0,0 +1,5 @@
#lang web-server/insta
(define (start initial-request)
`(html (head (title "Foo"))
(body (a ([href #f])
"Zog"))))

4
collects/web-server/formlets/input.ss
View File

@ -1,6 +1,6 @@
#lang scheme
(require web-server/http
xml
web-server/private/xexpr
(only-in "lib.ss"
formlet/c
pure
@ -31,7 +31,7 @@
default))))
(provide/contract
[make-input ((string? . -> . xexpr/c) . -> . (formlet/c (or/c false/c binding?)))]
[make-input ((string? . -> . pretty-xexpr/c) . -> . (formlet/c (or/c false/c binding?)))]
#;[binding:form-required (formlet/c (binding? . -> . bytes?))]
#;[binding:form/default (bytes? . -> . (formlet/c (binding? . -> . bytes?)))])

6
collects/web-server/formlets/lib.ss
View File

@ -1,6 +1,6 @@
#lang scheme
(require web-server/http
xml)
web-server/private/xexpr)
; Combinators
(define (const x) (lambda _ x))
@ -68,7 +68,7 @@
; Contracts
(define xexpr-forest/c
(listof xexpr/c))
(listof pretty-xexpr/c))
(define (formlet/c c)
(integer? . -> .
@ -91,7 +91,7 @@
() #:rest (listof (formlet/c alpha))
. ->* . (formlet/c beta))]
[xml-forest (xexpr-forest/c . -> . (formlet/c procedure?))]
[xml (xexpr? . -> . (formlet/c procedure?))]
[xml (pretty-xexpr/c . -> . (formlet/c procedure?))]
[text (string? . -> . (formlet/c procedure?))]
[tag-xexpr (symbol? (listof (list/c symbol? string?)) (formlet/c alpha) . -> . (formlet/c alpha))]
[formlet-display ((formlet/c alpha) . -> . xexpr-forest/c)]

6
collects/web-server/formlets/servlet.ss
View File

@ -1,11 +1,11 @@
#lang scheme
(require web-server/servlet
xml
web-server/private/xexpr
"lib.ss")
(provide/contract
[send/formlet (((formlet/c any/c))
(#:wrap (xexpr/c . -> . response/c))
(#:wrap (pretty-xexpr/c . -> . response/c))
. ->* . any/c)])
(define (send/formlet f
@ -23,7 +23,7 @@
,@(formlet-display f)))))))
(provide/contract
[embed-formlet (embed/url/c (formlet/c any/c) . -> . xexpr/c)])
[embed-formlet (embed/url/c (formlet/c any/c) . -> . pretty-xexpr/c)])
(define (embed-formlet embed/url f)
`(form ([action ,(embed/url

38
collects/web-server/http/cookie-parse.ss
View File

@ -41,9 +41,9 @@
(define-empty-tokens keywords (EQUALS SEMI COMMA PATH DOMAIN VERSION EOF))
(define cookie-lexer
(lexer
(lexer-src-pos
[(eof) (token-EOF)]
[whitespace (cookie-lexer input-port)]
[whitespace (return-without-pos (cookie-lexer input-port))]
["=" (token-EQUALS)]
[";" (token-SEMI)]
["," (token-COMMA)]
@ -54,8 +54,18 @@
(token-QUOTED-STRING (substring lexeme 1 (- (string-length lexeme) 1)))]
[(:+ token-char) (token-TOKEN lexeme)]))
(define current-source-name (make-parameter #f))
(define (make-srcloc start-pos end-pos)
(list (current-source-name)
(position-line start-pos)
(position-col start-pos)
(position-offset start-pos)
(- (position-offset end-pos) (position-offset start-pos))))
(define assoc-list-parser
(parser (start cookie)
(parser (src-pos)
(start cookie)
(tokens regular keywords)
(grammar (cookie [(VERSION EQUALS rhs separator items) $5]
[(items) $1])
@ -71,16 +81,26 @@
(rhs [(TOKEN) $1]
[(QUOTED-STRING) $1]))
(end EOF)
(error (lambda (a b c) (error 'assoc-list-parser "Malformed cookie: ~v ~v ~v" a b c)))))
(error (lambda (tok-ok? tok-name tok-value start-pos end-pos)
(raise-syntax-error
'assoc-list-parser
(format
(if tok-ok?
"Did not expect token ~a"
"Invalid token ~a")
tok-name)
(datum->syntax #f tok-value (make-srcloc start-pos end-pos)))))))
(define (do-parse str)
(with-handlers ([exn:fail?
(λ (e) empty)])
(let ([ip (open-input-string str)])
(dynamic-wind
void
(λ () (raw->cookies (assoc-list-parser (λ () (cookie-lexer ip)))))
(λ () (close-input-port ip))))))
(with-input-from-string
str
(λ ()
(let ([ip (current-input-port)])
(port-count-lines! ip)
(parameterize ([current-source-name (object-name ip)])
(raw->cookies (assoc-list-parser (λ () (cookie-lexer ip))))))))))
;; raw->cookies : flat-property-list -> (listof cookie)
(define (raw->cookies associations)

3
collects/web-server/http/cookie.ss
View File

@ -3,6 +3,7 @@
web-server/http/request-structs
web-server/http/response-structs
xml
web-server/private/xexpr
scheme/contract)
(provide/contract
@ -13,7 +14,7 @@
#:secure? (or/c false/c boolean?))
. ->* . cookie?)]
[cookie->header (cookie? . -> . header?)]
[xexpr-response/cookies ((listof cookie?) xexpr/c . -> . response/full?)])
[xexpr-response/cookies ((listof cookie?) pretty-xexpr/c . -> . response/full?)])
(define (set-when-true fn val)
(if val

31
collects/web-server/http/response-structs.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require mzlib/contract
scheme/list
xml/xml
#lang scheme
(require scheme
xml
web-server/private/xexpr
web-server/http/request-structs)
(define TEXT/HTML-MIME-TYPE #"text/html; charset=utf-8")
@ -13,7 +13,7 @@
(define response/c
(or/c response/basic?
(cons/c bytes? (listof (or/c string? bytes?)))
xexpr/c))
pretty-xexpr/c))
;; response/full->size: response/full -> number
(define (response/full->size resp)
@ -69,9 +69,18 @@
[else
(normalize-response
close?
(make-response/full
200 #"Okay" (current-seconds) TEXT/HTML-MIME-TYPE empty
(list (string->bytes/utf-8 (xexpr->string resp)))))]))
(make-xexpr-response resp))]))
(define (make-xexpr-response
xexpr
#:code [code 200]
#:message [message #"Okay"]
#:seconds [seconds (current-seconds)]
#:mime-type [mime-type TEXT/HTML-MIME-TYPE]
#:headers [hdrs empty])
(make-response/full
code message seconds mime-type hdrs
(list (string->bytes/utf-8 (xexpr->string xexpr)))))
(provide/contract
[struct response/basic
@ -93,7 +102,11 @@
[seconds number?]
[mime bytes?]
[headers (listof header?)]
[generator ((() (listof bytes?) . ->* . any) . -> . any)])]
[generator ((() () #:rest (listof bytes?) . ->* . any) . -> . any)])]
[response/c contract?]
[make-xexpr-response
((pretty-xexpr/c)
(#:code number? #:message bytes? #:seconds number? #:mime-type bytes? #:headers (listof header?))
. ->* . response/full?)]
[normalize-response (boolean? response/c . -> . (or/c response/full? response/incremental?))]
[TEXT/HTML-MIME-TYPE bytes?])

73
collects/web-server/private/xexpr.ss
View File

@ -1,14 +1,39 @@
#lang scheme
(require scheme/pretty
xml/xml)
xml)
(define-struct (exn:pretty exn) (xexpr))
(provide/contract
[struct (exn:pretty exn) ([message string?]
[continuation-marks continuation-mark-set?]
[xexpr xexpr/c])]
[format-xexpr/errors (any/c . -> . string?)]
[reformat-xexpr-exn (string? . -> . xexpr/c)])
[pretty-xexpr/c contract?])
(define pretty-xexpr/c
(make-proj-contract
'pretty-xexpr/c
(lambda (pos neg src-info name)
(lambda (val)
(define marks (current-continuation-marks))
(with-handlers ([exn:fail:contract?
(lambda (exn)
(raise
(make-exn:pretty
(exn-message exn)
marks
`(span ,(drop-after "Context:\n" (exn-message exn))
,(make-cdata #f #f (format-xexpr/errors val))))))])
(contract xexpr/c val pos neg src-info))))
(lambda (v) #t)))
(define (drop-after delim str)
(substring str 0 (cdr (first (regexp-match-positions (regexp-quote delim) str)))))
; Formating Xexprs
(define (format-xexpr/errors v)
(pretty-format (format-xexpr v)))
(pretty-format (format-xexpr v) 80))
(define-struct xexpr-error (message content)
#:property prop:custom-write
@ -26,7 +51,8 @@
(symbol? v)
(exact-nonnegative-integer? v)
(comment? v)
(pi? v)
(p-i? v)
(pcdata? v)
(cdata? v)))
(define (format-xexpr v)
@ -43,7 +69,7 @@
(format-elements+attributes (cdr v)))])]
[(xexpr-datum? v) v]
[else
(mark-error "Not a valid Xexpr datum (Must be a string, symbol, exact nonnegative integer, comment, PI, or cdata.)" v)]))
(mark-error "Not a valid Xexpr datum (Must be a string, symbol, exact nonnegative integer, comment, PI, pcdata, or cdata.)" v)]))
(define (format-elements+attributes l)
(match l
@ -87,39 +113,4 @@
[(list attr (? string? val))
(list (mark-error "Not a valid attribute name (Must be symbol.)" attr) val)]
[else
(mark-error "Not a valid attribute (Must be a list of a symbol and a string.)" l)]))
; Reformating Xexpr errors
(define (parse-xexpr-error s)
(with-input-from-string
s (lambda ()
(define violator (read))
(define c:broke (read))
(define c:the (read))
(define c:contract (read))
(define contract-expr (read))
(define c:on (read))
(define contracted (read))
(define c:semi (read-char))
(define xml:msg (read-line))
(define blank (read-line))
(define c:context (read-line))
(define not-xexpr (read))
(when
(or (ormap eof-object?
(list violator c:broke c:the c:contract contract-expr
c:on contracted c:semi xml:msg blank c:context not-xexpr))
(not (andmap symbol=?
(list 'broke 'the 'contract 'on '|;| 'Context:)
(list c:broke c:the c:contract c:on c:semi c:context))))
(error 'parse-xexpr-error "Not Xexpr error"))
(values violator contract-expr contracted xml:msg not-xexpr))))
(define (reformat-xexpr-exn m)
(with-handlers ([exn? (lambda _ m)])
(define-values (violator contract-expr contracted xml:msg not-xexpr)
(parse-xexpr-error m))
`(span ,(format "~a broke the contract~n~a~non ~a;~a~n~nContext:~n"
violator (pretty-format contract-expr) contracted
xml:msg)
,(make-cdata #f #f (format-xexpr/errors not-xexpr)))))
(mark-error "Not a valid attribute (Must be a list of a symbol and a string.)" l)]))

17
collects/web-server/scribblings/http.scrbl
View File

@ -13,6 +13,7 @@ The @web-server implements many HTTP RFCs that are provided by this module.
@; ------------------------------------------------------------
@section[#:tag "request-structs.ss"]{Requests}
@(require (for-label web-server/http/request-structs
xml
scheme/match))
@defmodule[web-server/http/request-structs]{
@ -198,7 +199,7 @@ Here is an example typical of what you will find in many applications:
}
@defstruct[(response/incremental response/basic)
([generator ((() (listof bytes?) . ->* . any) . -> . any)])]{
([generator ((() () #:rest (listof bytes?) . ->* . any) . -> . any)])]{
As with @scheme[response/basic], except with @scheme[generator] as a function that is
called to generate the response body, by being given an @scheme[output-response] function
that outputs the content it is called with.
@ -224,6 +225,20 @@ Here is an example typical of what you will find in many applications:
xexpr/c)].
}
@defproc[(make-xexpr-response [xexpr xexpr/c]
[#:code code number? 200]
[#:message message bytes? #"Okay"]
[#:seconds seconds number? (current-seconds)]
[#:mime-type mime-type bytes? TEXT/HTML-MIME-TYPE]
[#:headers headers (listof header?) empty])
response/full?]{
Equivalent to
@schemeblock[
(make-response/full
code message seconds mime-type headers
(list (string->bytes/utf-8 (xexpr->string xexpr))))
]}
@defproc[(normalize-response [close? boolean?] [response response/c])
(or/c response/full? response/incremental?)]{
Coerces @scheme[response] into a full response, filling in additional details where appropriate.

9
collects/xml/main.ss
View File

@ -1,11 +1,4 @@
#lang scheme/base
(require "xml.ss")
(provide (except-out (all-from-out "xml.ss")
pi struct:pi pi? make-pi pi-target-name pi-instruction)
(rename-out [pi p-i]
[struct:pi struct:p-i]
[pi? p-i?]
[make-pi make-p-i]
[pi-target-name p-i-target-name]
[pi-instruction p-i-instruction]))
(provide (all-from-out "xml.ss"))

913
collects/xml/private/reader.ss
View File

@ -1,462 +1,463 @@
#lang scheme
(require "sig.ss")
(require "structures.ss")
(provide reader@)
(provide/contract
[read-xml (() (input-port?) . ->* . document?)]
[read-xml/element (() (input-port?) . ->* . element?)]
[read-comments (parameter/c boolean?)]
[collapse-whitespace (parameter/c boolean?)]
[exn:xml? (any/c . -> . boolean?)])
(define-unit reader@
(import xml-structs^)
(export 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-comments (make-parameter #f))
(define collapse-whitespace (make-parameter #f))
;; read-xml : [Input-port] -> Document
(define read-xml
(lambda ([in (current-input-port)])
(let*-values ([(in pos) (positionify in)]
[(misc0 start) (read-misc in pos)])
(make-document (make-prolog misc0 #f empty)
(read-xml-element-helper pos in start)
(let ([loc-before (pos)])
(let-values ([(misc1 end-of-file) (read-misc in pos)])
(unless (eof-object? end-of-file)
(let ([loc-after (pos)])
(parse-error (list
(make-srcloc
(object-name in)
#f
#f
(location-offset loc-before)
(- (location-offset loc-after)
(location-offset loc-before))))
"extra stuff at end of document ~e"
end-of-file)))
misc1))))))
;; read-xml/element : [Input-port] -> Element
(define read-xml/element
(lambda ([in (current-input-port)])
(let-values ([(in pos) (positionify in)])
(skip-space in)
(read-xml-element-helper pos in (lex in pos)))))
;; read-xml-element-helper : Nat Iport Token -> Element
(define (read-xml-element-helper pos in start)
(cond
[(start-tag? start) (read-element start in pos)]
[(element? start) start]
[else (parse-error (list
(make-srcloc
(object-name in)
#f
#f
1
(- (location-offset (pos)) 1)))
"expected root element - received ~e"
(if (pcdata? start) (pcdata-string start) start))]))
;; read-misc : Input-port (-> Location) -> (listof Misc) Token
(define (read-misc in pos)
(let read-more ()
;; 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-comments (make-parameter #f))
(define collapse-whitespace (make-parameter #f))
;; read-xml : [Input-port] -> Document
(define read-xml
(lambda ([in (current-input-port)])
(let*-values ([(in pos) (positionify in)]
[(misc0 start) (read-misc in pos)])
(make-document (make-prolog misc0 #f empty)
(read-xml-element-helper pos in start)
(let ([loc-before (pos)])
(let-values ([(misc1 end-of-file) (read-misc in pos)])
(unless (eof-object? end-of-file)
(let ([loc-after (pos)])
(parse-error (list
(make-srcloc
(object-name in)
#f
#f
(location-offset loc-before)
(- (location-offset loc-after)
(location-offset loc-before))))
"extra stuff at end of document ~e"
end-of-file)))
misc1))))))
;; read-xml/element : [Input-port] -> Element
(define read-xml/element
(lambda ([in (current-input-port)])
(let-values ([(in pos) (positionify in)])
(skip-space in)
(read-xml-element-helper pos in (lex in pos)))))
;; read-xml-element-helper : Nat Iport Token -> Element
(define (read-xml-element-helper pos in start)
(cond
[(start-tag? start) (read-element start in pos)]
[(element? start) start]
[else (parse-error (list
(make-srcloc
(object-name in)
#f
#f
1
(- (location-offset (pos)) 1)))
"expected root element - received ~e"
(if (pcdata? start) (pcdata-string start) start))]))
;; read-misc : Input-port (-> Location) -> (listof Misc) Token
(define (read-misc in pos)
(let read-more ()
(let ([x (lex in pos)])
(cond
[(p-i? x)
(let-values ([(lst next) (read-more)])
(values (cons x lst) next))]
[(comment? x)
(let-values ([(lst next) (read-more)])
(if (read-comments)
(values (cons x lst) next)
(values lst next)))]
[(and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x))))
(read-more)]
[else (values null x)]))))
;; read-element : Start-tag Input-port (-> Location) -> Element
(define (read-element start in pos)
(let ([name (start-tag-name start)]
[a (source-start start)]
[b (source-stop start)])
(let read-content ([k (lambda (body end-loc)
(make-element
a end-loc name (start-tag-attrs start)
body))])
(let ([x (lex in pos)])
(cond
[(pi? x)
(let-values ([(lst next) (read-more)])
(values (cons x lst) next))]
[(comment? x)
(let-values ([(lst next) (read-more)])
(if (read-comments)
(values (cons x lst) next)
(values lst next)))]
[(and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x))))
(read-more)]
[else (values null x)]))))
;; read-element : Start-tag Input-port (-> Location) -> Element
(define (read-element start in pos)
(let ([name (start-tag-name start)]
[a (source-start start)]
[b (source-stop start)])
(let read-content ([k (lambda (body end-loc)
(make-element
a end-loc name (start-tag-attrs start)
body))])
(let ([x (lex in pos)])
(cond
[(eof-object? x)
(parse-error (list
(make-srcloc
(object-name in)
#f
#f
(location-offset (source-start start))
(- (location-offset (source-stop start))
(location-offset (source-start start)))))
"unclosed `~a' tag at [~a ~a]"
name
(format-source a)
(format-source b))]
[(start-tag? x)
(let ([next-el (read-element x in pos)])
(read-content (lambda (body end-loc)
(k (cons next-el body)
end-loc))))]
[(end-tag? x)
(let ([end-loc (source-stop x)])
(unless (eq? name (end-tag-name x))
(parse-error
(list
(make-srcloc (object-name in)
#f
#f
(location-offset a)
(- (location-offset b) (location-offset a)))
(make-srcloc (object-name in)
#f
#f
(location-offset (source-start x))
(- (location-offset end-loc) (location-offset (source-start x)))))
"start tag `~a' at [~a ~a] doesn't match end tag `~a' at [~a ~a]"
name
(format-source a)
(format-source b)
(end-tag-name x)
(format-source (source-start x))
(format-source end-loc)))
(k null end-loc))]
[(entity? x) (read-content (lambda (body end-loc)
(k (cons (expand-entity x) body)
end-loc)))]
[(comment? x) (if (read-comments)
(read-content (lambda (body end-loc) (k (cons x body) end-loc)))
(read-content k))]
[else (read-content (lambda (body end-loc) (k (cons x body) end-loc)))])))))
;; 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 (-> Location) -> (U Token special)
(define (lex in pos)
[(eof-object? x)
(parse-error (list
(make-srcloc
(object-name in)
#f
#f
(location-offset (source-start start))
(- (location-offset (source-stop start))
(location-offset (source-start start)))))
"unclosed `~a' tag at [~a ~a]"
name
(format-source a)
(format-source b))]
[(start-tag? x)
(let ([next-el (read-element x in pos)])
(read-content (lambda (body end-loc)
(k (cons next-el body)
end-loc))))]
[(end-tag? x)
(let ([end-loc (source-stop x)])
(unless (eq? name (end-tag-name x))
(parse-error
(list
(make-srcloc (object-name in)
#f
#f
(location-offset a)
(- (location-offset b) (location-offset a)))
(make-srcloc (object-name in)
#f
#f
(location-offset (source-start x))
(- (location-offset end-loc) (location-offset (source-start x)))))
"start tag `~a' at [~a ~a] doesn't match end tag `~a' at [~a ~a]"
name
(format-source a)
(format-source b)
(end-tag-name x)
(format-source (source-start x))
(format-source end-loc)))
(k null end-loc))]
[(entity? x) (read-content (lambda (body end-loc)
(k (cons (expand-entity x) body)
end-loc)))]
[(comment? x) (if (read-comments)
(read-content (lambda (body end-loc) (k (cons x body) end-loc)))
(read-content k))]
[else (read-content (lambda (body end-loc) (k (cons x body) end-loc)))])))))
;; 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 (-> Location) -> (U Token special)
(define (lex in pos)
(let ([c (peek-char-or-special in)])
(cond
[(eof-object? c) c]
[(eq? c #\&) (lex-entity in pos)]
[(eq? c #\<) (lex-tag-cdata-pi-comment in pos)]
[(not (char? c)) (read-char-or-special in)]
[else (lex-pcdata in pos)])))
; lex-entity : Input-port (-> Location) -> Entity
; pre: the first char is a #\&
(define (lex-entity in pos)
(let ([start (pos)])
(read-char in)
(let ([data (case (peek-char in)
[(#\#)
(read-char in)
(let ([n (case (peek-char in)
[(#\x) (read-char in)
(string->number (read-until #\; in pos) 16)]
[else (string->number (read-until #\; in pos))])])
(unless (number? n)
(lex-error in pos "malformed numeric entity"))
n)]
[else
(begin0
(lex-name in pos)
(unless (eq? (read-char in) #\;)
(lex-error in pos "expected ; at the end of an entity")))])])
(make-entity start (pos) data))))
; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Cdata | p-i | Comment
; pre: the first char is a #\<
(define (lex-tag-cdata-pi-comment in pos)
(let ([start (pos)])
(read-char in)
(case (non-eof peek-char-or-special in pos)
[(#\!)
(read-char in)
(case (non-eof peek-char in pos)
[(#\-) (read-char in)
(unless (eq? (read-char-or-special in) #\-)
(lex-error in pos "expected second - after <!-"))
(let ([data (lex-comment-contents in pos)])
(unless (eq? (read-char in) #\>)
(lex-error in pos "expected > to end comment (\"--\" can't appear in comments)"))
;(make-comment start (pos) data)
(make-comment data))]
[(#\[) (read-char in)
(unless (string=? (read-string 6 in) "CDATA[")
(lex-error in pos "expected CDATA following <["))
(let ([data (lex-cdata-contents in pos)])
(make-cdata start (pos) (format "<![CDATA[~a]]>" data)))]
[else (skip-dtd in pos)
(skip-space in)
(unless (eq? (peek-char-or-special in) #\<)
(lex-error in pos "expected p-i, comment, or element after doctype"))
(lex-tag-cdata-pi-comment in pos)])]
[(#\?) (read-char in)
(let ([name (lex-name in pos)])
(skip-space in)
(let ([data (lex-pi-data in pos)])
(make-p-i start (pos) name data)))]
[(#\/) (read-char in)
(let ([name (lex-name in pos)])
(skip-space in)
(unless (eq? (read-char-or-special in) #\>)
(lex-error in pos "expected > to close ~a's end tag" name))
(make-end-tag start (pos) name))]
[else ; includes 'special, but lex-name will fail in that case
(let ([name (lex-name in pos)]
[attrs (lex-attributes in pos)])
(skip-space in)
(case (read-char-or-special in)
[(#\/)
(unless (eq? (read-char in) #\>)
(lex-error in pos "expected > to close empty element ~a" name))
(make-element start (pos) name attrs null)]
[(#\>) (make-start-tag start (pos) name attrs)]
[else (lex-error in pos "expected / or > to close tag `~a'" name)]))])))
;; lex-attributes : Input-port (-> Location) -> (listof Attribute)
(define (lex-attributes in pos)
(sort (let loop ()
(skip-space in)
(cond [(name-start? (peek-char-or-special in))
(cons (lex-attribute in pos) (loop))]
[else null]))
(lambda (a b)
(let ([na (attribute-name a)]
[nb (attribute-name b)])
(cond
[(eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)]
[else (string<? (symbol->string na) (symbol->string nb))])))))
;; lex-attribute : Input-port (-> Location) -> Attribute
(define (lex-attribute in pos)
(let ([start (pos)]
[name (lex-name in pos)])
(skip-space in)
(unless (eq? (read-char in) #\=)
(lex-error in pos "expected = in attribute ~a" name))
(skip-space in)
;; more here - handle entites and disallow "<"
(let* ([delimiter (read-char-or-special in)]
[value (case delimiter
[(#\' #\")
(list->string
(let read-more ()
(let ([c (non-eof peek-char-or-special in pos)])
(cond
[(eq? c 'special)
(lex-error in pos "attribute values cannot contain non-text values")]
[(eq? c delimiter) (read-char in) null]
[(eq? c #\&)
(let ([entity (expand-entity (lex-entity in pos))])
(if (pcdata? entity)
(append (string->list (pcdata-string entity)) (read-more))
;; more here - do something with user defined entites
(read-more)))]
[else (read-char in) (cons c (read-more))]))))]
[else (if (char? delimiter)
(lex-error in pos "attribute values must be in ''s or in \"\"s")
delimiter)])])
(make-attribute start (pos) name value))))
;; skip-space : Input-port -> Void
;; deviation - should sometimes insist on at least one space
(define (skip-space in)
(let loop ()
(let ([c (peek-char-or-special in)])
(cond
[(eof-object? c) c]
[(eq? c #\&) (lex-entity in pos)]
[(eq? c #\<) (lex-tag-cdata-pi-comment in pos)]
[(not (char? c)) (read-char-or-special in)]
[else (lex-pcdata in pos)])))
; lex-entity : Input-port (-> Location) -> Entity
; pre: the first char is a #\&
(define (lex-entity in pos)
(let ([start (pos)])
(read-char in)
(let ([data (case (peek-char in)
[(#\#)
(read-char in)
(let ([n (case (peek-char in)
[(#\x) (read-char in)
(string->number (read-until #\; in pos) 16)]
[else (string->number (read-until #\; in pos))])])
(unless (number? n)
(lex-error in pos "malformed numeric entity"))
n)]
[else
(begin0
(lex-name in pos)
(unless (eq? (read-char in) #\;)
(lex-error in pos "expected ; at the end of an entity")))])])
(make-entity start (pos) data))))
; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Cdata | Pi | Comment
; pre: the first char is a #\<
(define (lex-tag-cdata-pi-comment in pos)
(let ([start (pos)])
(read-char in)
(case (non-eof peek-char-or-special in pos)
[(#\!)
(read-char in)
(case (non-eof peek-char in pos)
[(#\-) (read-char in)
(unless (eq? (read-char-or-special in) #\-)
(lex-error in pos "expected second - after <!-"))
(let ([data (lex-comment-contents in pos)])
(unless (eq? (read-char in) #\>)
(lex-error in pos "expected > to end comment (\"--\" can't appear in comments)"))
;(make-comment start (pos) data)
(make-comment data))]
[(#\[) (read-char in)
(unless (string=? (read-string 6 in) "CDATA[")
(lex-error in pos "expected CDATA following <["))
(let ([data (lex-cdata-contents in pos)])
(make-cdata start (pos) (format "<![CDATA[~a]]>" data)))]
[else (skip-dtd in pos)
(skip-space in)
(unless (eq? (peek-char-or-special in) #\<)
(lex-error in pos "expected pi, comment, or element after doctype"))
(lex-tag-cdata-pi-comment in pos)])]
[(#\?) (read-char in)
(let ([name (lex-name in pos)])
(skip-space in)
(let ([data (lex-pi-data in pos)])
(make-pi start (pos) name data)))]
[(#\/) (read-char in)
(let ([name (lex-name in pos)])
(skip-space in)
(unless (eq? (read-char-or-special in) #\>)
(lex-error in pos "expected > to close ~a's end tag" name))
(make-end-tag start (pos) name))]
[else ; includes 'special, but lex-name will fail in that case
(let ([name (lex-name in pos)]
[attrs (lex-attributes in pos)])
(skip-space in)
(case (read-char-or-special in)
[(#\/)
(unless (eq? (read-char in) #\>)
(lex-error in pos "expected > to close empty element ~a" name))
(make-element start (pos) name attrs null)]
[(#\>) (make-start-tag start (pos) name attrs)]
[else (lex-error in pos "expected / or > to close tag `~a'" name)]))])))
;; lex-attributes : Input-port (-> Location) -> (listof Attribute)
(define (lex-attributes in pos)
(sort (let loop ()
(skip-space in)
(cond [(name-start? (peek-char-or-special in))
(cons (lex-attribute in pos) (loop))]
[else null]))
(lambda (a b)
(let ([na (attribute-name a)]
[nb (attribute-name b)])
(cond
[(eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)]
[else (string<? (symbol->string na) (symbol->string nb))])))))
;; lex-attribute : Input-port (-> Location) -> Attribute
(define (lex-attribute in pos)
(let ([start (pos)]
[name (lex-name in pos)])
(skip-space in)
(unless (eq? (read-char in) #\=)
(lex-error in pos "expected = in attribute ~a" name))
(skip-space in)
;; more here - handle entites and disallow "<"
(let* ([delimiter (read-char-or-special in)]
[value (case delimiter
[(#\' #\")
(list->string
(let read-more ()
(let ([c (non-eof peek-char-or-special in pos)])
(cond
[(eq? c 'special)
(lex-error in pos "attribute values cannot contain non-text values")]
[(eq? c delimiter) (read-char in) null]
[(eq? c #\&)
(let ([entity (expand-entity (lex-entity in pos))])
(if (pcdata? entity)
(append (string->list (pcdata-string entity)) (read-more))
;; more here - do something with user defined entites
(read-more)))]
[else (read-char in) (cons c (read-more))]))))]
[else (if (char? delimiter)
(lex-error in pos "attribute values must be in ''s or in \"\"s")
delimiter)])])
(make-attribute start (pos) name value))))
;; skip-space : Input-port -> Void
;; deviation - should sometimes insist on at least one space
(define (skip-space in)
(let loop ()
(let ([c (peek-char-or-special in)])
(when (and (char? c)
(char-whitespace? c))
(read-char in)
(loop)))))
;; lex-pcdata : Input-port (-> Location) -> Pcdata
;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec
(define (lex-pcdata in pos)
(let ([start (pos)]
[data (let loop ()
(let ([next (peek-char-or-special in)])
(cond
[(or (eof-object? next)
(not (char? next))
(eq? next #\&)
(eq? next #\<))
null]
[(and (char-whitespace? next) (collapse-whitespace))
(skip-space in)
(cons #\space (loop))]
[else (cons (read-char in) (loop))])))])
(make-pcdata start
(pos)
(list->string data))))
;; lex-name : Input-port (-> Location) -> Symbol
(define (lex-name in pos)
(let ([c (non-eof read-char-or-special in pos)])
(unless (name-start? c)
(lex-error in pos "expected name, received ~e" c))
(string->symbol
(list->string
(cons c (let lex-rest ()
(let ([c (non-eof peek-char-or-special in pos)])
(cond
[(eq? c 'special)
(lex-error in pos "names cannot contain non-text values")]
[(name-char? c)
(cons (read-char in) (lex-rest))]
[else null]))))))))
;; skip-dtd : Input-port (-> Location) -> Void
(define (skip-dtd in pos)
(let skip ()
(case (non-eof read-char in pos)
[(#\') (read-until #\' in pos) (skip)]
[(#\") (read-until #\" in pos) (skip)]
[(#\<)
(case (non-eof read-char in pos)
[(#\!) (case (non-eof read-char in pos)
[(#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip)]
[else (skip) (skip)])]
[(#\?) (lex-pi-data in pos) (skip)]
[else (skip) (skip)])]
[(#\>) (void)]
[else (skip)])))
;; name-start? : Char -> Bool
(define (name-start? ch)
(and (char? ch)
(or (char-alphabetic? ch)
(eq? ch #\_)
(eq? ch #\:))))
;; name-char? : Char -> Bool
(define (name-char? ch)
(and (char? ch)
(or (name-start? ch)
(char-numeric? ch)
(eq? ch #\.)
(eq? ch #\-))))
;; read-until : Char Input-port (-> Location) -> String
;; discards the stop character, too
(define (read-until char in pos)
(list->string
(let read-more ()
(let ([c (non-eof read-char in pos)])
(cond
[(eq? c char) null]
[else (cons c (read-more))])))))
;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char
(define (non-eof f in pos)
(let ([c (f in)])
(cond
[(eof-object? c) (lex-error in pos "unexpected eof")]
[else c])))
;; gen-read-until-string : String -> Input-port (-> Location) -> 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 pos)
(list->string
(let/ec out
(let loop ([matched 0] [out out])
(let* ([c (non-eof read-char in pos)]
[matched (fall-back matched c)])
(cond
[(= 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.
(define lex-comment-contents (gen-read-until-string "--"))
(define lex-pi-data (gen-read-until-string "?>"))
(define lex-cdata-contents (gen-read-until-string "]]>"))
;; positionify : Input-port -> Input-port (-> Location)
; This function predates port-count-lines! and port-next-location.
; Otherwise I would have used those directly at the call sites.
(define (positionify in)
(port-count-lines! in)
(values
in
(lambda ()
(let-values ([(line column offset) (port-next-location in)])
(make-location line column offset)))))
;; locs : (listof (list number number))
(define-struct (exn:xml exn:fail:read) ())
;; lex-error : Input-port String (-> Location) TST* -> alpha
;; raises a lexer error, using exn:xml
(define (lex-error in pos str . rest)
(let* ([the-pos (pos)]
[offset (location-offset the-pos)])
(raise
(make-exn:xml
(format "read-xml: lex-error: at position ~a: ~a"
(format-source the-pos)
(apply format str rest))
(current-continuation-marks)
(list
(make-srcloc (object-name in) #f #f offset 1))))))
;; parse-error : (listof srcloc) (listof TST) *-> alpha
;; raises a parsing error, using exn:xml
(define (parse-error src fmt . args)
(raise (make-exn:xml (string-append "read-xml: parse-error: "
(apply format fmt args))
(current-continuation-marks)
src)))
;; format-source : Location -> string
;; to format the source location for an error message
(define (format-source loc)
(if (location? loc)
(format "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc))
(format "~a" loc))))
(when (and (char? c)
(char-whitespace? c))
(read-char in)
(loop)))))
;; lex-pcdata : Input-port (-> Location) -> Pcdata
;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec
(define (lex-pcdata in pos)
(let ([start (pos)]
[data (let loop ()
(let ([next (peek-char-or-special in)])
(cond
[(or (eof-object? next)
(not (char? next))
(eq? next #\&)
(eq? next #\<))
null]
[(and (char-whitespace? next) (collapse-whitespace))
(skip-space in)
(cons #\space (loop))]
[else (cons (read-char in) (loop))])))])
(make-pcdata start
(pos)
(list->string data))))
;; lex-name : Input-port (-> Location) -> Symbol
(define (lex-name in pos)
(let ([c (non-eof read-char-or-special in pos)])
(unless (name-start? c)
(lex-error in pos "expected name, received ~e" c))
(string->symbol
(list->string
(cons c (let lex-rest ()
(let ([c (non-eof peek-char-or-special in pos)])
(cond
[(eq? c 'special)
(lex-error in pos "names cannot contain non-text values")]
[(name-char? c)
(cons (read-char in) (lex-rest))]
[else null]))))))))
;; skip-dtd : Input-port (-> Location) -> Void
(define (skip-dtd in pos)
(let skip ()
(case (non-eof read-char in pos)
[(#\') (read-until #\' in pos) (skip)]
[(#\") (read-until #\" in pos) (skip)]
[(#\<)
(case (non-eof read-char in pos)
[(#\!) (case (non-eof read-char in pos)
[(#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip)]
[else (skip) (skip)])]
[(#\?) (lex-pi-data in pos) (skip)]
[else (skip) (skip)])]
[(#\>) (void)]
[else (skip)])))
;; name-start? : Char -> Bool
(define (name-start? ch)
(and (char? ch)
(or (char-alphabetic? ch)
(eq? ch #\_)
(eq? ch #\:))))
;; name-char? : Char -> Bool
(define (name-char? ch)
(and (char? ch)
(or (name-start? ch)
(char-numeric? ch)
(eq? ch #\.)
(eq? ch #\-))))
;; read-until : Char Input-port (-> Location) -> String
;; discards the stop character, too
(define (read-until char in pos)
(list->string
(let read-more ()
(let ([c (non-eof read-char in pos)])
(cond
[(eq? c char) null]
[else (cons c (read-more))])))))
;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char
(define (non-eof f in pos)
(let ([c (f in)])
(cond
[(eof-object? c) (lex-error in pos "unexpected eof")]
[else c])))
;; gen-read-until-string : String -> Input-port (-> Location) -> 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 pos)
(list->string
(let/ec out
(let loop ([matched 0] [out out])
(let* ([c (non-eof read-char in pos)]
[matched (fall-back matched c)])
(cond
[(= 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.
(define lex-comment-contents (gen-read-until-string "--"))
(define lex-pi-data (gen-read-until-string "?>"))
(define lex-cdata-contents (gen-read-until-string "]]>"))
;; positionify : Input-port -> Input-port (-> Location)
; This function predates port-count-lines! and port-next-location.
; Otherwise I would have used those directly at the call sites.
(define (positionify in)
(port-count-lines! in)
(values
in
(lambda ()
(let-values ([(line column offset) (port-next-location in)])
(make-location line column offset)))))
;; locs : (listof (list number number))
(define-struct (exn:xml exn:fail:read) ())
;; lex-error : Input-port String (-> Location) TST* -> alpha
;; raises a lexer error, using exn:xml
(define (lex-error in pos str . rest)
(let* ([the-pos (pos)]
[offset (location-offset the-pos)])
(raise
(make-exn:xml
(format "read-xml: lex-error: at position ~a: ~a"
(format-source the-pos)
(apply format str rest))
(current-continuation-marks)
(list
(make-srcloc (object-name in) #f #f offset 1))))))
;; parse-error : (listof srcloc) (listof TST) *-> alpha
;; raises a parsing error, using exn:xml
(define (parse-error src fmt . args)
(raise (make-exn:xml (string-append "read-xml: parse-error: "
(apply format fmt args))
(current-continuation-marks)
src)))
;; format-source : Location -> string
;; to format the source location for an error message
(define (format-source loc)
(if (location? loc)
(format "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc))
(format "~a" loc)))

89
collects/xml/private/sig.ss
View File

@ -1,89 +0,0 @@
#lang scheme
(define-signature xml-structs^
((struct/ctc location ([line exact-nonnegative-integer?]
[char exact-nonnegative-integer?]
[offset exact-nonnegative-integer?]))
(struct/ctc source ([start (or/c location? symbol?)]
[stop (or/c location? symbol?)]))
(struct/ctc comment ([text string?]))
(struct pcdata (string)) ; XXX needs parent
(struct cdata (string)) ; XXX needs parent
(struct/ctc document-type ([name symbol?]
#;[external external-dtd?]
; XXX results in this error
; ->: expected contract or a value that can be coerced into one, got #<undefined>
; I presume that there is a letrec somewhere
[external any/c]
[inlined false/c]))
(struct/ctc document (#;[prolog prolog?] ; XXX same as above
[prolog any/c]
#;[element element?]
[element any/c]
#;[misc (listof (or/c comment? pi?))]
[misc (listof any/c)]))
(struct/ctc prolog (#;[misc (listof (or/c comment? pi?))] ; XXX same as above
[misc (listof any/c)]
#;[dtd document-type?]
[dtd any/c]
#;[misc2 (listof (or/c comment? pi?))]
[misc2 (listof any/c)]))
(struct/ctc external-dtd ([system string?]))
(struct external-dtd/public (public)) ; XXX needs parent
(struct external-dtd/system ()) ; XXX needs parent
(struct element (name attributes content)) ; XXX needs parent
(struct attribute (name value)) ; XXX needs parent
(struct pi (target-name instruction)) ; XXX needs parent
(struct entity (text)) ; XXX needs parent
(contracted
[content? (any/c . -> . boolean?)])))
(define-signature writer^
((contracted
[write-xml ((any/c) (output-port?) . ->* . void?)]
[display-xml ((any/c) (output-port?) . ->* . void?)]
[write-xml/content ((any/c) (output-port?) . ->* . void?)]
[display-xml/content ((any/c) (output-port?) . ->* . void?)])
; XXX I can't contract the above (well), because they refer to structs from xml-structs^
(contracted
[empty-tag-shorthand (parameter/c (or/c (symbols 'always 'never) (listof symbol?)))]
[html-empty-tags (listof symbol?)])))
(define-signature reader^
((contracted
[read-xml (() (input-port?) . ->* . any/c)]
[read-xml/element (() (input-port?) . ->* . any/c)]
[read-comments (parameter/c boolean?)]
[collapse-whitespace (parameter/c boolean?)])
; XXX can't contract the above (well) because they refer to structs
; XXX can't contract exn:xml beacuse of parent
(struct exn:xml ())))
(define-signature xexpr^
((struct exn:invalid-xexpr (code)) ; XXX needs parent
(contracted
[xexpr/c contract?]
[xexpr? (any/c . -> . boolean?)]
[xexpr->string (xexpr/c . -> . string?)]
[xml->xexpr (any/c . -> . xexpr/c)] ; XXX bad because of struct
[xexpr->xml (xexpr/c . -> . any/c)] ; XXX bad because of struct
[xexpr-drop-empty-attributes (parameter/c boolean?)]
[permissive? (parameter/c boolean?)]
[validate-xexpr (any/c . -> . (one-of/c #t))]
[correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)]
[xexpr-attribute? (any/c . -> . boolean?)]
[listof? ((any/c . -> . boolean?) any/c . -> . boolean?)]
[attribute->srep (any/c . -> . xexpr-attribute?)] ; XXX bad because of struct
[bcompose ((any/c any/c . -> . any/c) (any/c . -> . any/c) . -> . (any/c any/c . -> . any/c))]
[assoc-sort ((listof (list/c symbol? string?)) . -> . (listof (list/c symbol? string?)))])))
(define-signature space^
((contracted
; XXX bad because of struct
[eliminate-whitespace ((listof symbol?) (boolean? . -> . boolean?) . -> . (any/c . -> . any/c))])))
(provide xml-structs^
writer^
reader^
xexpr^
space^)

58
collects/xml/private/space.ss
View File

@ -1,34 +1,30 @@
#lang scheme
(require "sig.ss")
(require "structures.ss")
(provide/contract
[eliminate-whitespace ((listof symbol?) (boolean? . -> . boolean?) . -> . (element? . -> . element?))])
(provide space@)
;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
(define (eliminate-whitespace special eliminate-special?)
(letrec ([blank-it
(lambda (el)
(let ([name (element-name el)]
[content (map (lambda (x)
(if (element? x) (blank-it x) x))
(element-content el))])
(make-element
(source-start el)
(source-stop el)
name
(element-attributes el)
(cond
[(eliminate-special? (and (memq (element-name el) special) #t))
(filter (lambda (s)
(not (and (pcdata? s)
(or (all-blank (pcdata-string s))
(error 'eliminate-blanks "Element <~a> is not allowed to contain text ~e" name (pcdata-string s))))))
content)]
[else content]))))])
blank-it))
(define-unit space@
(import xml-structs^)
(export space^)
;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
(define (eliminate-whitespace special eliminate-special?)
(letrec ([blank-it
(lambda (el)
(let ([name (element-name el)]
[content (map (lambda (x)
(if (element? x) (blank-it x) x))
(element-content el))])
(make-element
(source-start el)
(source-stop el)
name
(element-attributes el)
(cond
[(eliminate-special? (and (memq (element-name el) special) #t))
(filter (lambda (s)
(not (and (pcdata? s)
(or (all-blank (pcdata-string s))
(error 'eliminate-blanks "Element <~a> is not allowed to contain text ~e" name (pcdata-string s))))))
content)]
[else content]))))])
blank-it))
;; all-blank : String -> Bool
(define (all-blank s) (andmap char-whitespace? (string->list s))))
;; all-blank : String -> Bool
(define (all-blank s) (andmap char-whitespace? (string->list s)))

191
collects/xml/private/structures.ss
View File

@ -1,71 +1,126 @@
#lang scheme
(require "sig.ss")
(provide xml-structs@)
; Location = (make-location Nat Nat Nat) | Symbol
(define-struct location (line char offset))
(define-unit xml-structs@
(import)
(export xml-structs^)
; Location = (make-location Nat Nat Nat) | Symbol
(define-struct location (line char offset))
; Source = (make-source Location Location)
(define-struct source (start stop))
; Document = (make-document Prolog Element (listof Misc))
(define-struct document (prolog element misc))
; Prolog = (make-prolog (listof Misc) Document-type (listof Misc))
(define-struct prolog (misc dtd misc2))
; Document-type = (make-document-type sym External-dtd #f)
; | #f
(define-struct document-type (name external inlined))
; External-dtd = (make-external-dtd/public str str)
; | (make-external-dtd/system str)
; | #f
(define-struct external-dtd (system))
(define-struct (external-dtd/public external-dtd) (public))
(define-struct (external-dtd/system external-dtd) ())
; Element = (make-element Location Location Symbol (listof Attribute) (listof Content))
(define-struct (element source) (name attributes content))
; Attribute = (make-attribute Location Location Symbol String)
(define-struct (attribute source) (name value))
; Pcdata = (make-pcdata Location Location String)
(define-struct (pcdata source) (string))
; Cdata = (make-cdata Location Location String)
(define-struct (cdata source) (string))
; Content = Pcdata
; | Element
; | Entity
; | Misc
; | Cdata
; Misc = Comment
; | Processing-instruction
; Entity = (make-entity Location Location (U Nat Symbol))
(define-struct (entity source) (text))
; Processing-instruction = (make-pi Location Location String String)
; also represents XMLDecl
(define-struct (pi source) (target-name instruction))
; Comment = (make-comment String)
(define-struct comment (text))
; content? : TST -> Bool
(define (content? x)
(or (pcdata? x)
(element? x)
(entity? x)
(comment? x)
(cdata? x)
(pi? x))))
; Source = (make-source Location Location)
(define-struct source (start stop))
; Document = (make-document Prolog Element (listof Misc))
(define-struct document (prolog element misc))
; Prolog = (make-prolog (listof Misc) Document-type (listof Misc))
(define-struct prolog (misc dtd misc2))
; Document-type = (make-document-type sym External-dtd #f)
; | #f
(define-struct document-type (name external inlined))
; External-dtd = (make-external-dtd/public str str)
; | (make-external-dtd/system str)
; | #f
(define-struct external-dtd (system))
(define-struct (external-dtd/public external-dtd) (public))
(define-struct (external-dtd/system external-dtd) ())
; Element = (make-element Location Location Symbol (listof Attribute) (listof Content))
(define-struct (element source) (name attributes content))
; Attribute = (make-attribute Location Location Symbol String)
(define-struct (attribute source) (name value))
; Pcdata = (make-pcdata Location Location String)
(define-struct (pcdata source) (string))
; Cdata = (make-cdata Location Location String)
(define-struct (cdata source) (string))
; Content = Pcdata
; | Element
; | Entity
; | Misc
; | Cdata
; Misc = Comment
; | Processing-instruction
; Entity = (make-entity Location Location (U Nat Symbol))
(define-struct (entity source) (text))
; Processing-instruction = (make-p-i Location Location String String)
; also represents XMLDecl
(define-struct (p-i source) (target-name instruction))
; Comment = (make-comment String)
(define-struct comment (text))
; permissive? : parameter bool
(define permissive? (make-parameter #f))
(define permissive/c
(make-proj-contract 'permissive/c
(lambda (pos neg src-info name)
(lambda (v)
(if (permissive?)
v
(raise-contract-error
v src-info pos name "not in permissive mode"))))
(lambda (v)
(permissive?))))
; content? : TST -> Bool
(define content/c
(or/c pcdata? element? entity? comment? cdata? p-i? permissive/c))
(define misc/c
(or/c comment? p-i?))
(define location/c
(or/c location? symbol? false/c))
(provide/contract
(struct location ([line exact-nonnegative-integer?]
[char exact-nonnegative-integer?]
[offset exact-nonnegative-integer?]))
[location/c contract?]
(struct source ([start location/c]
[stop location/c]))
(struct external-dtd ([system string?]))
(struct (external-dtd/public external-dtd) ([system string?]
[public string?]))
(struct (external-dtd/system external-dtd) ([system string?]))
(struct document-type ([name symbol?]
[external external-dtd?]
[inlined false/c]))
(struct comment ([text string?]))
(struct (p-i source) ([start location/c]
[stop location/c]
[target-name symbol?]
[instruction string?]))
[misc/c contract?]
(struct prolog ([misc (listof misc/c)]
[dtd (or/c document-type? false/c)]
[misc2 (listof misc/c)]))
(struct document ([prolog prolog?]
[element element?]
[misc (listof misc/c)]))
(struct (element source) ([start location/c]
[stop location/c]
[name symbol?]
[attributes (listof attribute?)]
[content (listof content/c)]))
(struct (attribute source) ([start location/c]
[stop location/c]
[name symbol?]
[value string?]))
[permissive? (parameter/c boolean?)]
[permissive/c contract?]
[content/c contract?]
(struct (pcdata source) ([start location/c]
[stop location/c]
[string string?]))
(struct (cdata source) ([start location/c]
[stop location/c]
[string string?]))
(struct (entity source) ([start location/c]
[stop location/c]
[text (or/c symbol? exact-nonnegative-integer?)])))

258
collects/xml/private/syntax.ss
View File

@ -1,212 +1,52 @@
#lang scheme
(require "sig.ss")
(require "structures.ss"
"reader.ss"
"xexpr.ss")
; to make error-raising functions named like structure mutators
(define-syntax (struct! stx)
(syntax-case stx ()
[(struct-src name (field ...))
(with-syntax ([struct:name (datum->syntax
(syntax name)
(string->symbol (string-append "struct:" (symbol->string (syntax->datum (syntax name))))))]
[(setter-name ...)
(let ([struct-name
(symbol->string (syntax->datum (syntax name)))])
(map (lambda (field-name)
(datum->syntax
field-name
(string->symbol
(string-append
"set-"
struct-name
"-"
(symbol->string (syntax->datum field-name))
"!"))))
(syntax->list (syntax (field ...)))))])
(syntax
(begin
(define struct:name void)
(define (setter-name s v)
(error (quote setter-name) "cannot mutate XML syntax"))
...)))]))
(provide/contract
; XXX these should both actually return syntax? that is also xexpr/c
[syntax:read-xml (() (input-port?) . ->* . syntax?)]
[syntax:read-xml/element (() (input-port?) . ->* . syntax?)])
(provide syntax-structs@)
(define-unit syntax-structs@
(import)
(export xml-structs^)
; The locations from the two sets of structures shouldn't mingle, so I'm
; re-defining the location structure. Maybe this is not a good idea, but I
; think it's okay.
(define-struct location (line char offset))
(define-struct source (start stop))
; make-document : prolog element ? -> document
(define (make-document p e ?) e)
; make-prolog : (listof Misc) Document-type (listof Misc) -> prolog
(define (make-prolog misc dtd misc2) #f)
; make-element : src src sym (listof attribute) (listof content) -> element
(define (make-element from to name attrs content)
(wrap (list* name attrs content) from to))
; make-pcdata : src src str -> pcdata
(define (make-pcdata from to x)
(wrap x from to))
; make-cdata : src src str -> cdata
(define (make-cdata from to x)
(wrap x from to))
; make-entity : src src (U sym num) -> entity
(define (make-entity from to entity)
(wrap entity from to))
; make-comment : str -> comment
; There is no syntax object representation for comments
(define (make-comment x) #f)
; make-pi : src src sym str -> pi
; There's not really a syntax object representation for pi's either
(define (make-pi from to name val) #f)
; make-attribute : src src sym str -> attribute
(define (make-attribute from to name val)
(wrap (list name val) from to))
(define (make-document-type . x) #f)
(define (make-external-dtd . x) #f)
(define (make-external-dtd/public . x) #f)
(define (make-external-dtd/system . x) #f)
; wrap : tst src src -> syntax
(define (wrap x from to)
(datum->syntax #f x (position from to)))
; position : src src -> (list #f nat nat nat nat)
(define (position from to)
(let ([start-offset (location-offset from)])
(list #f (location-line from) (location-char from) start-offset
(- (location-offset to) start-offset))))
; : syntax -> syntax
(define (attribute-name a) (car (syntax->list a)))
(define (attribute-value a) (cadr (syntax->list a)))
; : syntax -> syntax
(define (element-name e) (car (syntax->list e)))
(define (element-attributes e) (cadr (syntax->list e)))
(define (element-content e) (cddr (syntax->list e)))
(define (entity-text e) (syntax-e e))
(define (pcdata-string x) (syntax-e x))
(define (cdata-string x) (syntax-e x))
(define (comment-text c)
(error 'comment-text "expected a syntax representation of an XML comment, received ~e" c))
; conflate documents with their root elements
(define (document-element d) d)
; more here - spoof document pieces better?
(define (document-misc d) null)
(define (document-prolog d) null)
(define (document-type-external dtd)
(error 'document-type-external "expected a dtd, given ~e" dtd))
(define (document-type-inlined dtd)
(error 'document-type-inlined "expected a dtd, given ~e" dtd))
(define (document-type-name dtd)
(error 'document-type-name "expected a dtd, given ~e" dtd))
(define (external-dtd-system x)
(error 'external-dtd-system "expected an external dtd, given ~e" x))
(define (external-dtd/public-public x)
(error 'external-dtd/public-public "expected an external dtd, given ~e" x))
(define (pi-instruction x)
(error 'pi-instruction "expected a pi, given ~e" x))
(define (pi-target-name x)
(error 'pi-target-name "expected a pi, given ~e" x))
(define (prolog-dtd x)
(error 'prolog-dtd "expected a prolog, given ~e" x))
(define (prolog-misc x)
(error 'prolog-misc "expected a prolog, given ~e" x))
(define (prolog-misc2 x)
(error 'prolog-misc2 "expected a prolog, given ~e" x))
; : tst -> bool
(define (attribute? a)
(and (syntax? a)
(let ([x (syntax->datum a)])
(and (pair? x) (symbol? (car x))
(pair? (cdr x)) (string? (cadr x))
(null? (cddr x))))))
; : tst -> bool
(define (comment? x) #f)
; : tst -> bool
(define (content? x)
(and (syntax? x)
(or (string? (syntax->datum x))
(element? x))))
; : tst -> bool
(define (element? x)
(and (syntax? x)
(let ([e (syntax-e x)])
(and (pair? e) (symbol? (car e))
(pair? (cdr e)) (list? (cadr e))
(andmap attribute? (cadr e))
(list? (cddr e))
(andmap content? (cddr e))))))
; : tst -> bool
(define document? element?)
; : tst -> bool
(define (document-type? x) #f)
; : tst -> bool
(define (external-dtd/public? x) #f)
(define (external-dtd/system? x) #f)
(define (external-dtd? x) #f)
(define (prolog? x) #f)
(define (pi? x) #f)
; : tst -> bool
(define (pcdata? x)
(and (syntax? x) (string (syntax-e x))))
(define (cdata? x)
(and (syntax? x) (string (syntax-e x))))
; : tst -> bool
(define (entity? x)
(and (syntax? x) (let ([r (syntax-e x)]) (or (symbol? r) (number? r)))))
;(struct! location (line char offset))
(struct! document (prolog element misc))
(struct! comment (text))
(struct! prolog (misc dtd misc2))
(struct! document-type (name external inlined))
(struct! external-dtd (system))
(struct! external-dtd/public (public))
(struct! external-dtd/system ())
(struct! element (name attributes content))
(struct! attribute (name value))
(struct! pi (target-name instruction))
;(struct! source (start stop))
(struct! pcdata (string))
(struct! cdata (string))
(struct! entity (text))
)
(define (syntax:read-xml [in (current-input-port)])
(define the-xml (read-xml in))
(define the-xml-element (document-element the-xml))
(element->xexpr-syntax the-xml-element))
(define (syntax:read-xml/element [in (current-input-port)])
(define the-xml-element (read-xml/element in))
(element->xexpr-syntax the-xml-element))
(define (position from to)
(let ([start-offset (location-offset from)])
(list #f (location-line from) (location-char from) start-offset
(- (location-offset to) start-offset))))
(define (wrap s e)
(datum->syntax #f e (position (source-start s) (source-stop s))))
(define (attribute->syntax a)
(wrap a (list (attribute-name a) (attribute-value a))))
(define (non-dropping-combine atts body)
(list* (map attribute->syntax atts) body))
(define (combine atts body)
(if (xexpr-drop-empty-attributes)
(if (empty? atts)
body
(non-dropping-combine atts body))
(non-dropping-combine atts body)))
(define (element->xexpr-syntax e)
(wrap e
(list* (element-name e)
(combine (element-attributes e)
(map content->xexpr-syntax (element-content e))))))
(define (content->xexpr-syntax x)
(cond
[(element? x) (element->xexpr-syntax x)]
[(pcdata? x) (wrap x (pcdata-string x))]
[(entity? x) (wrap x (entity-text x))]
[else (wrap x x)]))

330
collects/xml/private/writer.ss
View File

@ -1,167 +1,169 @@
#lang scheme
(require "sig.ss")
(require "structures.ss")
(provide writer@)
(provide/contract
[write-xml ((document?) (output-port?) . ->* . void?)]
[display-xml ((document?) (output-port?) . ->* . void?)]
[write-xml/content ((content/c) (output-port?) . ->* . void?)]
[display-xml/content ((content/c) (output-port?) . ->* . void?)]
[empty-tag-shorthand (parameter/c (or/c (symbols 'always 'never) (listof symbol?)))]
[html-empty-tags (listof symbol?)])
(define-unit writer@
(import xml-structs^)
(export writer^)
;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
(define empty-tag-shorthand
(make-parameter 'always
(lambda (x)
(if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x)))
x
(error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~e" x)))))
(define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area))
;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void
(define (gen-write/display-xml/content dent)
(lambda (c [out (current-output-port)]) (write-xml-content c 0 dent out)))
;; indent : Nat Output-port -> Void
(define (indent n out)
(newline out)
(let loop ([n n])
(unless (zero? n)
(display #\space out)
(loop (sub1 n)))))
;; write-xml/content : Content [Output-port] -> Void
(define write-xml/content (gen-write/display-xml/content void))
;; display-xml/content : Content [Output-port] -> Void
(define display-xml/content (gen-write/display-xml/content indent))
;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void
(define (gen-write/display-xml output-content)
(lambda (doc [out (current-output-port)])
(let ([prolog (document-prolog doc)])
(display-outside-misc (prolog-misc prolog) out)
(display-dtd (prolog-dtd prolog) out)
(display-outside-misc (prolog-misc2 prolog) out))
(output-content (document-element doc) out)
(display-outside-misc (document-misc doc) out)))
; display-dtd : document-type oport -> void
(define (display-dtd dtd out)
(when dtd
(fprintf out "<!DOCTYPE ~a" (document-type-name dtd))
(let ([external (document-type-external dtd)])
(cond
[(external-dtd/public? external)
(fprintf out " PUBLIC \"~a\" \"~a\""
(external-dtd/public-public external)
(external-dtd-system external))]
[(external-dtd/system? external)
(fprintf out " SYSTEM \"~a\"" (external-dtd-system external))]
[(not external) (void)]))
(display ">" out)
(newline out)))
;; write-xml : Document [Output-port] -> Void
(define write-xml (gen-write/display-xml write-xml/content))
;; display-xml : Document [Output-port] -> Void
(define display-xml (gen-write/display-xml display-xml/content))
;; display-outside-misc : (listof Misc) Output-port -> Void
(define (display-outside-misc misc out)
(for-each (lambda (x)
((cond
[(comment? x) write-xml-comment]
[(pi? x) write-xml-pi]) x 0 void out)
(newline out))
misc))
;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-content el over dent out)
((cond
[(element? el) write-xml-element]
[(pcdata? el) write-xml-pcdata]
[(cdata? el) write-xml-cdata]
[(entity? el) write-xml-entity]
[(comment? el) write-xml-comment]
[(pi? el) write-xml-pi]
[else (error 'write-xml-content "received ~e" el)])
el over dent out))
;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-element el over dent out)
(let* ([name (element-name el)]
[start (lambda (str)
(write-xml-base str over dent out)
(display name out))]
[content (element-content el)])
(start "<")
(for ([att (in-list (element-attributes el))])
(fprintf out " ~a=\"~a\"" (attribute-name att)
(escape (attribute-value att) escape-attribute-table)))
(if (and (null? content)
(let ([short (empty-tag-shorthand)])
(case short
[(always) #t]
[(never) #f]
[else (memq (lowercase-symbol name) short)])))
(display " />" out)
(begin
(display ">" out)
(for ([c (in-list content)])
(write-xml-content c (incr over) dent out))
(start "</")
(display ">" out)))))
; : sym -> sym
(define lowercases (make-weak-hash))
(define (lowercase-symbol x)
(or (hash-ref lowercases x #f)
(let ([s (symbol->string x)])
(let ([s (string->symbol (string-downcase s))])
(hash-set! lowercases x s)
s))))
;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-base el over dent out)
(dent over out)
(display el out))
;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-pcdata str over dent out)
(write-xml-base (escape (pcdata-string str) escape-table) over dent out))
;; write-xml-cdata : Cdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-cdata cdata over dent out)
;; XXX: Different kind of quote is needed, for assume the user includes the <![CDATA[...]]> with proper quoting
(write-xml-base (format "~a" (cdata-string cdata)) over dent out))
;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-pi pi over dent out)
(write-xml-base (format "<?~a ~a?>" (pi-target-name pi) (pi-instruction pi)) over dent out))
;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-comment comment over dent out)
(write-xml-base (format "<!--~a-->" (comment-text comment)) over dent out))
;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void
(define (write-xml-entity entity over dent out)
(let ([n (entity-text entity)])
(fprintf out (if (number? n) "&#~a;" "&~a;") n)))
(define escape-table #rx"[<>&]")
(define escape-attribute-table #rx"[<>&\"]")
(define (replace-escaped s)
(case (string-ref s 0)
[(#\<) "&lt;"]
[(#\>) "&gt;"]
[(#\&) "&amp;"]
[(#\") "&quot;"]))
;; escape : String -> String
(define (escape x table)
(regexp-replace* table x replace-escaped))
;; incr : Nat -> Nat
(define (incr n) (+ n 2)))
;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
(define empty-tag-shorthand
(make-parameter 'always
(lambda (x)
(if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x)))
x
(error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~e" x)))))
(define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area))
;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void
(define (gen-write/display-xml/content dent)
(lambda (c [out (current-output-port)]) (write-xml-content c 0 dent out)))
;; indent : Nat Output-port -> Void
(define (indent n out)
(newline out)
(let loop ([n n])
(unless (zero? n)
(display #\space out)
(loop (sub1 n)))))
;; write-xml/content : Content [Output-port] -> Void
(define write-xml/content (gen-write/display-xml/content void))
;; display-xml/content : Content [Output-port] -> Void
(define display-xml/content (gen-write/display-xml/content indent))
;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void
(define (gen-write/display-xml output-content)
(lambda (doc [out (current-output-port)])
(let ([prolog (document-prolog doc)])
(display-outside-misc (prolog-misc prolog) out)
(display-dtd (prolog-dtd prolog) out)
(display-outside-misc (prolog-misc2 prolog) out))
(output-content (document-element doc) out)
(display-outside-misc (document-misc doc) out)))
; display-dtd : document-type oport -> void
(define (display-dtd dtd out)
(when dtd
(fprintf out "<!DOCTYPE ~a" (document-type-name dtd))
(let ([external (document-type-external dtd)])
(cond
[(external-dtd/public? external)
(fprintf out " PUBLIC \"~a\" \"~a\""
(external-dtd/public-public external)
(external-dtd-system external))]
[(external-dtd/system? external)
(fprintf out " SYSTEM \"~a\"" (external-dtd-system external))]
[(not external) (void)]))
(display ">" out)
(newline out)))
;; write-xml : Document [Output-port] -> Void
(define write-xml (gen-write/display-xml write-xml/content))
;; display-xml : Document [Output-port] -> Void
(define display-xml (gen-write/display-xml display-xml/content))
;; display-outside-misc : (listof Misc) Output-port -> Void
(define (display-outside-misc misc out)
(for-each (lambda (x)
((cond
[(comment? x) write-xml-comment]
[(p-i? x) write-xml-p-i]) x 0 void out)
(newline out))
misc))
;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-content el over dent out)
((cond
[(element? el) write-xml-element]
[(pcdata? el) write-xml-pcdata]
[(cdata? el) write-xml-cdata]
[(entity? el) write-xml-entity]
[(comment? el) write-xml-comment]
[(p-i? el) write-xml-p-i]
[else (error 'write-xml-content "received ~e" el)])
el over dent out))
;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-element el over dent out)
(let* ([name (element-name el)]
[start (lambda (str)
(write-xml-base str over dent out)
(display name out))]
[content (element-content el)])
(start "<")
(for ([att (in-list (element-attributes el))])
(fprintf out " ~a=\"~a\"" (attribute-name att)
(escape (attribute-value att) escape-attribute-table)))
(if (and (null? content)
(let ([short (empty-tag-shorthand)])
(case short
[(always) #t]
[(never) #f]
[else (memq (lowercase-symbol name) short)])))
(display " />" out)
(begin
(display ">" out)
(for ([c (in-list content)])
(write-xml-content c (incr over) dent out))
(start "</")
(display ">" out)))))
; : sym -> sym
(define lowercases (make-weak-hash))
(define (lowercase-symbol x)
(or (hash-ref lowercases x #f)
(let ([s (symbol->string x)])
(let ([s (string->symbol (string-downcase s))])
(hash-set! lowercases x s)
s))))
;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-base el over dent out)
(dent over out)
(display el out))
;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-pcdata str over dent out)
(write-xml-base (escape (pcdata-string str) escape-table) over dent out))
;; write-xml-cdata : Cdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-cdata cdata over dent out)
;; XXX: Different kind of quote is needed, for assume the user includes the <![CDATA[...]]> with proper quoting
(write-xml-base (format "~a" (cdata-string cdata)) over dent out))
;; write-xml-p-i : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-p-i p-i over dent out)
(write-xml-base (format "<?~a ~a?>" (p-i-target-name p-i) (p-i-instruction p-i)) over dent out))
;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-comment comment over dent out)
(write-xml-base (format "<!--~a-->" (comment-text comment)) over dent out))
;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void
(define (write-xml-entity entity over dent out)
(let ([n (entity-text entity)])
(fprintf out (if (number? n) "&#~a;" "&~a;") n)))
(define escape-table #rx"[<>&]")
(define escape-attribute-table #rx"[<>&\"]")
(define (replace-escaped s)
(case (string-ref s 0)
[(#\<) "&lt;"]
[(#\>) "&gt;"]
[(#\&) "&amp;"]
[(#\") "&quot;"]))
;; escape : String -> String
(define (escape x table)
(regexp-replace* table x replace-escaped))
;; incr : Nat -> Nat
(define (incr n) (+ n 2))

461
collects/xml/private/xexpr.ss
View File

@ -1,228 +1,243 @@
#lang scheme
(require scheme/pretty)
(require "sig.ss")
(require scheme/pretty
"structures.ss"
"writer.ss")
(provide xexpr@)
;; Xexpr ::= String
;; | (list* Symbol (listof Attribute-srep) (listof Xexpr))
;; | (cons Symbol (listof Xexpr))
;; | Symbol
;; | Nat
;; | Comment
;; | Processing-instruction
;; | Cdata
;; Attribute-srep ::= (list Symbol String)
(define-unit xexpr@
(import xml-structs^ writer^)
(export xexpr^)
;; Xexpr ::= String
;; | (list* Symbol (listof Attribute-srep) (listof Xexpr))
;; | (cons Symbol (listof Xexpr))
;; | Symbol
;; | Nat
;; | Comment
;; | Processing-instruction
;; | Cdata
;; Attribute-srep ::= (list Symbol String)
;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a))
(define (assoc-sort to-sort)
(sort to-sort (bcompose string<? (compose symbol->string car))))
(define xexpr-drop-empty-attributes (make-parameter #f))
(define xexpr/c
(make-proj-contract
'xexpr?
(lambda (pos neg src-info name)
(lambda (val)
(with-handlers ([exn:invalid-xexpr?
(lambda (exn)
(raise-contract-error
val
src-info
pos
name
"Not an Xexpr. ~a~n~nContext:~n~a"
(exn-message exn)
(pretty-format val)))])
(validate-xexpr val)
val)))
(lambda (v) #t)))
(define (xexpr? x)
(correct-xexpr? x (lambda () #t) (lambda (exn) #f)))
(define (validate-xexpr x)
(correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn))))
;; ;; ;; ;; ;; ;; ;
;; ; xexpr? helpers
(define-struct (exn:invalid-xexpr exn:fail) (code))
;; correct-xexpr? : any (-> a) (exn -> a) -> a
(define (correct-xexpr? x true false)
(cond
((string? x) (true))
((symbol? x) (true))
((exact-nonnegative-integer? x) (true))
((comment? x) (true))
((pi? x) (true))
((cdata? x) (true))
((pcdata? x) (true))
((list? x)
(or (null? x)
(if (symbol? (car x))
(if (has-attribute? x)
(and (attribute-pairs? (cadr x) true false)
(andmap (lambda (part)
(correct-xexpr? part true false))
(cddr x))
(true))
(andmap (lambda (part)
(correct-xexpr? part true false))
(cdr x)))
(false (make-exn:invalid-xexpr
(format
"Expected a symbol as the element name, given ~s"
(car x))
(current-continuation-marks)
x)))))
[(permissive?) (true)]
(else (false
;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a))
(define (assoc-sort to-sort)
(sort to-sort (bcompose string<? (compose symbol->string car))))
(define xexpr-drop-empty-attributes (make-parameter #f))
(define xexpr-datum/c
(or/c string? symbol? exact-nonnegative-integer?
comment? p-i? cdata? pcdata?))
#;(define xexpr/c
(flat-rec-contract xexpr
xexpr-datum/c
(cons/c symbol?
(or/c (cons/c (listof (list/c symbol? string?)) (listof xexpr))
(listof xexpr)))))
(define xexpr/c
(make-proj-contract
'xexpr?
(lambda (pos neg src-info name)
(lambda (val)
(with-handlers ([exn:invalid-xexpr?
(lambda (exn)
(raise-contract-error
val
src-info
pos
name
"Not an Xexpr. ~a~n~nContext:~n~a"
(exn-message exn)
(pretty-format val)))])
(validate-xexpr val)
val)))
(lambda (v) #t)))
(define (xexpr? x)
(correct-xexpr? x (lambda () #t) (lambda (exn) #f)))
(define (validate-xexpr x)
(correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn))))
;; ;; ;; ;; ;; ;; ;
;; ; xexpr? helpers
(define-struct (exn:invalid-xexpr exn:fail) (code))
;; correct-xexpr? : any (-> a) (exn -> a) -> a
(define (correct-xexpr? x true false)
(cond
((string? x) (true))
((symbol? x) (true))
((exact-nonnegative-integer? x) (true))
((comment? x) (true))
((p-i? x) (true))
((cdata? x) (true))
((pcdata? x) (true))
((list? x)
(or (null? x)
(if (symbol? (car x))
(if (has-attribute? x)
(and (attribute-pairs? (cadr x) true false)
(andmap (lambda (part)
(correct-xexpr? part true false))
(cddr x))
(true))
(andmap (lambda (part)
(correct-xexpr? part true false))
(cdr x)))
(false (make-exn:invalid-xexpr
(format
"Expected a symbol as the element name, given ~s"
(car x))
(current-continuation-marks)
x)))))
[(permissive?) (true)]
(else (false
(make-exn:invalid-xexpr
(format (string-append
"Expected a string, symbol, number, comment, "
"processing instruction, or list, given ~s")
x)
(current-continuation-marks)
x)))))
;; has-attribute? : List -> Boolean
;; True if the Xexpr provided has an attribute list.
(define (has-attribute? x)
(and (> (length x) 1)
(list? (cadr x))
(andmap (lambda (attr)
(pair? attr))
(cadr x))))
;; attribute-pairs? : List (-> a) (exn -> a) -> a
;; True if the list is a list of pairs.
(define (attribute-pairs? attrs true false)
(if (null? attrs)
(true)
(let ((attr (car attrs)))
(if (pair? attr)
(and (attribute-symbol-string? attr true false)
(attribute-pairs? (cdr attrs) true false )
(true))
(false
(make-exn:invalid-xexpr
(format (string-append
"Expected a string, symbol, number, comment, "
"processing instruction, or list, given ~s")
x)
(format "Expected a pair, given ~a" attr)
(current-continuation-marks)
x)))))
;; has-attribute? : List -> Boolean
;; True if the Xexpr provided has an attribute list.
(define (has-attribute? x)
(and (> (length x) 1)
(list? (cadr x))
(andmap (lambda (attr)
(pair? attr))
(cadr x))))
;; attribute-pairs? : List (-> a) (exn -> a) -> a
;; True if the list is a list of pairs.
(define (attribute-pairs? attrs true false)
(if (null? attrs)
(true)
(let ((attr (car attrs)))
(if (pair? attr)
(and (attribute-symbol-string? attr true false)
(attribute-pairs? (cdr attrs) true false )
(true))
(false
(make-exn:invalid-xexpr
(format "Expected a pair, given ~a" attr)
(current-continuation-marks)
attr))))))
;; attribute-symbol-string? : List (-> a) (exn -> a) -> a
;; True if the list is a list of String,Symbol pairs.
(define (attribute-symbol-string? attr true false)
(if (symbol? (car attr))
(if (string? (cadr attr))
(true)
(false (make-exn:invalid-xexpr
(format "Expected a string, given ~a" (cadr attr))
(current-continuation-marks)
(cadr attr))))
(false (make-exn:invalid-xexpr
(format "Expected a symbol, given ~a" (car attr))
(current-continuation-marks)
(cadr attr)))))
;; ; end xexpr? helpers
;; ;; ;; ;; ;; ;; ;; ;;
; : (a -> bool) tst -> bool
; To check if l is a (listof p?)
; Don't use (and (list? l) (andmap p? l)) because l may be improper.
(define (listof? p? l)
(let listof-p? ([l l])
(or (null? l)
(and (cons? l) (p? (car l)) (listof-p? (cdr l))))))
; : tst -> bool
(define (xexpr-attribute? b)
(and (pair? b)
(symbol? (car b))
(pair? (cdr b))
(string? (cadr b))
(null? (cddr b))))
; permissive? : parameter bool
(define permissive? (make-parameter #f))
;; xml->xexpr : Content -> Xexpr
(define (xml->xexpr x)
(let* ([non-dropping-combine
(lambda (atts body)
(cons (assoc-sort (map attribute->srep atts))
body))]
[combine (if (xexpr-drop-empty-attributes)
(lambda (atts body)
(if (null? atts)
body
(non-dropping-combine atts body)))
non-dropping-combine)])
(let loop ([x x])
(cond
[(element? x)
(let ([body (map loop (element-content x))]
[atts (element-attributes x)])
(cons (element-name x) (combine atts body)))]
[(pcdata? x) (pcdata-string x)]
[(entity? x) (entity-text x)]
[(or (comment? x) (pi? x) (cdata? x)) x]
[(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)]
[(permissive?) x]
[else (error 'xml->xexpr "Expected content, given ~e" x)]))))
;; attribute->srep : Attribute -> Attribute-srep
(define (attribute->srep a)
(list (attribute-name a) (attribute-value a)))
;; srep->attribute : Attribute-srep -> Attribute
(define (srep->attribute a)
(unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a)))
(error 'srep->attribute "expected (list Symbol String) given ~e" a))
(make-attribute 'scheme 'scheme (car a) (cadr a)))
;; xexpr->xml : Xexpr -> Content
;; The contract is enforced.
(define (xexpr->xml x)
(cond
[(pair? x)
(let ([f (lambda (atts body)
(unless (list? body)
(error 'xexpr->xml
"expected a list of xexprs for the body in ~e"
x))
(make-element 'scheme 'scheme (car x)
atts
(map xexpr->xml body)))])
(if (and (pair? (cdr x))
(or (null? (cadr x))
(and (pair? (cadr x)) (pair? (caadr x)))))
(f (map srep->attribute (cadr x)) (cddr x))
(f null (cdr x))))]
[(string? x) (make-pcdata 'scheme 'scheme x)]
[(or (symbol? x) (exact-nonnegative-integer? x))
(make-entity 'scheme 'scheme x)]
[(or (comment? x) (pi? x) (cdata? x) (pcdata? x)) x]
[else ;(error 'xexpr->xml "malformed xexpr ~e" x)
x]))
;; xexpr->string : Xexpression -> String
(define (xexpr->string xexpr)
(let ([port (open-output-string)])
(write-xml/content (xexpr->xml xexpr) port)
(get-output-string port)))
;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
(define (bcompose f g)
(lambda (x y) (f (g x) (g y)))))
attr))))))
;; attribute-symbol-string? : List (-> a) (exn -> a) -> a
;; True if the list is a list of String,Symbol pairs.
(define (attribute-symbol-string? attr true false)
(if (symbol? (car attr))
(if (string? (cadr attr))
(true)
(false (make-exn:invalid-xexpr
(format "Expected a string, given ~a" (cadr attr))
(current-continuation-marks)
(cadr attr))))
(false (make-exn:invalid-xexpr
(format "Expected a symbol, given ~a" (car attr))
(current-continuation-marks)
(cadr attr)))))
;; ; end xexpr? helpers
;; ;; ;; ;; ;; ;; ;; ;;
; : (a -> bool) tst -> bool
; To check if l is a (listof p?)
; Don't use (and (list? l) (andmap p? l)) because l may be improper.
(define (listof? p? l)
(let listof-p? ([l l])
(or (null? l)
(and (cons? l) (p? (car l)) (listof-p? (cdr l))))))
; : tst -> bool
(define (xexpr-attribute? b)
(and (pair? b)
(symbol? (car b))
(pair? (cdr b))
(string? (cadr b))
(null? (cddr b))))
;; xml->xexpr : Content -> Xexpr
(define (xml->xexpr x)
(let* ([non-dropping-combine
(lambda (atts body)
(cons (assoc-sort (map attribute->srep atts))
body))]
[combine (if (xexpr-drop-empty-attributes)
(lambda (atts body)
(if (null? atts)
body
(non-dropping-combine atts body)))
non-dropping-combine)])
(let loop ([x x])
(cond
[(element? x)
(let ([body (map loop (element-content x))]
[atts (element-attributes x)])
(cons (element-name x) (combine atts body)))]
[(pcdata? x) (pcdata-string x)]
[(entity? x) (entity-text x)]
[(or (comment? x) (p-i? x) (cdata? x)) x]
[(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)]
[(permissive?) x]
[else (error 'xml->xexpr "Expected content, given ~e" x)]))))
;; attribute->srep : Attribute -> Attribute-srep
(define (attribute->srep a)
(list (attribute-name a) (attribute-value a)))
;; srep->attribute : Attribute-srep -> Attribute
(define (srep->attribute a)
(unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a)))
(error 'srep->attribute "expected (list Symbol String) given ~e" a))
(make-attribute 'scheme 'scheme (car a) (cadr a)))
;; xexpr->xml : Xexpr -> Content
;; The contract is enforced.
(define (xexpr->xml x)
(cond
[(pair? x)
(let ([f (lambda (atts body)
(unless (list? body)
(error 'xexpr->xml
"expected a list of xexprs for the body in ~e"
x))
(make-element 'scheme 'scheme (car x)
atts
(map xexpr->xml body)))])
(if (and (pair? (cdr x))
(or (null? (cadr x))
(and (pair? (cadr x)) (pair? (caadr x)))))
(f (map srep->attribute (cadr x)) (cddr x))
(f null (cdr x))))]
[(string? x) (make-pcdata 'scheme 'scheme x)]
[(or (symbol? x) (exact-nonnegative-integer? x))
(make-entity 'scheme 'scheme x)]
[(or (comment? x) (p-i? x) (cdata? x) (pcdata? x)) x]
[else ;(error 'xexpr->xml "malformed xexpr ~e" x)
x]))
;; xexpr->string : Xexpression -> String
(define (xexpr->string xexpr)
(let ([port (open-output-string)])
(write-xml/content (xexpr->xml xexpr) port)
(get-output-string port)))
;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
(define (bcompose f g)
(lambda (x y) (f (g x) (g y))))
(provide/contract
[exn:invalid-xexpr? (any/c . -> . boolean?)]
[exn:invalid-xexpr-code (exn:invalid-xexpr? . -> . any/c)]
[xexpr/c contract?]
[xexpr? (any/c . -> . boolean?)]
[xexpr->string (xexpr/c . -> . string?)]
[xml->xexpr (content/c . -> . xexpr/c)]
[xexpr->xml (xexpr/c . -> . content/c)]
[xexpr-drop-empty-attributes (parameter/c boolean?)]
[validate-xexpr (any/c . -> . (one-of/c #t))]
[correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)])

19
collects/xml/xml-sig.ss
View File

@ -1,19 +0,0 @@
#lang scheme
(require "private/sig.ss")
(define-signature xml-syntax^
((contracted
; XXX these should both actually return syntax? that is also xexpr/c
[syntax:read-xml (() (input-port?) . ->* . syntax?)]
[syntax:read-xml/element (() (input-port?) . ->* . syntax?)])))
(define-signature xml^
((open xml-structs^)
(open reader^)
(open writer^)
(open xexpr^)
(open space^)
(open xml-syntax^)))
(provide xml^
xml-syntax^)

74
collects/xml/xml-unit.ss
View File

@ -1,74 +0,0 @@
#lang scheme
(require "xml-sig.ss"
"private/sig.ss"
"private/structures.ss"
"private/reader.ss"
"private/writer.ss"
"private/xexpr.ss"
"private/space.ss"
"private/syntax.ss")
(provide xml@)
(define-unit reader->xml-syntax@
(import reader^)
(export xml-syntax^)
(define syntax:read-xml read-xml)
(define syntax:read-xml/element read-xml/element))
(define-compound-unit/infer xml-syntax@
(import)
(export xml-syntax^)
(link syntax-structs@ reader@ reader->xml-syntax@))
(define-unit native-xml-syntax@
(import xml-structs^ reader^ xexpr^)
(export xml-syntax^)
(define (syntax:read-xml [in (current-input-port)])
(define the-xml (read-xml in))
(define the-xml-element (document-element the-xml))
(element->xexpr-syntax the-xml-element))
(define (syntax:read-xml/element [in (current-input-port)])
(define the-xml-element (read-xml/element in))
(element->xexpr-syntax the-xml-element))
(define (position from to)
(let ([start-offset (location-offset from)])
(list #f (location-line from) (location-char from) start-offset
(- (location-offset to) start-offset))))
(define (wrap s e)
(datum->syntax #f e (position (source-start s) (source-stop s))))
(define (attribute->syntax a)
(wrap a (list (attribute-name a) (attribute-value a))))
(define (non-dropping-combine atts body)
(list* (map attribute->syntax atts) body))
(define (combine atts body)
(if (xexpr-drop-empty-attributes)
(if (empty? atts)
body
(non-dropping-combine atts body))
(non-dropping-combine atts body)))
(define (element->xexpr-syntax e)
(wrap e
(list* (element-name e)
(combine (element-attributes e)
(map content->xexpr-syntax (element-content e))))))
(define (content->xexpr-syntax x)
(cond
[(element? x) (element->xexpr-syntax x)]
[(pcdata? x) (wrap x (pcdata-string x))]
[(entity? x) (wrap x (entity-text x))]
[else (wrap x x)])))
(define-compound-unit/infer xml@
(import)
(export xml-structs^ reader^ xml-syntax^ writer^ xexpr^ space^)
(link xml-structs@ reader@ native-xml-syntax@ writer@ xexpr@ space@))

209
collects/xml/xml.scrbl
View File

@ -33,6 +33,107 @@ It also does not expand user-defined entities or read user-defined entities in a
@section{Datatypes}
@defstruct[location ([line exact-nonnegative-integer?]
[char exact-nonnegative-integer?]
[offset exact-nonnegative-integer?])]{
Represents a location in an input stream.}
@defthing[location/c contract?]{
Equivalent to @scheme[(or/c location? symbol? false/c)].
}
@defstruct[source ([start location/c]
[stop location/c])]{
Represents a source location. Other structure types extend @scheme[source].
When XML is generated from an input stream by @scheme[read-xml],
locations are represented by @scheme[location] instances. When XML
structures are generated by @scheme[xexpr->xml], then locations are
symbols.}
@deftogether[(
@defstruct[external-dtd ([system string?])]
@defstruct[(external-dtd/public external-dtd) ([public string?])]
@defstruct[(external-dtd/system external-dtd) ()]
)]{
Represents an externally defined DTD.}
@defstruct[document-type ([name symbol?]
[external external-dtd?]
[inlined false/c])]{
Represents a document type.}
@defstruct[comment ([text string?])]{
Represents a comment.}
@defstruct[(p-i source) ([target-name symbol?]
[instruction string?])]{
Represents a processing instruction.}
@defthing[misc/c contract?]{
Equivalent to @scheme[(or/c comment? p-i?)]
}
@defstruct[prolog ([misc (listof misc/c)]
[dtd (or/c document-type false/c)]
[misc2 (listof misc/c)])]{
Represents a document prolog.
}
@defstruct[document ([prolog prolog?]
[element element?]
[misc (listof misc/c)])]{
Represents a document.}
@defstruct[(element source) ([name symbol?]
[attributes (listof attribute?)]
[content (listof content/c)])]{
Represents an element.}
@defstruct[(attribute source) ([name symbol?] [value string?])]{
Represents an attribute within an element.}
@defthing[content/c contract?]{
Equivalent to @scheme[(or/c pcdata? element? entity? comment? cdata? p-i? permissive/c)].
}
@defthing[permissive/c contract?]{
If @scheme[(permissive?)] is @scheme[#t], then equivalent to @scheme[any/c], otherwise equivalent to @scheme[(make-none/c 'permissive)]}
@defstruct[(entity source) ([text (or/c symbol? exact-nonnegative-integer?)])]{
Represents a symbolic or numerical entity.}
@defstruct[(pcdata source) ([string string?])]{
Represents PCDATA content.}
@defstruct[(cdata source) ([string string?])]{
Represents CDATA content.
The @scheme[string] field is assumed to be of the form
@litchar{<![CDATA[}@nonterm{content}@litchar{]]>} with proper quoting
of @nonterm{content}. Otherwise, @scheme[write-xml] generates
incorrect output.}
@defstruct[(exn:invalid-xexpr exn:fail) ([code any/c])]{
Raised by @scheme[validate-xexpr] when passed an invalid
@tech{X-expression}. The @scheme[code] fields contains an invalid part
of the input to @scheme[validate-xexpr].}
@defstruct[(exn:xml exn:fail:read) ()]{
Raised by @scheme[read-xml] when an error in the XML input is found.
}
@defproc[(xexpr? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @tech{X-expression}, @scheme[#f] otherwise.
@ -65,108 +166,12 @@ An @scheme[_exact-nonnegative-integer] represents a numeric entity. For example,
A @scheme[_cdata] is an instance of the @scheme[cdata] structure type,
and a @scheme[_misc] is an instance of the @scheme[comment] or
@scheme[pcdata] structure types.}
@scheme[p-i] structure types.}
@defthing[xexpr/c contract?]{
A contract that is like @scheme[xexpr?] except produces a better error message when the value is not an @tech{X-expression}.
}
@defstruct[document ([prolog prolog?]
[element element?]
[misc (listof (or/c comment? p-i?))])]{
Represents a document.}
@defstruct[prolog ([misc (listof (or/c comment? p-i?))]
[dtd (or/c document-type false/c)]
[misc2 (listof (or/c comment? p-i?))])]{
Represents a document prolog.
}
@defstruct[document-type ([name symbol?]
[external external-dtd?]
[inlined false/c])]{
Represents a document type.}
@deftogether[(
@defstruct[external-dtd ([system string?])]
@defstruct[(external-dtd/public external-dtd) ([public string?])]
@defstruct[(external-dtd/system external-dtd) ()]
)]{
Represents an externally defined DTD.}
@defstruct[(element source) ([name symbol?]
[attributes (listof attribute?)]
[content (listof content?)])]{
Represents an element.}
@defproc[(content? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @scheme[pcdata] instance,
@scheme[element] instance, an @scheme[entity] instance,
@scheme[comment], or @scheme[cdata] instance.}
@defstruct[(attribute source) ([name symbol?] [value string?])]{
Represents an attribute within an element.}
@defstruct[(entity source) ([text (or/c symbol? exact-nonnegative-integer?)])]{
Represents a symbolic or numerical entity.}
@defstruct[(pcdata source) ([string string?])]{
Represents PCDATA content.}
@defstruct[(cdata source) ([string string?])]{
Represents CDATA content.
The @scheme[string] field is assumed to be of the form
@litchar{<![CDATA[}@nonterm{content}@litchar{]]>} with proper quoting
of @nonterm{content}. Otherwise, @scheme[write-xml] generates
incorrect output.}
@defstruct[(p-i source) ([target-name string?]
[instruction string?])]{
Represents a processing instruction.}
@defstruct[comment ([text string?])]{
Represents a comment.}
@defstruct[source ([start (or/c location? symbol?)]
[stop (or/c location? symbol?)])]{
Represents a source location. Other structure types extend @scheme[source].
When XML is generated from an input stream by @scheme[read-xml],
locations are represented by @scheme[location] instances. When XML
structures are generated by @scheme[xexpr->xml], then locations are
symbols.}
@defstruct[location ([line exact-nonnegative-integer?]
[char exact-nonnegative-integer?]
[offset exact-nonnegative-integer?])]{
Represents a location in an input stream.}
@defstruct[(exn:invalid-xexpr exn:fail) ([code any/c])]{
Raised by @scheme[validate-xexpr] when passed an invalid
@tech{X-expression}. The @scheme[code] fields contains an invalid part
of the input to @scheme[validate-xexpr].}
@; ----------------------------------------------------------------------
@section{Reading and Writing XML}
@ -217,7 +222,7 @@ Like @scheme[syntax:real-xml], but it reads an XML element like
Writes a document to the given output port, currently ignoring
everything except the document's root element.}
@defproc[(write-xml/content [content content?] [out output-port? (current-output-port)])
@defproc[(write-xml/content [content content/c] [out output-port? (current-output-port)])
void?]{
Writes document content to the given output port.}
@ -229,7 +234,7 @@ Like @scheme[write-xml], but newlines and indentation make the output
more readable, though less technically correct when whitespace is
significant.}
@defproc[(display-xml/content [content content?] [out output-port? (current-output-port)])
@defproc[(display-xml/content [content content/c] [out output-port? (current-output-port)])
void?]{
Like @scheme[write-xml/content], but with indentation and newlines
@ -246,12 +251,12 @@ like @scheme[display-xml].}
and leave them in place in the resulting ``@tech{X-expression}''.
}
@defproc[(xml->xexpr [content content?]) xexpr/c]{
@defproc[(xml->xexpr [content content/c]) xexpr/c]{
Converts document content into an @tech{X-expression}, using
@scheme[permissive?] to determine if foreign objects are allowed.}
@defproc[(xexpr->xml [xexpr xexpr/c]) content?]{
@defproc[(xexpr->xml [xexpr xexpr/c]) content/c]{
Converts an @tech{X-expression} into XML content.}

17
collects/xml/xml.ss
View File

@ -1,7 +1,14 @@
#lang scheme
(require "xml-sig.ss"
"xml-unit.ss")
(require "private/structures.ss"
"private/reader.ss"
"private/space.ss"
"private/writer.ss"
"private/xexpr.ss"
"private/syntax.ss")
(define-values/invoke-unit/infer xml@)
(provide-signature-elements xml^)
(provide (all-from-out "private/structures.ss"
"private/reader.ss"
"private/space.ss"
"private/writer.ss"
"private/xexpr.ss"
"private/syntax.ss"))