344 lines
9.7 KiB
Racket
344 lines
9.7 KiB
Racket
#lang scheme
|
|
(require rackunit
|
|
syntax/parse)
|
|
(require (for-syntax syntax/parse))
|
|
(provide (all-defined-out))
|
|
|
|
;; Error selection tests
|
|
|
|
(error-print-source-location #f)
|
|
|
|
(define-syntax-rule (terx s p stuff ...)
|
|
(terx* s [p] stuff ...))
|
|
|
|
(define-syntax-rule (terx* s [p ...] stuff ...)
|
|
(terx** s [[p] ...] stuff ...))
|
|
|
|
(define-syntax terx**
|
|
(syntax-parser
|
|
[(terx s [[p c ...] ...] (~optional (~seq #:term term) #:defaults ([term #'#f])) rx ...)
|
|
#`(test-case (format "line ~s: ~a match ~s for error"
|
|
'#,(syntax-line #'s)
|
|
's '(p ...))
|
|
(let ([exn (let/ec escape
|
|
(check-exn (lambda (exn)
|
|
(escape exn))
|
|
(lambda ()
|
|
(syntax-parse (quote-syntax s)
|
|
[p c ... (void)] ...))))])
|
|
(let ([msg (exn-message exn)]
|
|
[stxs (and (exn:fail:syntax? exn)
|
|
(exn:fail:syntax-exprs exn))])
|
|
(when 'term
|
|
(check-equal? (and (pair? stxs) (syntax->datum (car stxs))) 'term))
|
|
(erx rx (exn-message exn)) ... #t))
|
|
(void))]))
|
|
|
|
(define-syntax erx
|
|
(syntax-rules (not)
|
|
[(erx (not rx) msg)
|
|
(check (compose not regexp-match?) rx msg)]
|
|
[(erx rx msg)
|
|
(check regexp-match? rx msg)]))
|
|
|
|
;; ----
|
|
|
|
(terx (a b c 7) (x:id ...)
|
|
#:term 7
|
|
#rx"expected identifier")
|
|
|
|
;; ----
|
|
|
|
(terx* (1 2) [x:nat (y:id z:id)]
|
|
#:term 1
|
|
#rx"expected identifier")
|
|
|
|
;; --
|
|
|
|
(define-syntax-class bindings
|
|
(pattern ((var:id rhs:expr) ...)))
|
|
|
|
(terx* ((x 1 2)) [x:id bs:bindings]
|
|
#:term 2
|
|
#rx"unexpected term")
|
|
|
|
;; --
|
|
|
|
(terx ((a 1) (a 2))
|
|
((~or (~once ((~datum a) x) #:name "A clause")
|
|
(~optional ((~datum b) y) #:name "B clause"))
|
|
...)
|
|
;; #:term (a 2)
|
|
#rx"too many occurrences of A clause")
|
|
|
|
;; --
|
|
|
|
(define-syntax-class A
|
|
(pattern ((~datum a) x)))
|
|
(define-syntax-class B
|
|
(pattern ((~datum b) y)))
|
|
|
|
(terx ((a 1) (a 2))
|
|
((~or (~once a:A #:name "A clause")
|
|
(~optional b:B #:name "B clause"))
|
|
...)
|
|
#rx"too many occurrences of A clause")
|
|
|
|
(terx ((a 1 2) _)
|
|
((~or (~once a:A #:name "A clause")
|
|
(~optional b:B #:name "B clause"))
|
|
...)
|
|
#rx"unexpected term")
|
|
|
|
(terx ((b 1 2) _)
|
|
((~or (~once a:A #:name "A clause")
|
|
(~optional b:B #:name "B clause"))
|
|
...)
|
|
#rx"unexpected term")
|
|
|
|
;; Ellipses
|
|
|
|
(terx (a b c 4)
|
|
(x:id ...)
|
|
#rx"expected identifier")
|
|
|
|
;; Repetition constraints
|
|
|
|
(terx (1 2)
|
|
((~or (~once x:id #:name "identifier") n:nat) ...)
|
|
#rx"missing required occurrence of identifier")
|
|
|
|
(terx (1 a 2 b)
|
|
((~or (~once x:id #:name "identifier") n:nat) ...)
|
|
#rx"too many occurrences of identifier")
|
|
|
|
;; Roles
|
|
|
|
(terx 1
|
|
(~var x id #:role "var")
|
|
#rx"expected identifier for var")
|
|
(terx 1
|
|
(~describe #:opaque #:role "R" "D" (_))
|
|
#rx"expected D for R")
|
|
(terx 1
|
|
(~describe #:role "R" "D" (_))
|
|
#rx"expected D for R")
|
|
|
|
(test-case "#:describe #:role"
|
|
(check-exn #rx"expected identifier for var"
|
|
(lambda ()
|
|
(syntax-parse #'1
|
|
[x
|
|
#:declare x id #:role "var"
|
|
'ok]))))
|
|
|
|
(test-case "role coalescing"
|
|
(check-exn #rx"^m: expected identifier for thing$" ;; not repeated
|
|
(lambda ()
|
|
(syntax-parse #'(m 0 b)
|
|
[(_ x y:nat)
|
|
#:declare x id #:role "thing"
|
|
'a]
|
|
[(_ x y:id)
|
|
#:declare x id #:role "thing"
|
|
'b]))))
|
|
|
|
;; Expected more terms
|
|
|
|
(terx (1)
|
|
(a b)
|
|
#rx"expected more terms starting with any term$")
|
|
|
|
(terx (1)
|
|
(a b:id)
|
|
#rx"expected more terms starting with identifier$")
|
|
|
|
(terx (1)
|
|
(a (~describe "thing" b))
|
|
#rx"expected more terms starting with thing$")
|
|
|
|
(let ()
|
|
(define-syntax-class B1 #:description "B1" (pattern _:id))
|
|
(define-syntax-class B2 (pattern _:id))
|
|
(terx (1)
|
|
(a b:B1)
|
|
#rx"expected more terms starting with B1")
|
|
(terx (1)
|
|
(a b:B2)
|
|
#rx"expected more terms starting with B2"))
|
|
|
|
;; Post:
|
|
|
|
(terx "hello"
|
|
(~or a:nat (~post a:id))
|
|
#rx"expected identifier"
|
|
(not #rx"exact-nonnegative-integer"))
|
|
|
|
(terx "hello"
|
|
(~or a:nat (~and (~post (~fail "xyz")) _))
|
|
#rx"xyz"
|
|
(not #rx"exact-nonnegative-integer"))
|
|
|
|
(terx ("x")
|
|
(~or (a:nat) (~post (a:id)))
|
|
#rx"expected identifier"
|
|
(not #rx"exact-nonnegative-integer"))
|
|
|
|
;; sequential ~and
|
|
|
|
(terx 1
|
|
(~and (~or x:nat x:id) (~fail "never happy"))
|
|
#rx"never happy"
|
|
(not #rx"expected identifier"))
|
|
|
|
(terx** 1
|
|
([(~post (~or x:nat x:id)) #:fail-when #t "never happy"])
|
|
#rx"never happy"
|
|
(not #rx"expected identifier"))
|
|
|
|
;; indexes only compared within same ~and pattern
|
|
(terx** 1
|
|
([(~and (~fail "banana") _)]
|
|
[(~and x:nat (~fail "apple"))]
|
|
[(~and x:nat y:nat (~fail "orange"))])
|
|
#rx"apple"
|
|
#rx"orange"
|
|
#rx"banana")
|
|
|
|
;; default for min rep constraint
|
|
|
|
(terx ()
|
|
(x:id ...+)
|
|
#rx"expected more terms starting with identifier")
|
|
|
|
(let ()
|
|
(define-syntax-class thing (pattern _))
|
|
(terx ()
|
|
(x:thing ...+)
|
|
#rx"expected more terms starting with thing"))
|
|
|
|
;; ----------------------------------------
|
|
;; See "Simplification" from syntax/parse/private/runtime-report
|
|
|
|
(define-syntax-class X #:opaque (pattern 1))
|
|
(define-syntax-class Y #:opaque (pattern 2))
|
|
|
|
(let ()
|
|
;; Case 1: [A B X], [A B Y]
|
|
(define-syntax-class A (pattern (b:B _)))
|
|
(define-syntax-class B (pattern (x:X _)) (pattern (y:Y _)))
|
|
(terx ((3 _) _)
|
|
a:A
|
|
#:term 3
|
|
#rx"expected X or expected Y"
|
|
#rx"while parsing B.*while parsing A"))
|
|
|
|
(let ()
|
|
;; Case 2: [A X], [A]
|
|
(terx 1
|
|
(~describe "A" (x:id ...))
|
|
#rx"expected A"))
|
|
|
|
(let ()
|
|
;; Case 3: [t1:A t2:B t3:X], [t1:A t2:C t3:Y]
|
|
(define-syntax-class A (pattern (b:B _)) (pattern (c:C _)))
|
|
(define-syntax-class B (pattern (x:X _)))
|
|
(define-syntax-class C (pattern (y:Y _)))
|
|
(terx ((3 _) _)
|
|
a:A
|
|
#:term 3
|
|
#rx"expected X or expected Y"
|
|
(not #rx"while parsing [BC]")
|
|
#rx"while parsing A"))
|
|
|
|
(let ()
|
|
;; Case 4: [t1:A t2:B t4:X], [t1:A t3:C t4:Y]
|
|
(define-syntax-class A (pattern (b:B _)) (pattern (c:outerC _)))
|
|
(define-syntax-class B (pattern (b:innerB _)))
|
|
(define-syntax-class innerB #:description #f (pattern (x:X _)))
|
|
(define-syntax-class outerC #:description #f (pattern (c:C _)))
|
|
(define-syntax-class C (pattern (y:Y _)))
|
|
(terx (((3 _) _) _)
|
|
a:A
|
|
#:term 3
|
|
#rx"expected X or expected Y"
|
|
(not #rx"while parsing (B|C|innerB|outerC|X|Y)")
|
|
#rx"while parsing A"))
|
|
|
|
(let ()
|
|
;; Case 5: [t1:A t2:B t3:X], [t1:A t4:C t5:Y]
|
|
;; Need to use ~parse to get t3 != t5
|
|
(define-syntax-class A (pattern (b:B)) (pattern (c:outerC)))
|
|
(define-syntax-class B (pattern (b:innerB)))
|
|
(define-syntax-class innerB #:description #f (pattern _ #:with x:X #'4))
|
|
(define-syntax-class outerC #:description #f (pattern (c:C)))
|
|
(define-syntax-class C (pattern _ #:with y:Y #'5))
|
|
(terx (((3)))
|
|
a:A
|
|
#:term (((3)))
|
|
#rx"expected A"
|
|
(not #rx"while parsing (A|B|C|innerB|outerC|X|Y)")))
|
|
|
|
|
|
(let ()
|
|
;; Case 7: [_ t2:B t3:C _], [_ t3:C t2:B _]
|
|
;; Need to use ~parse; not sure if there's a realistic way for this to happen.
|
|
;; We will find the common frame, either B or C
|
|
(define stxB #'4)
|
|
(define stxC #'5)
|
|
(define-syntax-class A
|
|
(pattern (~and _ (~parse (~describe "B" (~and _ (~parse (~describe "C" 1) stxC))) stxB)))
|
|
(pattern (~and _ (~parse (~describe "C" (~and _ (~parse (~describe "B" 2) stxB))) stxC))))
|
|
(terx 3
|
|
a:A
|
|
;; #:term {4 or 5}
|
|
#rx"expected (B|C)"
|
|
#rx"while parsing A"
|
|
(not #rx"while parsing (B|C)")))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Regression tests
|
|
|
|
;; 4/16/2016, distilled from report by stchang
|
|
;; Want error message in second side clause to take precedence over
|
|
;; ellipsis-matching failures in first side clause.
|
|
|
|
(test-case "side-clauses order 1"
|
|
(check-exn #rx"unhappy about last number"
|
|
(lambda ()
|
|
(syntax-parse #'(1 2 3 4)
|
|
[(x:nat ...)
|
|
#:with (y ... z) #'(x ...)
|
|
#:fail-unless (>= (syntax->datum #'z) 10)
|
|
"unhappy about last number"
|
|
'ok]))))
|
|
|
|
(test-case "side-clauses order 2"
|
|
(check-exn (lambda (exn)
|
|
(and (regexp-match? #rx"unhappy about last number" (exn-message exn))
|
|
(exn:fail:syntax? exn)
|
|
(let* ([terms (exn:fail:syntax-exprs exn)]
|
|
[term (and (pair? terms) (syntax->datum (car terms)))])
|
|
(check-equal? term '4))))
|
|
(lambda ()
|
|
(syntax-parse #'(1 2 3 4)
|
|
[(x:nat ...)
|
|
#:with (y ... z) #'(x ...)
|
|
#:fail-when (and (< (syntax->datum #'z) 10) #'z)
|
|
"unhappy about last number"
|
|
'ok]))))
|
|
|
|
(test-case "side-clauses in different stxclasses don't compare"
|
|
(check-exn #rx"message1 or message2"
|
|
(lambda ()
|
|
(syntax-parse #'(1 2 3 4)
|
|
[(x:nat ...)
|
|
#:with (y ... z) #'(x ...)
|
|
#:fail-unless #f "message1" ;; (post 'g1 2)
|
|
'ok]
|
|
[(x:nat ...)
|
|
#:with (y ... z) #'(x ...)
|
|
#:with w #'whatever
|
|
#:fail-unless #f "message2" ;; (post 'g2 3), incomp w/ above
|
|
'ok]))))
|