Fixing PR13748
This commit is contained in:
parent
a48154a665
commit
857cdfce64
|
@ -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))
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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>
|
||||||
}|
|
}|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user