diff --git a/pkgs/racket-test/tests/stxparse/setup.rkt b/pkgs/racket-test/tests/stxparse/setup.rkt index 857c4a194f..382956ba57 100644 --- a/pkgs/racket-test/tests/stxparse/setup.rkt +++ b/pkgs/racket-test/tests/stxparse/setup.rkt @@ -8,6 +8,7 @@ (for-syntax racket/base)) (provide tok + t3d terx terx* tcerr @@ -64,6 +65,35 @@ Auxiliaries [(tok s p) #'(tok s p 'ok)])) +(define-syntax (t3d stx) + (syntax-case stx () + [(_ #:pass [pass ...] #:fail [fail ...]) + (with-syntax ([(pass-line ...) (map syntax-line + (syntax->list #'(pass ...)))] + [(fail-line ...) (map syntax-line + (syntax->list #'(fail ...)))]) + #`(begin + (test-case (format "line ~s: ~a should not be 3D syntax" + 'pass-line + 'pass) + (check-not-exn + (λ () + (syntax-parse (quote-syntax ()) + [_ + #:with _ pass + 'ok])))) + ... + (test-case (format "line ~s: ~a should be rejected 3D syntax" + 'fail-line + 'fail) + (check-exn #px"implicit conversion to 3D syntax" + (λ () + (syntax-parse (quote-syntax ()) + [_ + #:with _ fail + 'ok])))) + ...))])) + (define-syntax-rule (bound b ...) (begin (bound1 b) ...)) diff --git a/pkgs/racket-test/tests/stxparse/test-template-save-props.rkt b/pkgs/racket-test/tests/stxparse/test-template-save-props.rkt new file mode 100644 index 0000000000..83330ca839 --- /dev/null +++ b/pkgs/racket-test/tests/stxparse/test-template-save-props.rkt @@ -0,0 +1,65 @@ +#lang racket +(require syntax/parse + syntax/parse/experimental/template) + +(begin-for-syntax + (struct prefab-st (a b c) #:prefab) + (struct st (a b c)) + (define (syntax-properties s . p*) + (if (null? p*) + s + (apply syntax-properties + (syntax-property s (car p*) (cadr p*)) + (cddr p*))))) + +(define-syntax (define-with-prop stx) + (syntax-case stx () + [(_ name) + #`(define (name) + (syntax-parse #'1 + [v + (template #,(syntax-properties #'(v) + 'null '() + 'string "str" + 'bytes #"by" + 'number 123.4 + 'boolean #t + 'char #\c + 'keyword '#:kw + 'regexp #rx".*" + 'pregexp #px".*" + 'byte-regexp #rx#".*" + 'byte-pregexp #px#".*" + 'box #&bx + 'symbol 'sym + 'pair '(a . b) + 'vector #(1 2 3) + 'hash #hash([a . 1] [b . 2]) + 'hasheq #hasheq([a . 1] [b . 2]) + 'hasheqv #hasheqv([a . 1] [b . 2]) + 'prefab-st (prefab-st 'x 'y 'z) + 'st (st 'x 'y 'z)) + #:properties (null + string + bytes + number + boolean + char + keyword + regexp + pregexp + byte-regexp + byte-pregexp + box + symbol + pair + vector + hash + hasheq + hasheqv + prefab-st + st))]))])) + +(define-with-prop get-syntax-with-saved-props) + +(provide get-syntax-with-saved-props) \ No newline at end of file diff --git a/pkgs/racket-test/tests/stxparse/test-template-saved-props.rkt b/pkgs/racket-test/tests/stxparse/test-template-saved-props.rkt new file mode 100644 index 0000000000..62270bd7f8 --- /dev/null +++ b/pkgs/racket-test/tests/stxparse/test-template-saved-props.rkt @@ -0,0 +1,24 @@ +#lang racket +(require "test-template-save-props.rkt" + rackunit) +(define s (get-syntax-with-saved-props)) +(check-equal? (syntax-property s 'null) '()) +(check-equal? (syntax-property s 'string) "str") +(check-equal? (syntax-property s 'bytes) #"by") +(check-equal? (syntax-property s 'number) 123.4) +(check-equal? (syntax-property s 'boolean) #t) +(check-equal? (syntax-property s 'char) #\c) +(check-equal? (syntax-property s 'keyword) '#:kw) +(check-equal? (syntax-property s 'regexp) #rx".*") +(check-equal? (syntax-property s 'pregexp) #px".*") +(check-equal? (syntax-property s 'byte-regexp) #rx#".*") +(check-equal? (syntax-property s 'byte-pregexp) #px#".*") +(check-equal? (syntax-property s 'box) #&bx) +(check-equal? (syntax-property s 'symbol) 'sym) +(check-equal? (syntax-property s 'pair) '(a . b)) +(check-equal? (syntax-property s 'vector) #(1 2 3)) +(check-equal? (syntax-property s 'hash) #hash([a . 1] [b . 2])) +(check-equal? (syntax-property s 'hasheq) #hasheq([a . 1] [b . 2])) +(check-equal? (syntax-property s 'hasheqv) #hasheqv([a . 1] [b . 2])) +(check-equal? (syntax-property s 'prefab-st) #s(prefab-st x y z)) +(check-equal? (syntax-property s 'st) #f) ; st is not serializable, should be #f \ No newline at end of file diff --git a/pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-test/tests/stxparse/test.rkt index 0d8804a481..9a79da04ba 100644 --- a/pkgs/racket-test/tests/stxparse/test.rkt +++ b/pkgs/racket-test/tests/stxparse/test.rkt @@ -50,22 +50,92 @@ (terx (1 (2 3)) (_:one _:two) "expected one") (terx ((1) 2) (_:one _:two) "expected two") -;; datum patterns -(tok 1 1 - 'ok) -(tok 1 _ - #t - #:pre [2] #:post []) -(tok "here" "here" - 'ok - #:pre ["there"] #:post []) -(tok #f #f - 'ok - #:pre [#t 0] #:post [_]) +(test-case "datum patterns" + (tok () () + 'ok + #:pre [(_) 0] #:post []) + (tok "here" "here" + 'ok + #:pre ["there" #"here" 0] #:post []) + (tok #"byte" #"byte" + 'ok + #:pre [#"other" "byte" 0] #:post []) + (tok 1 1 + 'ok) + (tok 1 _ + #t + #:pre [2] #:post []) + (tok #f #f + 'ok + #:pre [#t 0] #:post [_]) + (tok #\c #\c + 'ok + #:pre [#\d "c" 0] #:post [_]) + (tok #:kw #:kw + 'ok + #:pre [#:other {~datum kw} "kw" 0] #:post [_]) + (tok #rx".*" #rx".*" + 'ok + #:pre [#rx"." #px".*" #rx#".*" #px#".*"] #:post [_]) + (tok #px".*" #px".*" + 'ok + #:pre [#px"." #rx".*" #rx#".*" #px#".*"] #:post [_]) + (tok #rx#".*" #rx#".*" + 'ok + #:pre [#rx#"." #px#".*" #rx".*" #px".*"] #:post [_]) + (tok #px#".*" #px#".*" + 'ok + #:pre [#px#"." #rx#".*" #rx".*" #px".*"] #:post [_]) + (tok #&"box" #&"box" + 'ok + #:pre [#&"other" {~datum #&_} 0] #:post [_]) + (tok #&_ #&_ + 'ok + #:pre [{~datum #&other}] #:post [_]) + (tok #&xyz {~datum #&xyz} + 'ok) + (tok xyz {~datum xyz} + 'ok) + (tok (a . b) {~datum (a . b)} + 'ok + #:pre [{~datum (_ . _)}] #:post [_]) + (tok (a b c) {~datum (a b c)} + 'ok + #:pre [{~datum (_ _ _)} {~datum (_ . _)}] #:post [_]) -(terx 1 2 "literal 2") -(terx (1 2) 1 "literal 1") -(terx (1 2) (1 1) "literal 1") + (tok #(1 2 3) {~datum #(1 2 3)} + 'ok + #:pre [{~datum #(_ _ _)}] #:post [_]) + (tok #hash([a . 1] [b . 2]) {~datum #hash([b . 2] [a . 1])} + 'ok + #:pre [{~datum #hash([_ . 1] [_ . 2])} + {~datum #hash([a . _] [b . _])} + {~datum #hasheq([a . 1] [b . 2])} + {~datum #hasheqv([a . 1] [b . 2])}] + #:post [_]) + (tok #hasheq([a . 1] [b . 2]) {~datum #hasheq([b . 2] [a . 1])} + 'ok + #:pre [{~datum #hasheq([_ . 1] [_ . 2])} + {~datum #hasheq([a . _] [b . _])} + {~datum #hash([a . 1] [b . 2])} + {~datum #hasheqv([a . 1] [b . 2])}] + #:post [_]) + (tok #hasheqv([a . 1] [b . 2]) {~datum #hasheqv([b . 2] [a . 1])} + 'ok + #:pre [{~datum #hasheqv([_ . 1] [_ . 2])} + {~datum #hasheqv([a . _] [b . _])} + {~datum #hasheq([a . 1] [b . 2])} + {~datum #hash([a . 1] [b . 2])}] + #:post [_]) + (tok #s(prefab-st x y z) {~datum #s(prefab-st x y z)} + 'ok + #:pre [{~datum #s(prefab-st _ _ _)}] #:post [_]) + (tok #s(prefab-st x y z) #s(prefab-st _ _ _) + 'ok) + + (terx 1 2 "literal 2") + (terx (1 2) 1 "literal 1") + (terx (1 2) (1 1) "literal 1")) ;; literal patterns (test-case "literals: +" @@ -702,3 +772,33 @@ ;; nullable but bounded EH pattern ok (thanks Alex Knauth) (7/2016) (tok (1 2 3) ((~once (~seq)) ... n:nat ...) 'ok) (tok (1 2 3) ((~once (~or (~seq a:id) (~seq))) ... x y z) 'ok) + +(struct s-3d () #:transparent) +(test-case "3D syntax checks" + (t3d #:pass ['() + '"here" + '#"byte" + '1 + '123.4 + '+inf.f + '#t + '#f + '#\c + '#:kw + '#rx".*" + '#px".*" + '#rx#".*" + '#px#".*" + '#&"box" + '#&box + 'xyz + '(a . b) + '(a b c) + '#(1 2 3) + '#s(prefab-st x y z) + '#hash([a . 1] [b . 2]) + '#hasheq([a . 1] [b . 2]) + '#hasheqv([a . 1] [b . 2])] + #:fail [(s-3d) + (vector-immutable 1 (s-3d) 3) + (list 'a (s-3d) 'c)])) diff --git a/racket/collects/syntax/parse/experimental/template.rkt b/racket/collects/syntax/parse/experimental/template.rkt index ce8c864a90..4f0b2d3f74 100644 --- a/racket/collects/syntax/parse/experimental/template.rkt +++ b/racket/collects/syntax/parse/experimental/template.rkt @@ -4,7 +4,8 @@ racket/syntax syntax/parse/private/minimatch racket/private/stx ;; syntax/stx - racket/private/sc) + racket/private/sc + racket/struct) syntax/parse/private/residual "private/substitute.rkt") (provide template @@ -403,11 +404,13 @@ instead of integers and integer vectors. (char? v) (keyword? v) (regexp? v) + (byte-regexp? v) (and (box? v) (quotable? (unbox v))) (and (symbol? v) (symbol-interned? v)) (and (pair? v) (quotable? (car v)) (quotable? (cdr v))) (and (vector? v) (andmap quotable? (vector->list v))) - (and (prefab-struct-key v) (andmap quotable? (struct->vector v))))) + (and (hash? v) (andmap quotable? (hash->list v))) + (and (prefab-struct-key v) (andmap quotable? (struct->list v))))) (define (cons-guide g1 g2) (if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2))) diff --git a/racket/collects/syntax/parse/private/3d-stx.rkt b/racket/collects/syntax/parse/private/3d-stx.rkt index e94dbe6af3..b5083d5f03 100644 --- a/racket/collects/syntax/parse/private/3d-stx.rkt +++ b/racket/collects/syntax/parse/private/3d-stx.rkt @@ -174,6 +174,7 @@ period. (char? x) (keyword? x) (regexp? x) + (byte-regexp? x) (extflonum? x)) fuel] [(symbol? x) diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index e2995ea83b..cc32c0459f 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -83,7 +83,8 @@ (keyword? datum) (bytes? datum) (char? datum) - (regexp? datum)))) + (regexp? datum) + (byte-regexp? datum)))) (define (id-predicate kw) (lambda (stx)