Skip to content
This repository has been archived by the owner on Sep 13, 2019. It is now read-only.

Commit

Permalink
Fixes several issues with syntax/parse, and adds some tests.
Browse files Browse the repository at this point in the history 
* 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.
  • Loading branch information
@SuzanneSoy @rmculpepper
SuzanneSoy authored and rmculpepper committed Jan 24, 2017
1 parent a9ae341 commit 6a07a3f
Show file tree
Hide file tree
Showing 7 changed files with 243 additions and 19 deletions.
30 changes: 30 additions & 0 deletions pkgs/racket-test/tests/stxparse/setup.rkt
View file
Expand Up @@ -8,6 +8,7 @@
(for-syntax racket/base))

(provide tok
t3d
terx
terx*
tcerr
Expand Down Expand Up @@ -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) ...))

Expand Down
65 changes: 65 additions & 0 deletions pkgs/racket-test/tests/stxparse/test-template-save-props.rkt
View 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)
24 changes: 24 additions & 0 deletions pkgs/racket-test/tests/stxparse/test-template-saved-props.rkt
View file
@@ -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
132 changes: 116 additions & 16 deletions pkgs/racket-test/tests/stxparse/test.rkt
View file
Expand Up @@ -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 [_])

(terx 1 2 "literal 2")
(terx (1 2) 1 "literal 1")
(terx (1 2) (1 1) "literal 1")
(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 [_])

(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: +"
Expand Down Expand Up @@ -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)]))
7 changes: 5 additions & 2 deletions racket/collects/syntax/parse/experimental/template.rkt
View file
Expand Up @@ -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
Expand Down Expand Up @@ -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)))
Expand Down
1 change: 1 addition & 0 deletions racket/collects/syntax/parse/private/3d-stx.rkt
View file
Expand Up @@ -174,6 +174,7 @@ period.
(char? x)
(keyword? x)
(regexp? x)
(byte-regexp? x)
(extflonum? x))
fuel]
[(symbol? x)
Expand Down
3 changes: 2 additions & 1 deletion racket/collects/syntax/parse/private/rep.rkt
View file
Expand Up @@ -83,7 +83,8 @@
(keyword? datum)
(bytes? datum)
(char? datum)
(regexp? datum))))
(regexp? datum)
(byte-regexp? datum))))

(define (id-predicate kw)
(lambda (stx)
Expand Down

0 comments on commit 6a07a3f

Please sign in to comment.