add tests for txexpr/stx
AlexKnauth
6 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")))
|
||||
|
||||
;; ---------------------------------------------------------
|
||||
|
||||
Loading…
Reference in New Issue