Add txexpr/stx module (#5)

.gitignore

@@ -1,5 +1,7 @@
 # for Racket
 compiled/
+doc/
+*~
 
 # for Mac OS X
 .DS_Store

txexpr/info.rkt

@@ -1,4 +1,4 @@
 #lang info
 
 (define scribblings '(("scribblings/txexpr.scrbl" ())))
-(define compile-omit-paths '("tests.rkt"))
+(define compile-omit-paths '("test/tests.rkt"))

txexpr/private/container.rkt

@@ -0,0 +1,43 @@
+#lang racket/base
+
+(provide txexpr?/recur
+         txexpr->values/attrs?)
+
+(require racket/list)
+
+;; A [TXcontainer T A E] is one of:
+;;  - (List* T A (Listof E))
+;;  - (Lxst* T (Listof E))
+;; Where A and E are disjoint.
+
+;; txexpr?/recur :
+;;   Any
+;;   [Any -> Bool : T]
+;;   [Any -> Bool : #:+ (and A (! E)) #:- (! A)]
+;;   [Any -> Bool : #:+ (and E (! A)) #:- (! E)]
+;;   ->
+;;   Bool
+;;   : [TXcontainer T A E]
+;; the attrs? predicate and the element? predicate should be disjoint
+(define (txexpr?/recur v tag? attrs? element?)
+  (and (list? v)
+       (not (empty? v))
+       (tag? (first v))
+       (cond [(and (not (empty? (rest v)))
+                   (attrs? (second v)))
+              (andmap element? (rest (rest v)))]
+             [else
+              (andmap element? (rest v))])))
+
+;; txexpr->values/attrs? :
+;;   [TXcontainer T A E]
+;;   [Any -> Bool : #:+ (and A (! E)) #:- (! A)]
+;;   ->
+;;   (values T A (Listof E))
+(define (txexpr->values/attrs? tx attrs?)
+  (cond [(and (not (empty? (rest tx)))
+              (attrs? (second tx)))
+         (values (first tx) (second tx) (rest (rest tx)))]
+        [else
+         (values (first tx) '() (rest tx))]))
+

txexpr/scribblings/txexpr.scrbl

@@ -3,7 +3,8 @@
 @; for documentation purposes, use the xexpr? from xml.
 @; the one in txexpr is just to patch over an issue with
 @; `valid-char?` in Racket 6.
-@(require scribble/eval (for-label racket txexpr xml rackunit))
+@(require scribble/eval
+          (for-label racket txexpr txexpr/stx xml rackunit))
 
 @(define my-eval (make-base-eval))
 @(my-eval `(require txexpr xml rackunit))
@@ -551,6 +552,110 @@ If ordering of attributes is relevant to your test, then just use @racket[check-
 ]
 
 
+@section{Syntax Versions of X-expressions}
+
+@(define stx-eval (make-base-eval))
+@(stx-eval `(require txexpr txexpr/stx xml rackunit))
+
+@defmodule[txexpr/stx]{
+This module provides functions for destructuring TX-expressions
+that might be wrapped in syntax objects.
+}
+
+@defproc[(stx-xexpr? [v any/c]) boolean?]{
+A predicate for X-expressions that might be wrapped in syntax
+(or have parts of them wrapped in syntax). It returns
+@racket[#true] for values that would become normal X-expressions
+with @racket[(syntax->datum (datum->syntax #f v))].
+
+@examples[#:eval stx-eval
+(stx-xexpr? "A leaf on the wind")
+(stx-xexpr? #'"A leaf in a bin")
+(stx-xexpr? '(div ((id "top")) "Hello" (p "World")))
+(stx-xexpr? #'(div ((id "top")) "Hello" (p "World")))
+(stx-xexpr? `(div ((id ,#'"top")) "Hello" ,#'(p "World")))
+]}
+
+@defproc[(stx-txexpr? [v any/c]) boolean?]{
+A predicate for Tagged X-expressions that might be wrapped in
+syntax. It returns @racket[#true] for values that become one
+of these with @racket[(syntax->datum (datum->syntax #f v))]:
+
+@racketgrammar*[
+#:literals (list)
+[txexpr (list tag attrs xexpr ...)
+        (list tag xexpr ...)]
+]
+
+@examples[#:eval stx-eval
+(stx-txexpr? "A block at the top")
+(stx-txexpr? '(div ((id "top")) "A block beneath a" (p "tag")))
+(stx-txexpr? #'(div ((id "top")) "A block beneath a" (p "tag")))
+(stx-txexpr? #'(div "A block beneath a" (p "tag")))
+]}
+
+@deftogether[[
+  @defproc[(stx-txexpr-tag? [v any/c]) boolean?]
+  @defproc[(stx-txexpr-attrs? [v any/c]) boolean?]
+]]{
+Predicates for sub-parts of TX-expressions that might be wrapped
+in syntax. There return @racket[#true] for values that become
+@racket[txexpr-tag?]s or @racket[txexpr-attrs?]s when unwrapped
+with @racket[(syntax->datum (datum->syntax #f v))].
+
+@examples[#:eval stx-eval
+(stx-txexpr-tag? 'div)
+(stx-txexpr-tag? #'div)
+(stx-txexpr-tag? 'analogous)
+(stx-txexpr-tag? #'analogous)
+(stx-txexpr-attrs? '())
+(stx-txexpr-attrs? #'())
+(stx-txexpr-attrs? '((id "top") (style "color: blue")))
+(stx-txexpr-attrs? #'((id "top") (style "color: blue")))
+(stx-txexpr-attrs? `((id "top") (style ,#'"color: blue")))
+]}
+
+@deftogether[[
+  @defproc[(stx-txexpr-tag [tx stx-txexpr?]) stx-txexpr-tag?]
+  @defproc[(stx-txexpr-attrs [tx stx-txexpr?]) stx-txexpr-attrs?]
+  @defproc[(stx-txexpr-elements [tx stx-txexpr?]) (listof stx-txexpr?)]
+]]{
+Accessor functions for the tag, attributes, and elements of a
+txexpr that might be wrapped in syntax. Note that these functions
+work whether the input is wrapped in syntax or not, and that
+the results may or may not be wrapped in syntax, depending on
+whether the input was wrapped.
+
+@examples[#:eval stx-eval
+(define tx1 '(div ((id "top")) "Hello" (p "World")))
+(define tx2 #'(div ((id "top")) "Hello" (p "World")))
+(stx-txexpr-tag tx1)
+(stx-txexpr-tag tx2)
+(stx-txexpr-attrs tx1)
+(stx-txexpr-attrs tx2)
+(stx-txexpr-elements tx1)
+(stx-txexpr-elements tx2)
+]}
+
+@deftogether[[
+  @defproc[(stx-txexpr->values [tx stx-txexpr?])
+           (values stx-txexpr-tag? stx-txexpr-attrs? (listof stx-txexpr?))]
+  @defproc[(stx-txexpr->list [tx stx-txexpr?])
+           (list/c stx-txexpr-tag? stx-txexpr-attrs? (listof stx-txexpr?))]
+]]{
+These functions break up a TX-expression into its components.
+@racket[stx-txexpr->values] returns them as three values, and
+@racket[stx-txexpr->list] returns them as a three-element list.
+
+@examples[#:eval stx-eval
+(stx-txexpr->values '(div))
+(stx-txexpr->list '(div))
+(stx-txexpr->values #'(div))
+(stx-txexpr->values #'(div "Hello" (p "World")))
+(stx-txexpr->values #'(div ((id "top")) "Hello" (p "World")))
+(stx-txexpr->values `(div ((id "top")) "Hello" ,#'(p "World")))
+]}
+
 @section{License & source code}
 
 This module is licensed under the LGPL.

txexpr/stx.rkt

@@ -0,0 +1,127 @@
+#lang racket/base
+
+(provide stx-xexpr?
+         stx-txexpr?
+         stx-txexpr-tag?
+         stx-txexpr-attrs?
+         stx-txexpr->values
+         stx-txexpr->list
+         stx-txexpr-tag
+         stx-txexpr-attrs
+         stx-txexpr-elements)
+
+(require syntax/stx
+         xml
+         "base.rkt"
+         "private/container.rkt")
+
+;; ---------------------------------------------------------
+
+;; Data Definitions
+
+;; A [Stx E] is one of:
+;;  - (Syntaxof E)
+;;  - E
+
+;; A StxXexpr is a [Stx XexprE]
+;; A StxTXexpr is a [Stx TXexprE]
+;; A StxTag is a [Stx Symbol]
+;; A StxAttrs is a (StxListof (StxList [Stx Symbol] [Stx String]))
+;; A StxElements is a (StxListof StxXexpr)
+
+;; A XexprE is one of:
+;;  - String
+;;  - TXexprE
+;;  - Symbol       ; for example 'nbsp representing ` `
+;;  - ValidChar    ; for example #x20 representing ` `
+;;  - CData        ; an instance of the `cdata` structure type from `xml`
+;;  - Misc         ; an instance of the `comment` or `p-i` structure types
+
+;; A TXexprE is one of:
+;;  - (list* StxTag StxAttrs StxElements)
+;;  - (list* StxTag StxElements)
+
+;; The types `StxAttrs` and `StxXexpr` are disjoint, as they
+;; need to be for this to be unambiguous.
+
+;; ---------------------------------------------------------
+
+;; Predicates
+
+;; Any -> Bool
+(define (stx-xexpr? v)
+  (stx-xexpr?/recur v stx-xexpr?))
+
+;; Any -> Bool
+(define (stx-txexpr? v)
+  (stx-txexpr?/recur v stx-xexpr?))
+
+;; Any [Any -> Bool] -> Bool
+(define (stx-xexpr?/recur v rec)
+  (cond
+    [(syntax? v) (stx-xexpr?/recur (syntax-e v) rec)]
+    [(pair? v) (stx-txexpr?/recur v rec)]
+    [else (xexpr?/recur v rec)]))
+
+;; Any [Any -> Bool] -> Bool
+;; the `rec` predicate should not overlap with `txexpr-attrs?`
+(define (xexpr?/recur v rec)
+  (cond
+    [(pair? v) (txexpr?/recur v txexpr-tag? txexpr-attrs? rec)]
+    [(string? v) #true]
+    [(symbol? v) #true]
+    [(integer? v) (valid-char? v)]
+    [(cdata? v) #true]
+    [(comment? v) #true]
+    [(p-i? v) #true]
+    [else #false]))
+
+;; Any [Any -> Bool] -> Bool
+;; the `rec` predicate should not overlap with
+;; `stx-txexpr-attrs?`
+(define (stx-txexpr?/recur v rec)
+  ;; Even if it's not stx, the cdr or cddr might be syntax.
+  ;; This flattens it so that the cdd...r is always a pair or empty.
+  (define lst (stx->list v))
+  (and lst (txexpr?/recur lst stx-txexpr-tag? stx-txexpr-attrs? rec)))
+
+;; Any -> Bool
+(define (stx-txexpr-tag? v)
+  (cond
+    [(syntax? v) (txexpr-tag? (syntax-e v))]
+    [else (txexpr-tag? v)]))
+
+;; Any -> Bool
+(define (stx-txexpr-attrs? v)
+  (txexpr-attrs? (syntax->datum (datum->syntax #f v))))
+
+;; ---------------------------------------------------------
+
+;; Accessors
+
+;; StxTxexpr -> (values StxTag StxAttrs StxElements)
+(define (stx-txexpr->values v)
+  (txexpr->values/attrs? (stx->list v) stx-txexpr-attrs?))
+
+;; StxTxexpr -> (List StxTag StxAttrs StxElements)
+(define (stx-txexpr->list v)
+  (define-values [tag attrs elements] (stx-txexpr->values v))
+  (list tag attrs elements))
+
+;; StxTxexpr -> StxTag
+(define (stx-txexpr-tag v)
+  (define-values [tag attrs elements] (stx-txexpr->values v))
+  tag)
+
+;; StxTxexpr -> StxAttrs
+(define (stx-txexpr-attrs v)
+  (define-values [tag attrs elements] (stx-txexpr->values v))
+  attrs)
+
+;; StxTxexpr -> StxElements
+(define (stx-txexpr-elements v)
+  (define-values [tag attrs elements] (stx-txexpr->values v))
+  elements)
+
+;; ---------------------------------------------------------
+

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

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