Add txexpr/stx module (#5)

v6.0-exception
Alex Knauth 5 years ago committed by Matthew Butterick
parent 77ea84153c
commit 87cd845136
  1. 2
      .gitignore
  2. 2
      txexpr/info.rkt
  3. 43
      txexpr/private/container.rkt
  4. 107
      txexpr/scribblings/txexpr.scrbl
  5. 127
      txexpr/stx.rkt
  6. 63
      txexpr/test/check-values.rkt
  7. 115
      txexpr/test/test-txexpr-stx.rkt
  8. 24
      txexpr/test/tests.rkt

2
.gitignore vendored

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

@ -1,4 +1,4 @@
#lang info
(define scribblings '(("scribblings/txexpr.scrbl" ())))
(define compile-omit-paths '("tests.rkt"))
(define compile-omit-paths '("test/tests.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))]))

@ -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.

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

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

@ -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)))
Loading…
Cancel
Save