diff --git a/.gitignore b/.gitignore index be52d7f..bdf2d5d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,7 @@ # for Racket compiled/ +doc/ +*~ # for Mac OS X .DS_Store diff --git a/txexpr/info.rkt b/txexpr/info.rkt index fde4212..4acda4e 100644 --- a/txexpr/info.rkt +++ b/txexpr/info.rkt @@ -1,4 +1,4 @@ #lang info (define scribblings '(("scribblings/txexpr.scrbl" ()))) -(define compile-omit-paths '("tests.rkt")) \ No newline at end of file +(define compile-omit-paths '("test/tests.rkt")) diff --git a/txexpr/private/container.rkt b/txexpr/private/container.rkt new file mode 100644 index 0000000..f4c042d --- /dev/null +++ b/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))])) + diff --git a/txexpr/scribblings/txexpr.scrbl b/txexpr/scribblings/txexpr.scrbl index dcc69d5..ab8ee61 100644 --- a/txexpr/scribblings/txexpr.scrbl +++ b/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. diff --git a/txexpr/stx.rkt b/txexpr/stx.rkt new file mode 100644 index 0000000..5d59ef8 --- /dev/null +++ b/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) + +;; --------------------------------------------------------- + diff --git a/txexpr/test/check-values.rkt b/txexpr/test/check-values.rkt new file mode 100644 index 0000000..6a6bfe3 --- /dev/null +++ b/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))))]) + diff --git a/txexpr/test/test-txexpr-stx.rkt b/txexpr/test/test-txexpr-stx.rkt new file mode 100644 index 0000000..59712f4 --- /dev/null +++ b/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"))) + +;; --------------------------------------------------------- + diff --git a/txexpr/tests.rkt b/txexpr/test/tests.rkt similarity index 91% rename from txexpr/tests.rkt rename to txexpr/test/tests.rkt index d47af43..b5f61b7 100644 --- a/txexpr/tests.rkt +++ b/txexpr/test/tests.rkt @@ -10,15 +10,11 @@ (replace-context stx #'(begin (module module-without-contracts racket - (require rackunit "main.rkt") - (define-syntax-rule (values->list values-expr) - (call-with-values (λ () values-expr) list)) + (require rackunit "../main.rkt" "check-values.rkt") . exprs) (require 'module-without-contracts) (module module-with-contracts racket - (require rackunit (submod "main.rkt" safe)) - (define-syntax-rule (values->list values-expr) - (call-with-values (λ () values-expr) list)) + (require rackunit (submod "../main.rkt" safe) "check-values.rkt") . 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))) - (values->list (values 'p null null))) - (check-equal? (values->list (txexpr->values '(p "foo"))) - (values->list (values 'p null '("foo")))) - (check-equal? (values->list (txexpr->values '(p ((key "value"))))) - (values->list (values 'p '((key "value")) null))) - (check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) - (values->list (values 'p '((key "value")) '("foo")))) + (check-values=? (txexpr->values '(p)) + (values 'p null null)) + (check-values=? (txexpr->values '(p "foo")) + (values 'p null '("foo"))) + (check-values=? (txexpr->values '(p ((key "value")))) + (values 'p '((key "value")) null)) + (check-values=? (txexpr->values '(p ((key "value")) "foo")) + (values 'p '((key "value")) '("foo"))) (check-equal? (values->list (txexpr->values '(p))) (txexpr->list '(p)))