diff --git a/.travis.yml b/.travis.yml index 3ffe69a..24bc75b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,7 +9,7 @@ env: global: - RACKET_DIR=~/racket matrix: - - RACKET_VERSION=6.0 + - RACKET_VERSION=6.0.1 # - RACKET_VERSION=6.1 # - RACKET_VERSION=6.2 - RACKET_VERSION=6.3 diff --git a/txexpr/base.rkt b/txexpr/base.rkt index a09e13e..cd1eced 100644 --- a/txexpr/base.rkt +++ b/txexpr/base.rkt @@ -1,5 +1,9 @@ #lang racket/base -(require racket/match sugar/define sugar/list sugar/coerce racket/string racket/list xml) +(require racket/match sugar/define sugar/list sugar/coerce + racket/string racket/list + xml + "private/define-provide-safe-match.rkt" + (for-syntax racket/base syntax/parse)) (provide cdata? cdata valid-char? xexpr->string xexpr?) ; from xml (provide empty) ; from racket/list @@ -124,9 +128,15 @@ (raise-argument-error func-name "txexpr-elements?" elements)) (txexpr-unsafe tag attrs elements)) -(define+provide+safe (txexpr tag [attrs null] [elements null]) +(define+provide+safe+match (txexpr tag [attrs null] [elements null]) ((txexpr-tag?) (txexpr-attrs? txexpr-elements?) . ->* . txexpr?) - (txexpr-base 'txexpr tag attrs elements)) + (txexpr-base 'txexpr tag attrs elements) + #:match-expander + (syntax-parser + [(_ tag-pat:expr + {~optional attrs-pat:expr #:defaults ([attrs-pat #'_])} + {~optional elements-pat:expr #:defaults ([elements-pat #'_])}) + #'(? txexpr? (app txexpr->values tag-pat attrs-pat elements-pat))])) (define+provide+safe (txexpr* tag [attrs null] . elements) ((txexpr-tag?) (txexpr-attrs?) #:rest txexpr-elements? . ->* . txexpr?) diff --git a/txexpr/private/define-provide-safe-match.rkt b/txexpr/private/define-provide-safe-match.rkt new file mode 100644 index 0000000..61851b1 --- /dev/null +++ b/txexpr/private/define-provide-safe-match.rkt @@ -0,0 +1,82 @@ +#lang racket/base + +(provide define+provide+safe+match) + +(require racket/match + (for-syntax racket/base + racket/syntax + syntax/parse + syntax/stx + version/utils)) + +;; (define+provide+safe+match name-id +;; contract-expr +;; value-expr +;; #:match-expander +;; match-transformer-expr) +;; +;; (define+provide+safe+match (head . args) +;; contract-expr +;; value-body-expr +;; ...+ +;; #:match-expander +;; match-transformer-expr) + +(begin-for-syntax + ;; Identifier -> [Syntax -> Syntax] + (define ((variable-like-transformer id) stx) + (cond + [(identifier? stx) + ; id, but with the source location of stx + (datum->syntax id (syntax-e id) stx id)] + [(stx-pair? stx) + (datum->syntax stx (cons id (stx-cdr stx)) stx stx)]))) + +(define-syntax define+provide+safe+match + (λ (stx) + (syntax-parse stx + + [(d (head . args) + contract:expr + value-body:expr ...+ + #:match-expander match-transformer:expr) + #:with fn-expr (syntax/loc stx (λ args value-body ...)) + (syntax/loc stx + (d head contract fn-expr #:match-expander match-transformer))] + + [(_ name:id + contract:expr + value:expr + #:match-expander match-transformer:expr) + #:with internal-name (generate-temporary #'name) + #:with contract-name (generate-temporary #'name) + #:with make-name-match-transformer (generate-temporary #'name) + #:with [name-for-blame ...] + (cond [(version<=? "6.8" (version)) #'[#:name-for-blame name]] + [else #'[]]) + + #'(begin + (define internal-name (let ([name value]) name)) + + (begin-for-syntax + (define (make-name-match-transformer name) + (with-syntax ([name name]) match-transformer))) + + (define-match-expander name + (make-name-match-transformer (quote-syntax internal-name)) + (variable-like-transformer (quote-syntax internal-name))) + + (provide name) + + (module+ safe + (require racket/contract/base) + + (define-module-boundary-contract contract-name internal-name contract + name-for-blame ...) + + (define-match-expander name + (make-name-match-transformer (quote-syntax contract-name)) + (variable-like-transformer (quote-syntax contract-name))) + + (provide name)))]))) + diff --git a/txexpr/test/contract-tests.rkt b/txexpr/test/contract-tests.rkt new file mode 100644 index 0000000..c84173b --- /dev/null +++ b/txexpr/test/contract-tests.rkt @@ -0,0 +1,16 @@ +#lang racket/base + +(require (submod "../main.rkt" safe)) +(module+ test + (require rackunit)) + +(module+ test + (check-exn (regexp (string-append + "txexpr.*: contract violation\n" + " *expected: txexpr-tag\\?\n" + " *given: 4\n" + " *in: the 1st argument.*" + " *blaming: .*test/contract-tests.rkt")) + (λ () (txexpr 4))) + ) + diff --git a/txexpr/test/tests.rkt b/txexpr/test/tests.rkt index 4c1fd4e..cedbbf8 100644 --- a/txexpr/test/tests.rkt +++ b/txexpr/test/tests.rkt @@ -108,6 +108,19 @@ (txexpr->list '(p ((key "value"))))) (check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) (txexpr->list '(p ((key "value")) "foo"))) + + ;; testing the match expander success + (check-match '(p ((key "value")) "leaf") + (txexpr 'p `((key ,val)) (list "leaf")) + (string=? val "value")) + + ;; testing the match expander failure + (check-false (match '(p ((key "value")) "something") + [(txexpr 'p _ (list "else")) #true] + [_ #false])) + (check-false (match "foo" + [(txexpr _ _ _) #true] + [_ #false])) (check-equal? (get-tag '(p ((key "value"))"foo" "bar" (em "square"))) 'p) (check-equal? (get-attrs '(p ((key "value"))"foo" "bar" (em "square"))) '((key "value")))