From 7a8ebdab7be3c903518818d14c72dfd9a409012b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 11 Sep 2012 17:17:38 -0600 Subject: [PATCH] add `xml/xexpr' Exports `xexpr?' and `xexpr/c' without dependencies on the rest of the `xml' library. --- collects/xml/private/core.rkt | 36 +++++++ collects/xml/private/structures.rkt | 33 +----- collects/xml/private/xexpr-core.rkt | 147 +++++++++++++++++++++++++++ collects/xml/private/xexpr.rkt | 150 ++-------------------------- collects/xml/xexpr.rkt | 8 ++ collects/xml/xml.scrbl | 12 ++- 6 files changed, 211 insertions(+), 175 deletions(-) create mode 100644 collects/xml/private/core.rkt create mode 100644 collects/xml/private/xexpr-core.rkt create mode 100644 collects/xml/xexpr.rkt diff --git a/collects/xml/private/core.rkt b/collects/xml/private/core.rkt new file mode 100644 index 0000000000..6260be4308 --- /dev/null +++ b/collects/xml/private/core.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require racket/contract/base) + +;; Core structures needed for `xml/xexpr' + +(provide (all-defined-out)) + +; permissive-xexprs : parameter bool +(define permissive-xexprs (make-parameter #f)) + +; Source = (make-source Location Location) +(define-struct source (start stop) #:transparent) + +; Comment = (make-comment String) +(define-struct comment (text) #:transparent) + +; Processing-instruction = (make-p-i Location Location String String) +; also represents XMLDecl +(define-struct (p-i source) (target-name instruction) #:transparent) + +; Pcdata = (make-pcdata Location Location String) +(define-struct (pcdata source) (string) #:transparent) + +; Cdata = (make-cdata Location Location String) +(define-struct (cdata source) (string) #:transparent) + +; Section 2.2 of XML 1.1 +; (XML 1.0 is slightly different and looks less restrictive) +(define (valid-char? i) + (and (exact-nonnegative-integer? i) + (or (= i #x9) + (= i #xA) + (= i #xD) + (<= #x20 i #xD7FF) + (<= #xE000 i #xFFFD) + (<= #x10000 i #x10FFFF)))) diff --git a/collects/xml/private/structures.rkt b/collects/xml/private/structures.rkt index b12daeba45..8cb7a4a31f 100644 --- a/collects/xml/private/structures.rkt +++ b/collects/xml/private/structures.rkt @@ -1,12 +1,10 @@ #lang racket/base -(require racket/contract) +(require "core.rkt" + racket/contract) ; Location = (make-location Nat Nat Nat) | Symbol (define-struct location (line char offset) #:transparent) -; Source = (make-source Location Location) -(define-struct source (start stop) #:transparent) - ; Document = (make-document Prolog Element (listof Misc)) (define-struct document (prolog element misc) #:transparent) @@ -30,12 +28,6 @@ ; Attribute = (make-attribute Location Location Symbol String) (define-struct (attribute source) (name value) #:transparent) -; Pcdata = (make-pcdata Location Location String) -(define-struct (pcdata source) (string) #:transparent) - -; Cdata = (make-cdata Location Location String) -(define-struct (cdata source) (string) #:transparent) - ; Content = Pcdata ; | Element ; | Entity @@ -45,30 +37,9 @@ ; Misc = Comment ; | Processing-instruction -; Section 2.2 of XML 1.1 -; (XML 1.0 is slightly different and looks less restrictive) -(define (valid-char? i) - (and (exact-nonnegative-integer? i) - (or (= i #x9) - (= i #xA) - (= i #xD) - (<= #x20 i #xD7FF) - (<= #xE000 i #xFFFD) - (<= #x10000 i #x10FFFF)))) - ; Entity = (make-entity Location Location (U Nat Symbol)) (define-struct (entity source) (text) #:transparent) -; Processing-instruction = (make-p-i Location Location String String) -; also represents XMLDecl -(define-struct (p-i source) (target-name instruction) #:transparent) - -; Comment = (make-comment String) -(define-struct comment (text) #:transparent) - -; permissive-xexprs : parameter bool -(define permissive-xexprs (make-parameter #f)) - (define permissive/c (make-contract #:name 'permissive/c diff --git a/collects/xml/private/xexpr-core.rkt b/collects/xml/private/xexpr-core.rkt new file mode 100644 index 0000000000..1f31fdaf16 --- /dev/null +++ b/collects/xml/private/xexpr-core.rkt @@ -0,0 +1,147 @@ +#lang racket/base +(require racket/list + racket/contract/base + racket/contract/combinator + racket/pretty + "core.rkt") + + +(provide + (contract-out + [xexpr/c contract?] + [xexpr? (any/c . -> . boolean?)] + [validate-xexpr (any/c . -> . (one-of/c #t))] + [correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)]) + (struct-out exn:invalid-xexpr)) + +;; Xexpr ::= String +;; | (list* Symbol (listof Attribute-srep) (listof Xexpr)) +;; | (cons Symbol (listof Xexpr)) +;; | Symbol +;; | Nat (WFC: Valid Char) +;; | Comment +;; | Processing-instruction +;; | Cdata +;; Attribute-srep ::= (list Symbol String) + +;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts. + +(define xexpr-datum/c + (or/c string? symbol? valid-char? + comment? p-i? cdata? pcdata?)) + +(define (xexpr? x) + (correct-xexpr? x (lambda () #t) (lambda (exn) #f))) + +(define (validate-xexpr x) + (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn)))) + +(define xexpr/c + (make-flat-contract + #:name 'xexpr? + #:projection + (lambda (blame) + (lambda (val) + (with-handlers ([exn:invalid-xexpr? + (lambda (exn) + (raise-blame-error + blame + val + "Not an Xexpr. ~a\n\nContext:\n~a" + (exn-message exn) + (pretty-format val)))]) + (validate-xexpr val) + val))) + #:first-order xexpr?)) + +;; ;; ;; ;; ;; ;; ; +;; ; 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)) + ((valid-char? 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-xexprs) (true)] + (else (false + (make-exn:invalid-xexpr + (format (string-append + "Expected a string, symbol, valid numeric entity, 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 "Expected an attribute pair, given ~s" 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 (pair? (cdr attr)) + (if (or (string? (cadr attr)) + (permissive-xexprs)) + (true) + (false (make-exn:invalid-xexpr + (format "Expected an attribute value string, given ~v" (cadr attr)) + (current-continuation-marks) + (cadr attr)))) + (false (make-exn:invalid-xexpr + (format "Expected an attribute value string for attribute ~s, given nothing" attr) + (current-continuation-marks) + attr))) + (false (make-exn:invalid-xexpr + (format "Expected an attribute symbol, given ~s" (car attr)) + (current-continuation-marks) + (cadr attr))))) + +;; ; end xexpr? helpers +;; ;; ;; ;; ;; ;; ;; ;; diff --git a/collects/xml/private/xexpr.rkt b/collects/xml/private/xexpr.rkt index 5e96cee87a..dfdec61a78 100644 --- a/collects/xml/private/xexpr.rkt +++ b/collects/xml/private/xexpr.rkt @@ -2,20 +2,11 @@ (require racket/pretty racket/list racket/contract + "xexpr-core.rkt" "structures.rkt" "reader.rkt" "writer.rkt") -;; Xexpr ::= String -;; | (list* Symbol (listof Attribute-srep) (listof Xexpr)) -;; | (cons Symbol (listof Xexpr)) -;; | Symbol -;; | Nat (WFC: Valid Char) -;; | 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)) @@ -24,134 +15,6 @@ (define xexpr-drop-empty-attributes (make-parameter #f)) -(define xexpr-datum/c - (or/c string? symbol? valid-char? - 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? x) - (correct-xexpr? x (lambda () #t) (lambda (exn) #f))) - -(define (validate-xexpr x) - (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn)))) - -(define xexpr/c - (make-flat-contract - #:name 'xexpr? - #:projection - (lambda (blame) - (lambda (val) - (with-handlers ([exn:invalid-xexpr? - (lambda (exn) - (raise-blame-error - blame - val - "Not an Xexpr. ~a\n\nContext:\n~a" - (exn-message exn) - (pretty-format val)))]) - (validate-xexpr val) - val))) - #:first-order xexpr?)) - -;; ;; ;; ;; ;; ;; ; -;; ; 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)) - ((valid-char? 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-xexprs) (true)] - (else (false - (make-exn:invalid-xexpr - (format (string-append - "Expected a string, symbol, valid numeric entity, 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 "Expected an attribute pair, given ~s" 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 (pair? (cdr attr)) - (if (or (string? (cadr attr)) - (permissive-xexprs)) - (true) - (false (make-exn:invalid-xexpr - (format "Expected an attribute value string, given ~v" (cadr attr)) - (current-continuation-marks) - (cadr attr)))) - (false (make-exn:invalid-xexpr - (format "Expected an attribute value string for attribute ~s, given nothing" attr) - (current-continuation-marks) - attr))) - (false (make-exn:invalid-xexpr - (format "Expected an attribute symbol, given ~s" (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. @@ -241,19 +104,20 @@ (define (bcompose f g) (lambda (x y) (f (g x) (g y)))) +(provide xexpr? + validate-xexpr + correct-xexpr? + xexpr/c) + (provide/contract [exn:invalid-xexpr? (any/c . -> . boolean?)] [exn:invalid-xexpr-code (exn:invalid-xexpr? . -> . any/c)] - [xexpr/c contract?] - [xexpr? (any/c . -> . boolean?)] [string->xexpr (string? . -> . xexpr/c)] [xexpr->string (xexpr/c . -> . string?)] [xml->xexpr (content/c . -> . xexpr/c)] [xexpr->xml (xexpr/c . -> . content/c)] [xexpr-drop-empty-attributes (parameter/c boolean?)] - [write-xexpr (->* (xexpr/c) (output-port?) void)] - [validate-xexpr (any/c . -> . (one-of/c #t))] - [correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)]) + [write-xexpr (->* (xexpr/c) (output-port?) void)] ) (define (write-xexpr x [out (current-output-port)]) (cond diff --git a/collects/xml/xexpr.rkt b/collects/xml/xexpr.rkt new file mode 100644 index 0000000000..ec87dffacb --- /dev/null +++ b/collects/xml/xexpr.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require "private/xexpr-core.rkt") + + +(provide xexpr/c + xexpr? + validate-xexpr + correct-xexpr?) diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index f906828baa..39cb412d2c 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -18,7 +18,7 @@ @author["Paul Graunke and Jay McCarthy"] -@defmodule[xml] +@defmodule[xml #:use-sources (xml/private/xexpr-core)] The @racketmodname[xml] library provides functions for parsing and generating XML. XML can be represented as an instance of the @@ -181,6 +181,16 @@ and a @racket[_misc] is an instance of the @racket[comment] or @; ---------------------------------------------------------------------- +@section{X-expression Predicate and Contract} + +@defmodule[xml/xexpr] + +The @racketmodname[xml/xexpr] library provides just @racket[xexpr/c], +@racket[xexpr?], @racket[correct-xexpr?], and @racket[validate-xexpr] +from @racketmodname[xml] with minimal dependencies. + +@; ---------------------------------------------------------------------- + @section{Reading and Writing XML} @defproc[(read-xml [in input-port? (current-input-port)]) document?]{