From 32e018f33344f2152c20af62670471800d40a7b8 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Tue, 11 Dec 2018 15:22:46 -0500 Subject: [PATCH 1/6] make txexpr a match-expander --- txexpr/base.rkt | 16 ++++- txexpr/private/define-provide-safe-match.rkt | 76 ++++++++++++++++++++ txexpr/test/contract-tests.rkt | 16 +++++ txexpr/test/tests.rkt | 13 ++++ 4 files changed, 118 insertions(+), 3 deletions(-) create mode 100644 txexpr/private/define-provide-safe-match.rkt create mode 100644 txexpr/test/contract-tests.rkt 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..fe093cc --- /dev/null +++ b/txexpr/private/define-provide-safe-match.rkt @@ -0,0 +1,76 @@ +#lang racket/base + +(provide define+provide+safe+match) + +(require racket/match + syntax/parse/define + (for-syntax racket/base + racket/syntax + syntax/parse + syntax/stx)) + +;; (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-parser define+provide+safe+match + + [(d (head . args) + contract:expr + value-body:expr ...+ + #:match-expander match-transformer:expr) + #:with fn-expr (syntax/loc this-syntax (λ args value-body ...)) + (syntax/loc this-syntax + (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) + #'(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 name) + + (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..b011631 --- /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"))) -- 2.25.1 From 9ddb20c53cd2b963a61dd65dd4b798014cad07f7 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Tue, 11 Dec 2018 21:20:37 -0500 Subject: [PATCH 2/6] avoid define-syntax-parser for older versions --- txexpr/private/define-provide-safe-match.rkt | 67 ++++++++++---------- 1 file changed, 34 insertions(+), 33 deletions(-) diff --git a/txexpr/private/define-provide-safe-match.rkt b/txexpr/private/define-provide-safe-match.rkt index fe093cc..4819ffe 100644 --- a/txexpr/private/define-provide-safe-match.rkt +++ b/txexpr/private/define-provide-safe-match.rkt @@ -3,7 +3,6 @@ (provide define+provide+safe+match) (require racket/match - syntax/parse/define (for-syntax racket/base racket/syntax syntax/parse @@ -32,45 +31,47 @@ [(stx-pair? stx) (datum->syntax stx (cons id (stx-cdr stx)) stx stx)]))) -(define-syntax-parser define+provide+safe+match +(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 this-syntax (λ args value-body ...)) - (syntax/loc this-syntax - (d head contract fn-expr #:match-expander match-transformer))] + [(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) - #'(begin - (define internal-name (let ([name value]) name)) + [(_ 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) + #'(begin + (define internal-name (let ([name value]) name)) - (begin-for-syntax - (define (make-name-match-transformer name) - (with-syntax ([name name]) match-transformer))) + (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))) + (define-match-expander name + (make-name-match-transformer (quote-syntax internal-name)) + (variable-like-transformer (quote-syntax internal-name))) - (provide name) + (provide name) - (module+ safe - (require racket/contract/base) + (module+ safe + (require racket/contract/base) - (define-module-boundary-contract contract-name internal-name contract - #:name-for-blame name) + (define-module-boundary-contract contract-name internal-name contract + #:name-for-blame name) - (define-match-expander name - (make-name-match-transformer (quote-syntax contract-name)) - (variable-like-transformer (quote-syntax contract-name))) + (define-match-expander name + (make-name-match-transformer (quote-syntax contract-name)) + (variable-like-transformer (quote-syntax contract-name))) - (provide name)))]) + (provide name)))]))) -- 2.25.1 From 83b4afa10f656e9fdc0e388561fb1beb3e466d4d Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Tue, 11 Dec 2018 21:32:52 -0500 Subject: [PATCH 3/6] avoid #:name-for-blame on older versions --- txexpr/private/define-provide-safe-match.rkt | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/txexpr/private/define-provide-safe-match.rkt b/txexpr/private/define-provide-safe-match.rkt index 4819ffe..61851b1 100644 --- a/txexpr/private/define-provide-safe-match.rkt +++ b/txexpr/private/define-provide-safe-match.rkt @@ -6,7 +6,8 @@ (for-syntax racket/base racket/syntax syntax/parse - syntax/stx)) + syntax/stx + version/utils)) ;; (define+provide+safe+match name-id ;; contract-expr @@ -50,6 +51,10 @@ #: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)) @@ -67,7 +72,7 @@ (require racket/contract/base) (define-module-boundary-contract contract-name internal-name contract - #:name-for-blame name) + name-for-blame ...) (define-match-expander name (make-name-match-transformer (quote-syntax contract-name)) -- 2.25.1 From 4a3defc7cc206e0e786f6ea1dd1a68f1762ea934 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Tue, 11 Dec 2018 21:39:35 -0500 Subject: [PATCH 4/6] update contract-tests.rkt --- txexpr/test/contract-tests.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/txexpr/test/contract-tests.rkt b/txexpr/test/contract-tests.rkt index b011631..c84173b 100644 --- a/txexpr/test/contract-tests.rkt +++ b/txexpr/test/contract-tests.rkt @@ -6,7 +6,7 @@ (module+ test (check-exn (regexp (string-append - "txexpr: contract violation\n" + "txexpr.*: contract violation\n" " *expected: txexpr-tag\\?\n" " *given: 4\n" " *in: the 1st argument.*" -- 2.25.1 From 4fdeee74299bcc8b9f679b28411d14df784b9426 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Tue, 11 Dec 2018 22:08:00 -0500 Subject: [PATCH 5/6] test on version 6.0.1 --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 3ffe69a..a2f20c4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,6 +10,7 @@ env: - 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 -- 2.25.1 From 49ab5ac3888ecda743e749ac991885294519988c Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 14 Dec 2018 12:03:36 -0800 Subject: [PATCH 6/6] Update .travis.yml --- .travis.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index a2f20c4..24bc75b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,7 +9,6 @@ env: global: - RACKET_DIR=~/racket matrix: - - RACKET_VERSION=6.0 - RACKET_VERSION=6.0.1 # - RACKET_VERSION=6.1 # - RACKET_VERSION=6.2 -- 2.25.1