suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse/experimental/template: fix ellipses/depth rules again

Browse Source
This commit is contained in:
Ryan Culpepper 2012-09-18 23:34:41 -04:00
parent 018f16d30c
commit ddcafbc6d1
2 changed files with 17 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/syntax/parse/experimental/template.rkt
View File

@ -3,6 +3,7 @@
racket/set racket/set
racket/syntax racket/syntax
syntax/parse/private/minimatch syntax/parse/private/minimatch
racket/private/stx ;; syntax/stx
racket/private/sc) racket/private/sc)
syntax/parse/private/residual syntax/parse/private/residual
"private/substitute.rkt") "private/substitute.rkt")
@ -147,8 +148,7 @@ instead of integers and integer vectors.
|# |#
(begin-for-syntax (begin-for-syntax
(struct pvar (sm dd) #:prefab) (struct pvar (sm dd) #:prefab))
(define (pvar/dd=0? x) (and (pvar? x) (equal? (pvar-dd x) 0))))
;; ============================================================ ;; ============================================================
@ -350,9 +350,12 @@ instead of integers and integer vectors.
(parse-t tail depth esc?)]) (parse-t tail depth esc?)])
(when (set-empty? hdrivers) (when (set-empty? hdrivers)
(wrong-syntax #'head "no pattern variables in term before ellipsis")) (wrong-syntax #'head "no pattern variables in term before ellipsis"))
(when (set-empty? (set-filter hdrivers pvar/dd=0?)) (when (set-empty? (set-filter hdrivers (pvar/dd<=? depth)))
;; FIXME: improve error message? ;; FIXME: improve error message?
(wrong-syntax #'DOTS "too many ellipses in template")) (let ([bad-dots
;; select the nestingth (last) ellipsis as the bad one
(stx-car (stx-drop nesting t))])
(wrong-syntax bad-dots "too many ellipses in template")))
(wrap-props t (wrap-props t
(set-union hdrivers tdrivers) (set-union hdrivers tdrivers)
;; pre-guide hdrivers is (listof (setof pvar)) ;; pre-guide hdrivers is (listof (setof pvar))
@ -473,4 +476,8 @@ instead of integers and integer vectors.
(match x (match x
[(pvar sm dd) (and dd (<= dd expected-dd))] [(pvar sm dd) (and dd (<= dd expected-dd))]
[_ #f])) [_ #f]))
(define (stx-drop n x)
(cond [(zero? n) x]
[else (stx-drop (sub1 n) (stx-cdr x))]))
) )

6
collects/tests/stxparse/test-template.rkt
View File

@ -108,6 +108,9 @@
;; compatible with syntax ;; compatible with syntax
(syntax->datum #'(((uu aa yy) ...) ...))) (syntax->datum #'(((uu aa yy) ...) ...)))
(tc (template ((aa ... xx) ...))
'((a b c x) (a b c y) (a b c z)))
;; liberal depth rules with consecutive ellipses ;; liberal depth rules with consecutive ellipses
(tc (template ((aa yy) ... ...)) (tc (template ((aa yy) ... ...))
@ -170,6 +173,9 @@
(terx (template (uu ...)) (terx (template (uu ...))
#rx"too many ellipses in template") #rx"too many ellipses in template")
(terx (template ((aa ... uu) ...))
#rx"too many ellipses in template")
(terx (template aa) (terx (template aa)
#rx"pattern variable used at wrong ellipsis depth") #rx"pattern variable used at wrong ellipsis depth")