Fixes several issues with syntax/parse, and adds some tests.
* byte-regexp? values should not be considered 3D syntax. * hash? values are now allowed in serialized syntax properties with (template … #:properties (…)) * marshalling properties which were prefab structs called map on the result of struct->vector, changed it to struct->list as the struct "name" is always serializable.
This commit is contained in:
Georges Dupéron
parent
aead07b5de
commit
bece3e13e2
|
|
@ -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) ...))
|
||||
|
||||
|
|
|
|||
65
pkgs/racket-test/tests/stxparse/test-template-save-props.rkt
Normal file
65
pkgs/racket-test/tests/stxparse/test-template-save-props.rkt
Normal file
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -50,22 +50,92 @@
|
|||
(terx (1 (2 3)) (_:one _:two) "expected one")
|
||||
(terx ((1) 2) (_:one _:two) "expected two")
|
||||
|
||||
;; datum patterns
|
||||
(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 "here" "here"
|
||||
'ok
|
||||
#:pre ["there"] #: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 [_])
|
||||
|
||||
(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")
|
||||
(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)]))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -174,6 +174,7 @@ period.
|
|||
(char? x)
|
||||
(keyword? x)
|
||||
(regexp? x)
|
||||
(byte-regexp? x)
|
||||
(extflonum? x))
|
||||
fuel]
|
||||
[(symbol? x)
|
||||
|
|
|
|||
|
|
@ -83,7 +83,8 @@
|
|||
(keyword? datum)
|
||||
(bytes? datum)
|
||||
(char? datum)
|
||||
(regexp? datum))))
|
||||
(regexp? datum)
|
||||
(byte-regexp? datum))))
|
||||
|
||||
(define (id-predicate kw)
|
||||
(lambda (stx)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user