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

Making string->xexpr more permissive

Browse Source
This commit is contained in:
Jay McCarthy 2010-05-27 10:48:05 -06:00
parent 103d53f6ad
commit 08a48a67a0
2 changed files with 21 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/tests/xml/test.rkt
View File

@ -481,7 +481,10 @@ END
[(define (test-xml->xexpr str xe) [(define (test-xml->xexpr str xe)
(test-equal? str (string->xexpr str) xe)) (test-equal? str (string->xexpr str) xe))
(define (test-xexpr->string xe str) (define (test-xexpr->string xe str)
(test-equal? (format "~S" xe) (xexpr->string xe) str))] (test-equal? (format "~S" xe) (xexpr->string xe) str)
(test-string->xexpr str xe))
(define (test-string->xexpr str xe)
(test-equal? str (string->xexpr str) xe))]
(test-suite (test-suite
"XML and X-expression Conversions" "XML and X-expression Conversions"
@ -519,12 +522,20 @@ END
; XXX more xexpr->string tests ; XXX more xexpr->string tests
) )
(test-suite
"string->xexpr"
(test-string->xexpr "<?foo bar?>\n\n<html /><?foo bar?>\n"
'(html ()))
(parameterize ([xexpr-drop-empty-attributes #t])
(test-string->xexpr "<?foo bar?>\n\n<html /><?foo bar?>\n"
'(html))))
(local (local
[(define (test-eliminate-whitespace tags choose str res) [(define (test-eliminate-whitespace tags choose str res)
(test-equal? (format "~S" (list tags choose str)) (test-equal? (format "~S" (list tags choose str))
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str)))))) (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str))))))
res)) res))
(define (test-eliminate-whitespace/exn tags choose str msg) (define (test-eliminate-whitespace/exn tags choose str msg)
(test-exn (format "~S" (list tags choose str)) (test-exn (format "~S" (list tags choose str))
@ -533,8 +544,8 @@ END
(regexp-match (regexp-quote msg) (exn-message x)))) (regexp-match (regexp-quote msg) (exn-message x))))
(lambda () (lambda ()
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str))))))))) (write-xml/content ((eliminate-whitespace tags choose) (read-xml/element (open-input-string str)))))))))
(define (truer x) #t)] (define (truer x) #t)]
(test-suite (test-suite
"eliminate-whitespace" "eliminate-whitespace"
@ -601,8 +612,8 @@ END
(test-equal? (format "~S" (list v istr)) (test-equal? (format "~S" (list v istr))
(parameterize ([param v]) (parameterize ([param v])
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(write-xml (read-xml (open-input-string istr)))))) (write-xml (read-xml (open-input-string istr))))))
ostr)) ostr))
(define test-empty-tag-shorthand (mk-test-param empty-tag-shorthand)) (define test-empty-tag-shorthand (mk-test-param empty-tag-shorthand))
(define test-collapse-whitespace (mk-test-param collapse-whitespace)) (define test-collapse-whitespace (mk-test-param collapse-whitespace))
@ -715,8 +726,8 @@ END
(test-equal? "write-plist" (test-equal? "write-plist"
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(write-plist example (current-output-port)))) (write-plist example (current-output-port))))
example-str) example-str)
(local [(define (test-plist-round-trip plist) (local [(define (test-plist-round-trip plist)

2
collects/xml/private/xexpr.rkt
View File

@ -233,7 +233,7 @@
(get-output-string port))) (get-output-string port)))
(define (string->xexpr str) (define (string->xexpr str)
(xml->xexpr (read-xml/element (open-input-string str)))) (xml->xexpr (document-element (read-xml (open-input-string str)))))
;; bcompose : (a a -> c) (b -> a) -> (b b -> c) ;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
(define (bcompose f g) (define (bcompose f g)