diff --git a/txexpr/test/check-values.rkt b/txexpr/test/check-values.rkt new file mode 100644 index 0000000..6a6bfe3 --- /dev/null +++ b/txexpr/test/check-values.rkt @@ -0,0 +1,63 @@ +#lang racket/base + +(provide values->list + check-values=? + check/values) + +(require rackunit + (for-syntax racket/base)) + +;; Takes an expression producing an unknown number of values +;; and wraps them all in a list. +(define-syntax-rule (values->list values-expr) + (call-with-values (λ () values-expr) list)) + + +;; Checks that two expressions (each producing an unknown +;; number of values until evaluated) produce the same number +;; of values, and that the values are equal. +(define-syntax check-values=? + (lambda (stx) + (syntax-case stx [] + [(_ actual-expr expected-expr) + (syntax/loc stx + (check/values check-equal? actual-expr expected-expr))]))) + +(define-syntax check/values + (lambda (stx) + (syntax-case stx [] + [(_ check-form actual-expr expected-expr) + (syntax/loc stx + (check-form (vs actual-expr) (vs expected-expr)))]))) + + +;; Takes an expression producing an unknown number of values +;; and wraps them in a "fake-values" structure that can be +;; compared with other fake-values structures for equality, +;; and can be printed to look like a call to `values`. +(define-syntax-rule (vs values-expr) + (fake-values (values->list values-expr))) + +;; if make-constructor-style-printer from racket/struct exists, +;; this is it, and otherwise this is a cheap immitation. +(define make-constructor-style-printer + (with-handlers ([exn:fail:filesystem? + (λ (e) + (λ (get-head get-elems) + (λ (v out mode) + (define head (get-head v)) + (define elems (get-elems v)) + (fprintf out "(~a" head) + (for ([elem elems]) + (fprintf out " ~v" elem)) + (fprintf out ")"))))]) + (dynamic-require 'racket/struct 'make-constructor-style-printer))) + +(struct fake-values [list] + #:transparent + #:methods gen:custom-write + [(define write-proc + (make-constructor-style-printer + (lambda (self) 'values) + (lambda (self) (fake-values-list self))))]) + diff --git a/txexpr/test/test-txexpr-stx.rkt b/txexpr/test/test-txexpr-stx.rkt new file mode 100644 index 0000000..5fe7df5 --- /dev/null +++ b/txexpr/test/test-txexpr-stx.rkt @@ -0,0 +1,115 @@ +#lang racket/base + +(require rackunit "../stx.rkt" "check-values.rkt" + (for-syntax racket/base)) + +;; Works on fully wrapped, non-wrapped, and partially +;; wrapped values, and it checks that the the inputs +;; are wrapped in all the same places. It checks scopes, +;; but it does not check source location. +(define-binary-check (check-stx=? stx=? actual expected)) + +(define (stx=? a b) + (cond + [(and (identifier? a) (identifier? b)) + (bound-identifier=? a b)] + [(and (syntax? a) (syntax? b)) + (and (bound-identifier=? (datum->syntax a '||) (datum->syntax b '||)) + (stx=? (syntax-e a) (syntax-e b)))] + [else + (equal?/recur a b stx=?)])) + +(define-syntax check-values-stx=? + (lambda (stx) + (syntax-case stx [] + [(_ actual-expr expected-expr) + (syntax/loc stx + (check/values check-stx=? actual-expr expected-expr))]))) + +;; --------------------------------------------------------- + +;; Predicates + +(check-pred stx-xexpr? "A leaf on a string") +(check-pred stx-xexpr? #'"A leaf in syntax") +(check-pred stx-xexpr? #'(div)) +(check-pred stx-xexpr? #'(div ((id "top")) "Hello" (p "World"))) +(check-pred stx-xexpr? `(div ((id ,#'"top")) "Hello" ,#'(p "World"))) + +(check-false (stx-txexpr? "A leaf without a tag")) +(check-pred stx-txexpr? '(div)) +(check-pred stx-txexpr? #'(div)) +(check-pred stx-txexpr? #'(div ((id "top")) "Hello" (p "World"))) +(check-pred stx-txexpr? `(div ((id ,#'"top")) "Hello" ,#'(p "World"))) + +(check-pred stx-txexpr-tag? 'div) +(check-pred stx-txexpr-tag? #'div) +(check-pred stx-txexpr-tag? 'this-is-something-else) +(check-pred stx-txexpr-tag? #'this-is-something-else) + +(check-pred stx-txexpr-attrs? '()) +(check-pred stx-txexpr-attrs? #'()) +(check-pred stx-txexpr-attrs? '((id "top") (stlye "color: blue"))) +(check-pred stx-txexpr-attrs? #'((id "top") (stlye "color: blue"))) +(check-pred stx-txexpr-attrs? `((id "top") (stlye ,#'"color: blue"))) + +;; --------------------------------------------------------- + +;; Accessors + +(check-values-stx=? (stx-txexpr->values '(p)) + (values 'p null null)) +(check-values-stx=? (stx-txexpr->values '(p "foo")) + (values 'p null '("foo"))) +(check-values-stx=? (stx-txexpr->values '(p ((key "value")))) + (values 'p '((key "value")) null)) +(check-values-stx=? (stx-txexpr->values '(p ((key "value")) "foo")) + (values 'p '((key "value")) '("foo"))) + +(check-values-stx=? (stx-txexpr->values #'(p)) + (values #'p null null)) +(check-values-stx=? (stx-txexpr->values #'(p "foo")) + (values #'p null (list #'"foo"))) +(check-values-stx=? (stx-txexpr->values #'(p ((key "value")))) + (values #'p #'((key "value")) null)) +(check-values-stx=? (stx-txexpr->values #'(p ((key "value")) "foo")) + (values #'p #'((key "value")) (list #'"foo"))) + +(check-values-stx=? (stx-txexpr->values `(,#'p)) + (values #'p null null)) +(check-values-stx=? (stx-txexpr->values `(p ,#'"foo")) + (values 'p null (list #'"foo"))) +(check-values-stx=? (stx-txexpr->values `(p ((,#'key "value")) . ,#'("foo"))) + (values 'p `((,#'key "value")) (list #'"foo"))) + + +(check-stx=? (stx-txexpr-tag '(p ((key "value"))"foo" (em "square"))) + 'p) +(check-stx=? (stx-txexpr-tag #'(p ((key "value"))"foo" (em "square"))) + #'p) + +(check-stx=? (stx-txexpr-attrs '(p ((key "value"))"foo" "bar" (em "square"))) + '((key "value"))) +(check-stx=? (stx-txexpr-attrs #'(p ((key "value"))"foo" "bar" (em "square"))) + #'((key "value"))) +(check-stx=? (stx-txexpr-attrs '(p "foo" "bar" (em "square"))) + '()) +(check-stx=? (stx-txexpr-attrs #'(p "foo" "bar" (em "square"))) + '()) + +(check-stx=? (stx-txexpr-elements '(p "foo" "bar" (em "square"))) + '("foo" "bar" (em "square"))) +(check-stx=? (stx-txexpr-elements #'(p "foo" "bar" (em "square"))) + (list #'"foo" #'"bar" #'(em "square"))) + +(check-stx=? (stx-txexpr-elements '(p ((k "v"))"foo" "bar" (em "square"))) + '("foo" "bar" (em "square"))) +(check-stx=? (stx-txexpr-elements #'(p ((k "v"))"foo" "bar" (em "square"))) + (list #'"foo" #'"bar" #'(em "square"))) +(check-stx=? (stx-txexpr-elements #'(p ((k "v"))"foo" . ("bar" (em "square")))) + (list #'"foo" #'"bar" #'(em "square"))) +(check-stx=? (stx-txexpr-elements `(p ((k "v"))"foo" .,#'("bar" (em "square")))) + (list "foo" #'"bar" #'(em "square"))) + +;; --------------------------------------------------------- + diff --git a/txexpr/test/tests.rkt b/txexpr/test/tests.rkt index d953e53..b5f61b7 100644 --- a/txexpr/test/tests.rkt +++ b/txexpr/test/tests.rkt @@ -10,15 +10,11 @@ (replace-context stx #'(begin (module module-without-contracts racket - (require rackunit "../main.rkt") - (define-syntax-rule (values->list values-expr) - (call-with-values (λ () values-expr) list)) + (require rackunit "../main.rkt" "check-values.rkt") . exprs) (require 'module-without-contracts) (module module-with-contracts racket - (require rackunit (submod "../main.rkt" safe)) - (define-syntax-rule (values->list values-expr) - (call-with-values (λ () values-expr) list)) + (require rackunit (submod "../main.rkt" safe) "check-values.rkt") . exprs) (require 'module-with-contracts))))])) @@ -95,14 +91,14 @@ (check-txexprs-equal? (txexpr* 'p '((key "value")) "foo" "bar") '(p ((key "value")) "foo" "bar")) - (check-equal? (values->list (txexpr->values '(p))) - (values->list (values 'p null null))) - (check-equal? (values->list (txexpr->values '(p "foo"))) - (values->list (values 'p null '("foo")))) - (check-equal? (values->list (txexpr->values '(p ((key "value"))))) - (values->list (values 'p '((key "value")) null))) - (check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) - (values->list (values 'p '((key "value")) '("foo")))) + (check-values=? (txexpr->values '(p)) + (values 'p null null)) + (check-values=? (txexpr->values '(p "foo")) + (values 'p null '("foo"))) + (check-values=? (txexpr->values '(p ((key "value")))) + (values 'p '((key "value")) null)) + (check-values=? (txexpr->values '(p ((key "value")) "foo")) + (values 'p '((key "value")) '("foo"))) (check-equal? (values->list (txexpr->values '(p))) (txexpr->list '(p)))