add `check-txexprs-equal?`

pull/2/head
Matthew Butterick 9 years ago
parent 5a97174df1
commit 7fe9a04b6d

@ -50,7 +50,7 @@
(define+provide+safe (txexpr-attrs? x) (define+provide+safe (txexpr-attrs? x)
predicate/c predicate/c
(and (list? x) (andmap txexpr-attr? x))) (and (list? x) (andmap txexpr-attr? x)))
(define+provide+safe (txexpr-element? x) (define+provide+safe (txexpr-element? x)
@ -60,7 +60,7 @@
(define+provide+safe (txexpr-elements? x) (define+provide+safe (txexpr-elements? x)
predicate/c predicate/c
(and (list? x) (andmap txexpr-element? x))) (and (list? x) (andmap txexpr-element? x)))
(define+provide+safe (txexpr-attr-key? x) (define+provide+safe (txexpr-attr-key? x)
@ -245,8 +245,8 @@
(define+provide+safe (attr-join tx key value) (define+provide+safe (attr-join tx key value)
(txexpr? can-be-txexpr-attr-key? can-be-txexpr-attr-value? . -> . txexpr?) (txexpr? can-be-txexpr-attr-key? can-be-txexpr-attr-value? . -> . txexpr?)
(define starting-values (string-split (if (attrs-have-key? tx key) (define starting-values (string-split (if (attrs-have-key? tx key)
(attr-ref tx key) (attr-ref tx key)
""))) "")))
(attr-set tx key (string-join `(,@starting-values ,value) " "))) (attr-set tx key (string-join `(,@starting-values ,value) " ")))
@ -340,4 +340,19 @@
[(txexpr? x) (if (member (get-tag x) '(script style)) [(txexpr? x) (if (member (get-tag x) '(script style))
(make-txexpr (get-tag x) (get-attrs x) (map ->cdata (get-elements x))) (make-txexpr (get-tag x) (get-attrs x) (map ->cdata (get-elements x)))
(make-txexpr (get-tag x) (get-attrs x) (map loop (get-elements x))))] (make-txexpr (get-tag x) (get-attrs x) (map loop (get-elements x))))]
[else x])))) [else x]))))
(require rackunit)
(provide+safe check-txexprs-equal?)
(define-simple-check (check-txexprs-equal? tx1 tx2)
;; txexprs are deemed equal if they differ only in the ordering of attributes.
;; therefore, to check them, 1) sort their attributes, 2) straight list comparison.
(define symbol<? (λ syms (apply string<? (map symbol->string syms))))
(define (sort-attrs x)
(if (txexpr? x)
(let-values ([(tag attr elements) (txexpr->values x)])
(make-txexpr tag (sort attr #:key car symbol<?) (map sort-attrs elements)))
x))
(equal? (sort-attrs tx1) (sort-attrs tx2)))
(check-txexprs-equal? '(p ((b "foo")(a "bar")) (span ((d "foo")(c "bar")))) '(p ((a "bar")(b "foo")) (span ((c "bar")(d "foo")))))

@ -3,10 +3,10 @@
@; for documentation purposes, use the xexpr? from xml. @; for documentation purposes, use the xexpr? from xml.
@; the one in txexpr is just to patch over an issue with @; the one in txexpr is just to patch over an issue with
@; `valid-char?` in Racket 6. @; `valid-char?` in Racket 6.
@(require scribble/eval (for-label racket txexpr xml)) @(require scribble/eval (for-label racket txexpr xml rackunit))
@(define my-eval (make-base-eval)) @(define my-eval (make-base-eval))
@(my-eval `(require txexpr xml)) @(my-eval `(require txexpr xml rackunit))
@title{txexpr: Tagged X-expressions} @title{txexpr: Tagged X-expressions}
@ -516,6 +516,33 @@ Ordinarily, the result of the split operation is to remove the elements that mat
] ]
@defproc[
(check-txexprs-equal?
[tx1 txexpr?]
[tx2 txexpr?])
void?]
Designed to be used with @racketmodname[rackunit]. Check whether @racket[_tx1] and @racket[_tx2] are @racket[equal?] except for ordering of attributes (which ordinarily has no semantic significance). Return @racket[void] if so, otherwise raise a check failure.
@examples[#:eval my-eval
(define tx1 '(div ((attr-a "foo")(attr-z "bar"))))
(define tx2 '(div ((attr-z "bar")(attr-a "foo"))))
(parameterize ([current-check-handler (λ _ (display "not "))])
(display "txexprs are ")
(check-txexprs-equal? tx1 tx2)
(displayln "equal"))
]
If ordering of attributes is relevant to your test, then just use @racket[check-equal?] as usual.
@examples[#:eval my-eval
(define tx1 '(div ((attr-a "foo")(attr-z "bar"))))
(define tx2 '(div ((attr-z "bar")(attr-a "foo"))))
(parameterize ([current-check-handler (λ _ (display "not "))])
(display "txexprs are ")
(check-equal? tx1 tx2)
(displayln "equal"))
]
@section{License & source code} @section{License & source code}

Loading…
Cancel
Save