From 3ecf06a8ba9063e4821b40b8db29eda358c56506 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 10 Apr 2012 16:38:54 -0600 Subject: [PATCH] generalize `xml/plist' to read/write any plist value Merge to 5.3 --- collects/tests/xml/test.rkt | 18 ++++++++++- collects/xml/plist.rkt | 64 ++++++++++++++++++++----------------- collects/xml/xml.scrbl | 26 +++++++++------ 3 files changed, 67 insertions(+), 41 deletions(-) diff --git a/collects/tests/xml/test.rkt b/collects/tests/xml/test.rkt index b7287770ba..2bed28d40b 100644 --- a/collects/tests/xml/test.rkt +++ b/collects/tests/xml/test.rkt @@ -784,6 +784,22 @@ END (write-plist plist out) (close-output-port out) (test-equal? (format "~S" plist) (read-plist in) plist))] - (test-plist-round-trip example)))))) + (test-plist-round-trip example) + + (let () + (define array '(array "apple" + (true) + (false) + (integer 5) + (real 5.0))) + (test-not-false + "plist-value?" + (plist-value? array)) + (test-plist-round-trip array) + (for ([v (in-list (cdr array))]) + (test-not-false + "plist-value?" + (plist-value? v)) + (test-plist-round-trip v)))))))) (run-tests xml-tests) diff --git a/collects/xml/plist.rkt b/collects/xml/plist.rkt index 7ee184dd4c..a56e700027 100644 --- a/collects/xml/plist.rkt +++ b/collects/xml/plist.rkt @@ -22,20 +22,22 @@ (= 3 (length v)) (eq? (car v) 'assoc-pair) (string? (cadr v)) - (let pl-value? ([v (caddr v)]) - (or (string? v) - (and (pair? v) - (case (car v) - [(true) (null? (cdr v))] - [(false) (null? (cdr v))] - [(integer) (and (= (length v) 2) - (exact-integer? (cadr v)))] - [(real) (and (= (length v) 2) - (real? (cadr v)))] - [(array) (andmap pl-value? (cdr v))] - [else (plist-dict? v)])))))) + (plist-value? (caddr v)))) (cdr v)))) +(define (plist-value? v) + (or (string? v) + (and (pair? v) + (case (car v) + [(true) (null? (cdr v))] + [(false) (null? (cdr v))] + [(integer) (and (= (length v) 2) + (exact-integer? (cadr v)))] + [(real) (and (= (length v) 2) + (real? (cadr v)))] + [(array) (andmap plist-value? (cdr v))] + [else (plist-dict? v)])))) + ; raise-plist-exn : string mark-set xexpr symbol -> ??? (define (raise-plist-exn tag mark-set xexpr type) @@ -122,18 +124,17 @@ ; write-plist : xexpr port -> (void) (define (write-plist xexpr port) - (let ([plist-xexpr `(plist ,(expand-dict xexpr))]) - (write-xml - (make-document (make-prolog (list (make-p-i #f #f 'xml "version=\"1.0\" encoding=\"UTF-8\"")) - (make-document-type 'plist - (make-external-dtd/system - "http://www.apple.com/DTDs/PropertyList-1.0.dtd") - #f) - empty) - (xexpr->xml `(plist ((version "0.9")) - ,(expand-dict xexpr))) - null) - port))) + (write-xml + (make-document (make-prolog (list (make-p-i #f #f 'xml "version=\"1.0\" encoding=\"UTF-8\"")) + (make-document-type 'plist + (make-external-dtd/system + "http://www.apple.com/DTDs/PropertyList-1.0.dtd") + #f) + empty) + (xexpr->xml `(plist ((version "0.9")) + ,(expand-value xexpr))) + null) + port)) ; collapse-dict : xexpr -> dict @@ -166,7 +167,7 @@ (define tags-without-whitespace '(plist dict array)) -; read-plist : port -> dict +; read-plist : port -> value (define (read-plist port) (let* ([xml-doc (read-xml port)] [content (parameterize ([xexpr-drop-empty-attributes #t]) @@ -175,9 +176,12 @@ (document-element xml-doc))))]) (unless (eq? (car content) 'plist) (error 'read-plist "xml expression is not a plist: ~a" content)) - (collapse-dict (caddr content)))) + (collapse-value (caddr content)))) + +(provide + (contract-out + [plist-dict? (any/c . -> . boolean?)] + [plist-value? (any/c . -> . boolean?)] + [read-plist (input-port? . -> . plist-value?)] + [write-plist (plist-value? output-port? . -> . void?)])) -(provide/contract - [plist-dict? (any/c . -> . boolean?)] - [read-plist (input-port? . -> . plist-dict?)] - [write-plist (plist-dict? output-port? . -> . void?)]) diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index 584946bdc9..f906828baa 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -387,34 +387,40 @@ used to store dictionaries of string--value associations. This format is used by Mac OS X (both the operating system and its applications) to store all kinds of data. -A @deftech{plist dictionary} is a value that could be created by an -expression matching the following @racket[_dict-expr] grammar: +A @deftech{plist value} is a value that could be created by an +expression matching the following @racket[_pl-expr] grammar, where a +value created by a @racket[_dict-expr] is a @deftech{plist dictionary}: @racketgrammar*[ #:literals (list quote) -[dict-expr (list 'dict assoc-pair ...)] -[assoc-pair (list 'assoc-pair string pl-value)] -[pl-value string +[pl-expr string (list 'true) (list 'false) (list 'integer integer) (list 'real real) dict-expr - (list 'array pl-value ...)] + (list 'array pl-expr ...)] +[dict-expr (list 'dict assoc-pair ...)] +[assoc-pair (list 'assoc-pair string pl-expr)] ] +@defproc[(plist-value? [any/c v]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @tech{plist value}, +@racket[#f] otherwise.} + @defproc[(plist-dict? [any/c v]) boolean?]{ Returns @racket[#t] if @racket[v] is a @tech{plist dictionary}, @racket[#f] otherwise.} -@defproc[(read-plist [in input-port?]) plist-dict?]{ +@defproc[(read-plist [in input-port?]) plist-value?]{ -Reads a plist from a port, and produces a @tech{plist dictionary}.} +Reads a plist from a port, and produces a @tech{plist value}.} -@defproc[(write-plist [dict plist-dict?] [out output-port?]) void?]{ +@defproc[(write-plist [dict plist-value?] [out output-port?]) void?]{ -Write a @tech{plist dictionary} to the given port.} +Write a @tech{plist value} to the given port.} @examples[ #:eval plist-eval