You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
116 lines
4.5 KiB
Racket
116 lines
4.5 KiB
Racket
#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") (style "color: blue")))
|
|
(check-pred stx-txexpr-attrs? #'((id "top") (style "color: blue")))
|
|
(check-pred stx-txexpr-attrs? `((id "top") (style ,#'"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")))
|
|
|
|
;; ---------------------------------------------------------
|
|
|