Fixing PR13748

This commit is contained in:
Jay McCarthy 2013-05-20 15:46:36 -06:00
parent a48154a665
commit 857cdfce64
3 changed files with 46 additions and 18 deletions

View File

@ -751,11 +751,15 @@ END
"another string" "another string"
(true))) (true)))
(assoc-pair "sixth-key" (assoc-pair "sixth-key"
(array)))) (array))
(assoc-pair "seventh-key"
(data "some data"))
(assoc-pair "eighth-key"
(date "2013-05-10T20:29:55Z"))))
(define example-str #<<END (define example-str #<<END
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist SYSTEM "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!DOCTYPE plist SYSTEM "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="0.9"><dict><key>first-key</key><string>just a string with some whitespace in it</string><key>second-key</key><false /><key>third-key</key><dict /><key>fourth-key</key><dict><key>inner-key</key><real>3.432</real></dict><key>fifth-key</key><array><integer>14</integer><string>another string</string><true /></array><key>sixth-key</key><array /></dict></plist> <plist version="0.9"><dict><key>first-key</key><string>just a string with some whitespace in it</string><key>second-key</key><false /><key>third-key</key><dict /><key>fourth-key</key><dict><key>inner-key</key><real>3.432</real></dict><key>fifth-key</key><array><integer>14</integer><string>another string</string><true /></array><key>sixth-key</key><array /><key>seventh-key</key><data>some data</data><key>eighth-key</key><date>2013-05-10T20:29:55Z</date></dict></plist>
END END
)] )]
(test-suite (test-suite
@ -819,4 +823,5 @@ END
(plist-value? v)) (plist-value? v))
(test-plist-round-trip v)))))))) (test-plist-round-trip v))))))))
(run-tests xml-tests) (module+ test
(run-tests xml-tests))

View File

@ -3,18 +3,6 @@
racket/contract racket/contract
xml) xml)
; a dict is (list 'dict assoc-pair ...)
; an assoc-pair is (list 'assoc-pair key value)
; a key is a string
; a value is either:
; a string,
; a boolean,
; an integer : (list 'integer number)
; a real : (list 'real number)
; a dict, or
; an array : (list 'array value ...)
; (we're ignoring data & date)
(define (plist-dict? v) (define (plist-dict? v)
(and (list? v) (and (list? v)
(pair? v) (pair? v)
@ -38,9 +26,10 @@
[(real) (and (= (length v) 2) [(real) (and (= (length v) 2)
(real? (cadr v)))] (real? (cadr v)))]
[(array) (andmap plist-value? (cdr v))] [(array) (andmap plist-value? (cdr v))]
[(data) (and (= (length v) 2) (string? (cadr v)))]
[(date) (and (= (length v) 2) (string? (cadr v)))]
[else (plist-dict? v)])))) [else (plist-dict? v)]))))
; raise-plist-exn : string mark-set xexpr symbol -> ??? ; raise-plist-exn : string mark-set xexpr symbol -> ???
(define (raise-plist-exn tag mark-set xexpr type) (define (raise-plist-exn tag mark-set xexpr type)
(raise (make-exn:fail:contract (string-append "badly formed '" tag "'") (raise (make-exn:fail:contract (string-append "badly formed '" tag "'")
@ -85,6 +74,14 @@
(expand-dict x)) (expand-dict x))
=> =>
(lambda (x) x)] (lambda (x) x)]
[(and (eq? (car x) 'date)
(expand-date x))
=>
(lambda (x) x)]
[(and (eq? (car x) 'data)
(expand-data x))
=>
(lambda (x) x)]
[(and (eq? (car x) 'array) [(and (eq? (car x) 'array)
(expand-array x)) (expand-array x))
=> =>
@ -108,6 +105,20 @@
[else [else
(raise-plist-exn "integer" (current-continuation-marks) x 'plist:integer)])) (raise-plist-exn "integer" (current-continuation-marks) x 'plist:integer)]))
(define (expand-date x)
(cond [(and (eq? (car x) 'date)
(string? (cadr x)))
`(date ,(cadr x))]
[else
(raise-plist-exn "date" (current-continuation-marks) x 'plist:date)]))
(define (expand-data x)
(cond [(and (eq? (car x) 'data)
(string? (cadr x)))
`(data ,(cadr x))]
[else
(raise-plist-exn "data" (current-continuation-marks) x 'plist:data)]))
; expand-array : xexpr -> xexpr ; expand-array : xexpr -> xexpr
(define (expand-array x) (define (expand-array x)
(cond [(and (eq? (car x) 'array) (cond [(and (eq? (car x) 'array)
@ -160,7 +171,9 @@
[(true false) value] [(true false) value]
[(integer real) (list (car value) (string->number (cadr value)))] [(integer real) (list (car value) (string->number (cadr value)))]
[(dict) (collapse-dict value)] [(dict) (collapse-dict value)]
[(array) (collapse-array value)])) [(array) (collapse-array value)]
[(date) value]
[(data) value]))
; collapse-array : xexpr -> array ; collapse-array : xexpr -> array
(define (collapse-array xexpr) (define (collapse-array xexpr)

View File

@ -425,6 +425,8 @@ value created by a @racket[_dict-expr] is a @deftech{plist dictionary}:
(list 'false) (list 'false)
(list 'integer integer) (list 'integer integer)
(list 'real real) (list 'real real)
(list 'data string)
(list 'date string)
dict-expr dict-expr
(list 'array pl-expr ...)] (list 'array pl-expr ...)]
[dict-expr (list 'dict assoc-pair ...)] [dict-expr (list 'dict assoc-pair ...)]
@ -466,7 +468,11 @@ Write a @tech{plist value} to the given port.}
"another string" "another string"
(true))) (true)))
(assoc-pair "sixth-key" (assoc-pair "sixth-key"
(array)))) (array))
(assoc-pair "seventh-key"
(data "some data"))
(assoc-pair "eighth-key"
(date "2013-05-10T20:29:55Z"))))
(define-values (in out) (make-pipe)) (define-values (in out) (make-pipe))
(write-plist my-dict out) (write-plist my-dict out)
(close-output-port out) (close-output-port out)
@ -503,6 +509,10 @@ indentation:
</array> </array>
<key>sixth-key</key> <key>sixth-key</key>
<array /> <array />
<key>seventh-key</key>
<data>some data</data>
<key>eighth-key</key>
<date>2013-05-10T20:29:55Z</date>
</dict> </dict>
</plist> </plist>
}| }|