add `xml/xexpr'
Exports `xexpr?' and `xexpr/c' without dependencies on the rest of the `xml' library.
This commit is contained in:
Matthew Flatt
parent
f1671f2044
commit
7a8ebdab7b
36
collects/xml/private/core.rkt
Normal file
36
collects/xml/private/core.rkt
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
147
collects/xml/private/xexpr-core.rkt
Normal file
147
collects/xml/private/xexpr-core.rkt
Normal file
|
|
@ -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
|
||||
;; ;; ;; ;; ;; ;; ;; ;;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
8
collects/xml/xexpr.rkt
Normal file
8
collects/xml/xexpr.rkt
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
#lang racket/base
|
||||
(require "private/xexpr-core.rkt")
|
||||
|
||||
|
||||
(provide xexpr/c
|
||||
xexpr?
|
||||
validate-xexpr
|
||||
correct-xexpr?)
|
||||
|
|
@ -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?]{
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user