254 lines
8.5 KiB
Racket
254 lines
8.5 KiB
Racket
#lang racket
|
|
(require racket/pretty
|
|
"structures.rkt"
|
|
"reader.rkt"
|
|
"writer.rkt")
|
|
|
|
;; Xexpr ::= String
|
|
;; | (list* Symbol (listof Attribute-srep) (listof Xexpr))
|
|
;; | (cons Symbol (listof Xexpr))
|
|
;; | Symbol
|
|
;; | Nat
|
|
;; | 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))
|
|
(define (assoc-sort to-sort)
|
|
(sort to-sort (bcompose string<? (compose symbol->string car))))
|
|
|
|
(define xexpr-drop-empty-attributes (make-parameter #f))
|
|
|
|
(define xexpr-datum/c
|
|
(or/c string? symbol? exact-nonnegative-integer?
|
|
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))
|
|
((exact-nonnegative-integer? 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, number, 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 a pair, given ~a" 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 a string, given ~a" (cadr attr))
|
|
(current-continuation-marks)
|
|
(cadr attr))))
|
|
(false (make-exn:invalid-xexpr
|
|
(format "Expected an attribute value string for attribute ~a" attr)
|
|
(current-continuation-marks)
|
|
attr)))
|
|
(false (make-exn:invalid-xexpr
|
|
(format "Expected a symbol, given ~a" (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.
|
|
(define (listof? p? l)
|
|
(let listof-p? ([l l])
|
|
(or (null? l)
|
|
(and (cons? l) (p? (car l)) (listof-p? (cdr l))))))
|
|
|
|
; : tst -> bool
|
|
(define (xexpr-attribute? b)
|
|
(and (pair? b)
|
|
(symbol? (car b))
|
|
(pair? (cdr b))
|
|
(string? (cadr b))
|
|
(null? (cddr b))))
|
|
|
|
;; xml->xexpr : Content -> Xexpr
|
|
(define (xml->xexpr x)
|
|
(let* ([non-dropping-combine
|
|
(lambda (atts body)
|
|
(cons (assoc-sort (map attribute->srep atts))
|
|
body))]
|
|
[combine (if (xexpr-drop-empty-attributes)
|
|
(lambda (atts body)
|
|
(if (null? atts)
|
|
body
|
|
(non-dropping-combine atts body)))
|
|
non-dropping-combine)])
|
|
(let loop ([x x])
|
|
(cond
|
|
[(element? x)
|
|
(let ([body (map loop (element-content x))]
|
|
[atts (element-attributes x)])
|
|
(cons (element-name x) (combine atts body)))]
|
|
[(pcdata? x) (pcdata-string x)]
|
|
[(entity? x) (entity-text x)]
|
|
[(or (comment? x) (p-i? x) (cdata? x)) x]
|
|
[(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)]
|
|
[(permissive-xexprs) x]
|
|
[else (error 'xml->xexpr "Expected content, given ~e" x)]))))
|
|
|
|
;; attribute->srep : Attribute -> Attribute-srep
|
|
(define (attribute->srep a)
|
|
(list (attribute-name a) (attribute-value a)))
|
|
|
|
;; srep->attribute : Attribute-srep -> Attribute
|
|
(define (srep->attribute a)
|
|
(unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a)))
|
|
(error 'srep->attribute "expected (list Symbol String) given ~e" a))
|
|
(make-attribute 'scheme 'scheme (car a) (cadr a)))
|
|
|
|
;; xexpr->xml : Xexpr -> Content
|
|
;; The contract is enforced.
|
|
(define (xexpr->xml x)
|
|
(cond
|
|
[(pair? x)
|
|
(let ([f (lambda (atts body)
|
|
(unless (list? body)
|
|
(error 'xexpr->xml
|
|
"expected a list of xexprs for the body in ~e"
|
|
x))
|
|
(make-element 'scheme 'scheme (car x)
|
|
atts
|
|
(map xexpr->xml body)))])
|
|
(if (and (pair? (cdr x))
|
|
(or (null? (cadr x))
|
|
(and (pair? (cadr x)) (pair? (caadr x)))))
|
|
(f (map srep->attribute (cadr x)) (cddr x))
|
|
(f null (cdr x))))]
|
|
[(string? x) (make-pcdata 'scheme 'scheme x)]
|
|
[(or (symbol? x) (exact-nonnegative-integer? x))
|
|
(make-entity 'scheme 'scheme x)]
|
|
[(or (comment? x) (p-i? x) (cdata? x) (pcdata? x)) x]
|
|
[else ;(error 'xexpr->xml "malformed xexpr ~e" x)
|
|
x]))
|
|
|
|
;; xexpr->string : Xexpression -> String
|
|
(define (xexpr->string xexpr)
|
|
(let ([port (open-output-string)])
|
|
(write-xml/content (xexpr->xml xexpr) port)
|
|
(get-output-string port)))
|
|
|
|
(define (string->xexpr str)
|
|
(xml->xexpr (document-element (read-xml (open-input-string str)))))
|
|
|
|
;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
|
|
(define (bcompose f g)
|
|
(lambda (x y) (f (g x) (g y))))
|
|
|
|
(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?)]
|
|
[validate-xexpr (any/c . -> . (one-of/c #t))]
|
|
[correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)])
|