bece3e13e2
* 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.
155 lines
4.5 KiB
Racket
155 lines
4.5 KiB
Racket
#lang racket/base
|
|
(require rackunit
|
|
syntax/parse
|
|
(only-in syntax/parse/private/residual
|
|
attribute-binding)
|
|
syntax/parse/private/residual-ct ;; for attr functions
|
|
syntax/macro-testing
|
|
(for-syntax racket/base))
|
|
|
|
(provide tok
|
|
t3d
|
|
terx
|
|
terx*
|
|
tcerr
|
|
|
|
bound
|
|
s=
|
|
a=
|
|
convert-syntax-error)
|
|
|
|
#|
|
|
Testing forms
|
|
-------------
|
|
|
|
(tok stx-template pattern [#:pre pre-pattern ...] [#:post post-pattern ...])
|
|
-- pattern should succeed parsing stx (pre and post patterns should fail)
|
|
|
|
(terx stx-template pattern ErrorPattern ...)
|
|
(terx* stx-template (pattern ...) ErrorPattern ...)
|
|
where ErrorPattern is regexp | (not regexp)
|
|
-- pattern should fail with exn message matching every ErrorPattern
|
|
|
|
(tcerr tc-name-expr expr ErrorPattern ...)
|
|
-- delays syntax errors in expr until runtime, error msg must every pattern
|
|
|
|
|
|
Auxiliaries
|
|
-----------
|
|
|
|
(bound (name depth [syntax?]) ...)
|
|
-- checks that name is an attr w/ proper depth and syntax?
|
|
|
|
(s= stx-template sexpr)
|
|
-- checks that stx-template produces stx w/ datum equivalent to sexpr
|
|
|
|
(a= attr expr)
|
|
-- checks that attr has value equal to expr
|
|
|
|
|#
|
|
|
|
;; tok = test pattern ok
|
|
(define-syntax (tok stx)
|
|
(syntax-case stx ()
|
|
[(tok s p expr #:pre [pre-p ...] #:post [post-p ...])
|
|
#`(test-case (format "line ~s: ~s match ~s"
|
|
'#,(syntax-line #'s)
|
|
's 'p)
|
|
(syntax-parse (quote-syntax s)
|
|
[pre-p (error 'wrong-pattern "~s" 'pre-p)] ...
|
|
[p expr]
|
|
[post-p (error 'wrong-pattern "~s" 'post-p)] ...)
|
|
(void))]
|
|
[(tok s p expr)
|
|
#'(tok s p expr #:pre () #:post ())]
|
|
[(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) ...))
|
|
|
|
(define-syntax bound1
|
|
(syntax-rules ()
|
|
[(bound1 (name depth))
|
|
(let ([a (attribute-binding name)])
|
|
(check-pred attr? a)
|
|
(when (attr? a)
|
|
(check-equal? (attr-depth a) 'depth)))]
|
|
[(bound1 (name depth syntax?))
|
|
(let ([a (attribute-binding name)])
|
|
(check-pred attr? a)
|
|
(when (attr? a)
|
|
(check-equal? (attr-depth a) 'depth)
|
|
(check-equal? (attr-syntax? a) 'syntax?)))]))
|
|
|
|
(define-syntax-rule (s= t v)
|
|
(check-equal? (syntax->datum #'t) v))
|
|
|
|
(define-syntax-rule (a= a v)
|
|
(check-equal? (attribute a) v))
|
|
|
|
(define-syntax-rule (terx s p rx ...)
|
|
(terx* s [p] rx ...))
|
|
|
|
(define-syntax (terx* stx)
|
|
(syntax-case stx ()
|
|
[(terx s [p ...] rx ...)
|
|
#`(test-case (format "line ~s: ~a match ~s for error"
|
|
'#,(syntax-line #'s)
|
|
's '(p ...))
|
|
(check-exn (lambda (exn)
|
|
(erx rx (exn-message exn)) ... #t)
|
|
(lambda ()
|
|
(syntax-parse (quote-syntax s)
|
|
[p 'ok] ...)))
|
|
(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)]))
|
|
|
|
;; ====
|
|
|
|
(define-syntax-rule (tcerr name expr rx ...)
|
|
(test-case name
|
|
(check-exn (lambda (exn)
|
|
(define msg (exn-message exn))
|
|
(erx rx msg) ...
|
|
#t)
|
|
(lambda ()
|
|
(parameterize ((error-print-source-location #f))
|
|
(convert-syntax-error expr))))
|
|
(void)))
|