add tests for txexpr/stx

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

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

txexpr/test/tests.rkt

@@ -10,15 +10,11 @@
        (replace-context stx
                         #'(begin
                             (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)
                             (require 'module-without-contracts)
                             (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)
                             (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))) 
+ (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))) 
                (txexpr->list '(p)))