add tests for txexpr/stx

pull/5/head
AlexKnauth 7 years ago
parent 2ec55051ba
commit 16ae7793d3

@ -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))))])

@ -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")))
;; ---------------------------------------------------------

@ -10,15 +10,11 @@
(replace-context stx (replace-context stx
#'(begin #'(begin
(module module-without-contracts racket (module module-without-contracts racket
(require rackunit "../main.rkt") (require rackunit "../main.rkt" "check-values.rkt")
(define-syntax-rule (values->list values-expr)
(call-with-values (λ () values-expr) list))
. exprs) . exprs)
(require 'module-without-contracts) (require 'module-without-contracts)
(module module-with-contracts racket (module module-with-contracts racket
(require rackunit (submod "../main.rkt" safe)) (require rackunit (submod "../main.rkt" safe) "check-values.rkt")
(define-syntax-rule (values->list values-expr)
(call-with-values (λ () values-expr) list))
. exprs) . exprs)
(require 'module-with-contracts))))])) (require 'module-with-contracts))))]))
@ -95,14 +91,14 @@
(check-txexprs-equal? (txexpr* 'p '((key "value")) "foo" "bar") (check-txexprs-equal? (txexpr* 'p '((key "value")) "foo" "bar")
'(p ((key "value")) "foo" "bar")) '(p ((key "value")) "foo" "bar"))
(check-equal? (values->list (txexpr->values '(p))) (check-values=? (txexpr->values '(p))
(values->list (values 'p null null))) (values 'p null null))
(check-equal? (values->list (txexpr->values '(p "foo"))) (check-values=? (txexpr->values '(p "foo"))
(values->list (values 'p null '("foo")))) (values 'p null '("foo")))
(check-equal? (values->list (txexpr->values '(p ((key "value"))))) (check-values=? (txexpr->values '(p ((key "value"))))
(values->list (values 'p '((key "value")) null))) (values 'p '((key "value")) null))
(check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) (check-values=? (txexpr->values '(p ((key "value")) "foo"))
(values->list (values 'p '((key "value")) '("foo")))) (values 'p '((key "value")) '("foo")))
(check-equal? (values->list (txexpr->values '(p))) (check-equal? (values->list (txexpr->values '(p)))
(txexpr->list '(p))) (txexpr->list '(p)))

Loading…
Cancel
Save