69 lines
2.0 KiB
Racket
69 lines
2.0 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base)
|
|
rackunit
|
|
(only-in "setup.rkt" convert-syntax-error tcerr)
|
|
racket/promise
|
|
racket/syntax
|
|
syntax/parse
|
|
syntax/parse/experimental/template)
|
|
|
|
;; See test-syntax.rkt for main syntax tests (now same as template).
|
|
;; This file has tests for features not exported by racket/base
|
|
;; (metafunctions).
|
|
|
|
(define-syntax (tc stx)
|
|
(syntax-case stx ()
|
|
[(tc expr expected)
|
|
#`(test-equal? (format "line ~s" #,(syntax-line stx))
|
|
(syntax->datum (convert-syntax-error expr))
|
|
expected)]))
|
|
|
|
(define-syntax (terx stx)
|
|
(syntax-case stx ()
|
|
[(terx expr err-rx ...)
|
|
#`(tcerr (format "line ~s" #,(syntax-line stx)) expr err-rx ...)]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
;; Common pattern variable definitions
|
|
;; (avoids having to have 'with-syntax' in every test case)
|
|
|
|
(define/with-syntax uu #'abc)
|
|
(define/with-syntax (aa ...) #'(a b c))
|
|
(define/with-syntax (xx ...) #'(x y z))
|
|
(define/with-syntax (nn ...) #'(1 2 3))
|
|
(define/with-syntax ((yy ...) ...) #'((1 2 3) (4 5 6) (7 8 9)))
|
|
|
|
(define/syntax-parse (~or* oo:nat _:id) #'x)
|
|
(define/syntax-parse ((~or* pp:nat _:id) ...) #'(a 1 b 2 3))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-template-metafunction (join stx)
|
|
(syntax-parse stx
|
|
[(join a:id b:id ...)
|
|
(datum->syntax #'a
|
|
(string->symbol
|
|
(apply string-append
|
|
(map symbol->string
|
|
(syntax->datum #'(a b ...)))))
|
|
stx)]))
|
|
|
|
(tc (template (join a b c))
|
|
'abc)
|
|
(tc (template ((xx (join tmp- xx)) ...))
|
|
'((x tmp-x) (y tmp-y) (z tmp-z)))
|
|
(tc (template ((xx (join uu - xx)) ...))
|
|
'((x abc-x) (y abc-y) (z abc-z)))
|
|
(tc (template ((xx (join aa xx)) ...))
|
|
'((x ax) (y by) (z cz)))
|
|
|
|
;; ============================================================
|
|
|
|
;; Error tests
|
|
|
|
(define-template-metafunction (bad-mf stx) 123)
|
|
|
|
(terx (template (bad-mf))
|
|
#rx"result of template metafunction was not syntax")
|