separate out the error location tests
also, Rackety
This commit is contained in:
Robby Findler
parent
34c5b32746
commit
4bcb44c442
170
pkgs/redex-pkgs/redex-test/redex/tests/err-loc-test.rkt
Normal file
170
pkgs/redex-pkgs/redex-test/redex/tests/err-loc-test.rkt
Normal file
|
|
@ -0,0 +1,170 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(module util racket/base
|
||||||
|
(require setup/path-to-relative
|
||||||
|
racket/runtime-path
|
||||||
|
"test-util.rkt"
|
||||||
|
(for-syntax racket/base))
|
||||||
|
(provide exec-syntax-error-tests
|
||||||
|
exec-runtime-error-tests
|
||||||
|
syn-err-test-namespace)
|
||||||
|
|
||||||
|
(define-runtime-path this-dir ".")
|
||||||
|
|
||||||
|
(define syn-err-test-namespace (make-base-namespace))
|
||||||
|
(parameterize ([current-namespace syn-err-test-namespace])
|
||||||
|
(eval '(require redex/reduction-semantics)))
|
||||||
|
|
||||||
|
(define (syntax-error-test-setup thunk)
|
||||||
|
(parameterize ([current-namespace syn-err-test-namespace])
|
||||||
|
(with-handlers ([exn:fail:syntax?
|
||||||
|
(λ (exn)
|
||||||
|
(values (exn-message exn)
|
||||||
|
(map source-location (exn:fail:syntax-exprs exn))))])
|
||||||
|
(thunk))))
|
||||||
|
(define (runtime-error-test-setup thunk)
|
||||||
|
(define errortrace-key (dynamic-require 'errortrace/errortrace-key 'errortrace-key))
|
||||||
|
(parameterize ([current-compile ((dynamic-require 'errortrace/errortrace-lib
|
||||||
|
'make-errortrace-compile-handler))])
|
||||||
|
(with-handlers ([exn:fail?
|
||||||
|
(λ (exn)
|
||||||
|
(values (exn-message exn)
|
||||||
|
(let ([ans (let ([marks (continuation-mark-set->list
|
||||||
|
(exn-continuation-marks exn)
|
||||||
|
errortrace-key)])
|
||||||
|
(if (null? marks) '() (list (cdar marks))))])
|
||||||
|
(let loop ([ans ans])
|
||||||
|
(cond
|
||||||
|
[(pair? ans) (cons (loop (car ans)) (loop (cdr ans)))]
|
||||||
|
[(path? ans) (path->relative-string/library ans)]
|
||||||
|
[else ans])))))])
|
||||||
|
(thunk))))
|
||||||
|
|
||||||
|
(define ((exec-error-tests setup exec) path)
|
||||||
|
(for ([test (read-tests (build-path this-dir path))])
|
||||||
|
(exec-error-test test exec setup)))
|
||||||
|
(define exec-syntax-error-tests
|
||||||
|
(exec-error-tests syntax-error-test-setup expand))
|
||||||
|
(define exec-runtime-error-tests
|
||||||
|
(exec-error-tests runtime-error-test-setup eval))
|
||||||
|
|
||||||
|
(define (exec-error-test spec exec setup)
|
||||||
|
(define-values (file line expected-message expected-sources test)
|
||||||
|
(make-error-test spec))
|
||||||
|
(let-values ([(actual-message actual-sources)
|
||||||
|
(setup (λ () (begin (exec test) (values "" '()))))])
|
||||||
|
(test/proc (λ () actual-message) expected-message line file)
|
||||||
|
(test/proc (λ () actual-sources) expected-sources line file)))
|
||||||
|
|
||||||
|
(define (make-error-test spec)
|
||||||
|
(syntax-case spec ()
|
||||||
|
[(message named-pieces body)
|
||||||
|
(make-error-test (syntax/loc spec (message named-pieces () body)))]
|
||||||
|
[(message ([loc-name loc-piece] ...) ([non-loc-name non-loc-piece] ...) body)
|
||||||
|
(values (and (path? (syntax-source spec))
|
||||||
|
(path->relative-string/library (syntax-source spec)))
|
||||||
|
(syntax-line spec)
|
||||||
|
(syntax-e #'message)
|
||||||
|
(map source-location (syntax->list #'(loc-piece ...)))
|
||||||
|
#'(let-syntax ([subst
|
||||||
|
(λ (stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ loc-name ... non-loc-name ...)
|
||||||
|
#'body]))])
|
||||||
|
(subst loc-piece ... non-loc-piece ...)
|
||||||
|
(void)))]))
|
||||||
|
|
||||||
|
(define (source-location stx)
|
||||||
|
(list (and (path? (syntax-source stx))
|
||||||
|
(path->relative-string/library (syntax-source stx)))
|
||||||
|
(syntax-line stx)
|
||||||
|
(syntax-column stx)
|
||||||
|
(syntax-position stx)
|
||||||
|
(syntax-span stx)))
|
||||||
|
|
||||||
|
(define (read-tests path)
|
||||||
|
(call-with-input-file path
|
||||||
|
(λ (port)
|
||||||
|
(port-count-lines! port)
|
||||||
|
(let loop ()
|
||||||
|
(define test (read-syntax path port))
|
||||||
|
(if (eof-object? test)
|
||||||
|
'()
|
||||||
|
(cons test (loop))))))))
|
||||||
|
|
||||||
|
(require "test-util.rkt"
|
||||||
|
redex/reduction-semantics
|
||||||
|
(for-syntax racket/base)
|
||||||
|
'util)
|
||||||
|
|
||||||
|
(reset-count)
|
||||||
|
|
||||||
|
(parameterize ([current-namespace syn-err-test-namespace])
|
||||||
|
(eval (quote-syntax
|
||||||
|
(define-language syn-err-lang
|
||||||
|
(M (M M)
|
||||||
|
number)
|
||||||
|
(E hole
|
||||||
|
(E M)
|
||||||
|
(number E))
|
||||||
|
(X (number any)
|
||||||
|
(any number))
|
||||||
|
(Q (Q ...)
|
||||||
|
variable)
|
||||||
|
(UN (add1 UN)
|
||||||
|
zero)))))
|
||||||
|
|
||||||
|
|
||||||
|
(parameterize ([current-namespace (make-base-namespace)])
|
||||||
|
(eval '(require redex/reduction-semantics redex/pict))
|
||||||
|
(eval '(define-language L
|
||||||
|
(s a b c)))
|
||||||
|
(exec-runtime-error-tests "run-err-tests/define-union-language.rktd"))
|
||||||
|
|
||||||
|
(exec-syntax-error-tests "syn-err-tests/language-definition.rktd")
|
||||||
|
|
||||||
|
;; term with #:lang tests
|
||||||
|
(exec-syntax-error-tests "syn-err-tests/term-lang.rktd")
|
||||||
|
|
||||||
|
(parameterize ([current-namespace (make-base-namespace)])
|
||||||
|
(eval '(require redex/reduction-semantics))
|
||||||
|
(exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd"))
|
||||||
|
|
||||||
|
(exec-syntax-error-tests "syn-err-tests/metafunction-definition.rktd")
|
||||||
|
|
||||||
|
(exec-syntax-error-tests "syn-err-tests/relation-definition.rktd")
|
||||||
|
|
||||||
|
(exec-syntax-error-tests "syn-err-tests/reduction-relation-definition.rktd")
|
||||||
|
|
||||||
|
(exec-syntax-error-tests "syn-err-tests/redex-let.rktd")
|
||||||
|
|
||||||
|
(exec-syntax-error-tests "syn-err-tests/judgment-form-definition.rktd")
|
||||||
|
(exec-syntax-error-tests "syn-err-tests/judgment-holds.rktd")
|
||||||
|
|
||||||
|
(parameterize ([current-namespace (make-base-namespace)])
|
||||||
|
(eval '(require redex/reduction-semantics))
|
||||||
|
(eval '(define-language L
|
||||||
|
(s a b c)))
|
||||||
|
(eval '(define-judgment-form L
|
||||||
|
#:mode (ctc-fail I O)
|
||||||
|
#:contract (ctc-fail s s)
|
||||||
|
[(ctc-fail a q)]
|
||||||
|
[(ctc-fail b s)
|
||||||
|
(ctc-fail q s)]
|
||||||
|
[(ctc-fail c s)
|
||||||
|
(ctc-fail a s)]))
|
||||||
|
(exec-runtime-error-tests "run-err-tests/judgment-form-contracts.rktd")
|
||||||
|
(exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")
|
||||||
|
(exec-runtime-error-tests "run-err-tests/judgment-form-ellipses.rktd"))
|
||||||
|
|
||||||
|
|
||||||
|
(require redex/private/term
|
||||||
|
redex/private/lang-struct)
|
||||||
|
(define-namespace-anchor here)
|
||||||
|
(define ns (namespace-anchor->namespace here))
|
||||||
|
(parameterize ([current-namespace ns])
|
||||||
|
(exec-runtime-error-tests "run-err-tests/term.rktd"))
|
||||||
|
|
||||||
|
(exec-syntax-error-tests "syn-err-tests/term.rktd")
|
||||||
|
|
||||||
|
(print-tests-passed 'err-loc-test.rkt)
|
||||||
|
|
@ -24,6 +24,7 @@
|
||||||
"unify-tests.rkt"
|
"unify-tests.rkt"
|
||||||
"dq-test.rkt"
|
"dq-test.rkt"
|
||||||
"tl-test.rkt"
|
"tl-test.rkt"
|
||||||
|
"err-loc-test.rkt"
|
||||||
"term-test.rkt"
|
"term-test.rkt"
|
||||||
"rg-test.rkt"
|
"rg-test.rkt"
|
||||||
"gen-test.rkt"
|
"gen-test.rkt"
|
||||||
|
|
|
||||||
|
|
@ -1,112 +1,105 @@
|
||||||
(module term-test scheme
|
#lang racket/base
|
||||||
(require redex/private/term
|
(require redex/private/term
|
||||||
redex/private/lang-struct
|
redex/private/lang-struct
|
||||||
redex/private/matcher
|
redex/private/matcher
|
||||||
"test-util.rkt")
|
racket/function
|
||||||
|
"test-util.rkt")
|
||||||
(reset-count)
|
|
||||||
(test (term 1) 1)
|
|
||||||
(test (term (1 2)) (list 1 2))
|
|
||||||
(test (term (1 ,(+ 1 1))) (list 1 2))
|
|
||||||
(test (term-let ([x 1]) (term (x x))) (list 1 1))
|
|
||||||
(test (term-let ([(x ...) (list 1 2 3)]) (term ((y x) ...))) '((y 1) (y 2) (y 3)))
|
|
||||||
|
|
||||||
(test (term (in-hole (1 hole) 2)) (term (1 2)))
|
|
||||||
(test (term (in-hole (1 hole (hole x)) 2)) (term (1 2 (hole x))))
|
|
||||||
|
|
||||||
(test (equal? (term hole) (term hole)) #t)
|
|
||||||
(test (hole? (term hole)) #t)
|
|
||||||
(test (hole? (term (hole #f))) #f)
|
|
||||||
(test (hole? (term (hole the-name))) #f)
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (lambda (q) q)))
|
|
||||||
(term (f 1 2 3)))
|
|
||||||
(term (1 2 3)))
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
|
||||||
(term (f (zzzz))))
|
|
||||||
(term (y (zzzz))))
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (λ (x) (add1 (car x)))))
|
|
||||||
(term (f 2)))
|
|
||||||
(term 3))
|
|
||||||
|
|
||||||
(test (term-let ([((x ...) ...) (list (list 1 1) (list 2 2) (list 3 3))])
|
|
||||||
(term-let-fn ((f (λ (x) (car x))))
|
|
||||||
(term ((qq (f x) ...) ...))))
|
|
||||||
(term ((qq 1 1) (qq 2 2) (qq 3 3))))
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (lambda (x) (car x))))
|
|
||||||
(term (f hole)))
|
|
||||||
(term hole))
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
|
||||||
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
|
||||||
(term (g (f (zzzz))))))
|
|
||||||
(term (ff (y (zzzz)))))
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
|
||||||
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
|
||||||
(term (f (g (f (zzzz)))))))
|
|
||||||
(term (y (ff (y (zzzz))))))
|
|
||||||
|
|
||||||
(test (term-let ([x 1])
|
|
||||||
(term (x . y)))
|
|
||||||
(term (1 . y)))
|
|
||||||
|
|
||||||
(test (term-let ([(x ...) (list 3 2 1)])
|
|
||||||
(term (x ... . y)))
|
|
||||||
(term (3 2 1 . y)))
|
|
||||||
|
|
||||||
(test (term-let ([(x . y) (cons 1 2)])
|
|
||||||
(term (x y)))
|
|
||||||
(term (1 2)))
|
|
||||||
|
|
||||||
;; test that the implicit `plug' inserted by `in-hole'
|
|
||||||
;; deals with ellipses properly
|
|
||||||
(test (term-let ([(E ...) '(1 2 3)])
|
|
||||||
(term ((in-hole E x) ...)))
|
|
||||||
(term (1 2 3)))
|
|
||||||
|
|
||||||
(test (term-let-fn ((metafun car))
|
|
||||||
(term-let ((x 'whatever)
|
|
||||||
((y ...) '(4 5 6)))
|
|
||||||
(term (((metafun x) y) ...))))
|
|
||||||
'((whatever 4) (whatever 5) (whatever 6)))
|
|
||||||
|
|
||||||
(test (term-let-fn ((metafun (λ (x) (car x))))
|
|
||||||
(term-let (((y ...) '(4 5 6)))
|
|
||||||
(term ((y (metafun 1)) ...))))
|
|
||||||
'((4 1) (5 1) (6 1)))
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (compose add1 car)))
|
|
||||||
(term-let (((x ...) '(1 2 3))
|
|
||||||
((y ...) '(a b c)))
|
|
||||||
(term (((f x) y) ...))))
|
|
||||||
'((2 a) (3 b) (4 c)))
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (curry foldl + 0)))
|
|
||||||
(term-let (((x ...) '(1 2 3)))
|
|
||||||
(term (f x ...))))
|
|
||||||
6)
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (compose add1 car)))
|
|
||||||
(term-let (((x ...) '(1 2 3))
|
|
||||||
(((y ...) ...) '((a b c) (d e f) (g h i))))
|
|
||||||
(term ((((f x) y) ...) ...))))
|
|
||||||
'(((2 a) (3 b) (4 c)) ((2 d) (3 e) (4 f)) ((2 g) (3 h) (4 i))))
|
|
||||||
|
|
||||||
(test (term-let-fn ((f (curry foldl + 0)))
|
|
||||||
(term-let ((((x ...) ...) '((1 2) (3 4 5) (6))))
|
|
||||||
(term ((f x ...) ...))))
|
|
||||||
'(3 12 6))
|
|
||||||
|
|
||||||
(define-namespace-anchor here)
|
(reset-count)
|
||||||
(define ns (namespace-anchor->namespace here))
|
(test (term 1) 1)
|
||||||
|
(test (term (1 2)) (list 1 2))
|
||||||
(parameterize ([current-namespace ns])
|
(test (term (1 ,(+ 1 1))) (list 1 2))
|
||||||
(exec-runtime-error-tests "run-err-tests/term.rktd"))
|
(test (term-let ([x 1]) (term (x x))) (list 1 1))
|
||||||
|
(test (term-let ([(x ...) (list 1 2 3)]) (term ((y x) ...))) '((y 1) (y 2) (y 3)))
|
||||||
(exec-syntax-error-tests "syn-err-tests/term.rktd")
|
|
||||||
|
(test (term (in-hole (1 hole) 2)) (term (1 2)))
|
||||||
(print-tests-passed 'term-test.rkt))
|
(test (term (in-hole (1 hole (hole x)) 2)) (term (1 2 (hole x))))
|
||||||
|
|
||||||
|
(test (equal? (term hole) (term hole)) #t)
|
||||||
|
(test (hole? (term hole)) #t)
|
||||||
|
(test (hole? (term (hole #f))) #f)
|
||||||
|
(test (hole? (term (hole the-name))) #f)
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (lambda (q) q)))
|
||||||
|
(term (f 1 2 3)))
|
||||||
|
(term (1 2 3)))
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||||
|
(term (f (zzzz))))
|
||||||
|
(term (y (zzzz))))
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (λ (x) (add1 (car x)))))
|
||||||
|
(term (f 2)))
|
||||||
|
(term 3))
|
||||||
|
|
||||||
|
(test (term-let ([((x ...) ...) (list (list 1 1) (list 2 2) (list 3 3))])
|
||||||
|
(term-let-fn ((f (λ (x) (car x))))
|
||||||
|
(term ((qq (f x) ...) ...))))
|
||||||
|
(term ((qq 1 1) (qq 2 2) (qq 3 3))))
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (lambda (x) (car x))))
|
||||||
|
(term (f hole)))
|
||||||
|
(term hole))
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||||
|
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
||||||
|
(term (g (f (zzzz))))))
|
||||||
|
(term (ff (y (zzzz)))))
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||||
|
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
||||||
|
(term (f (g (f (zzzz)))))))
|
||||||
|
(term (y (ff (y (zzzz))))))
|
||||||
|
|
||||||
|
(test (term-let ([x 1])
|
||||||
|
(term (x . y)))
|
||||||
|
(term (1 . y)))
|
||||||
|
|
||||||
|
(test (term-let ([(x ...) (list 3 2 1)])
|
||||||
|
(term (x ... . y)))
|
||||||
|
(term (3 2 1 . y)))
|
||||||
|
|
||||||
|
(test (term-let ([(x . y) (cons 1 2)])
|
||||||
|
(term (x y)))
|
||||||
|
(term (1 2)))
|
||||||
|
|
||||||
|
;; test that the implicit `plug' inserted by `in-hole'
|
||||||
|
;; deals with ellipses properly
|
||||||
|
(test (term-let ([(E ...) '(1 2 3)])
|
||||||
|
(term ((in-hole E x) ...)))
|
||||||
|
(term (1 2 3)))
|
||||||
|
|
||||||
|
(test (term-let-fn ((metafun car))
|
||||||
|
(term-let ((x 'whatever)
|
||||||
|
((y ...) '(4 5 6)))
|
||||||
|
(term (((metafun x) y) ...))))
|
||||||
|
'((whatever 4) (whatever 5) (whatever 6)))
|
||||||
|
|
||||||
|
(test (term-let-fn ((metafun (λ (x) (car x))))
|
||||||
|
(term-let (((y ...) '(4 5 6)))
|
||||||
|
(term ((y (metafun 1)) ...))))
|
||||||
|
'((4 1) (5 1) (6 1)))
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (compose add1 car)))
|
||||||
|
(term-let (((x ...) '(1 2 3))
|
||||||
|
((y ...) '(a b c)))
|
||||||
|
(term (((f x) y) ...))))
|
||||||
|
'((2 a) (3 b) (4 c)))
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (curry foldl + 0)))
|
||||||
|
(term-let (((x ...) '(1 2 3)))
|
||||||
|
(term (f x ...))))
|
||||||
|
6)
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (compose add1 car)))
|
||||||
|
(term-let (((x ...) '(1 2 3))
|
||||||
|
(((y ...) ...) '((a b c) (d e f) (g h i))))
|
||||||
|
(term ((((f x) y) ...) ...))))
|
||||||
|
'(((2 a) (3 b) (4 c)) ((2 d) (3 e) (4 f)) ((2 g) (3 h) (4 i))))
|
||||||
|
|
||||||
|
(test (term-let-fn ((f (curry foldl + 0)))
|
||||||
|
(term-let ((((x ...) ...) '((1 2) (3 4 5) (6))))
|
||||||
|
(term ((f x ...) ...))))
|
||||||
|
'(3 12 6))
|
||||||
|
|
||||||
|
(print-tests-passed 'term-test.rkt)
|
||||||
|
|
|
||||||
|
|
@ -5,20 +5,11 @@
|
||||||
(for-syntax syntax/parse setup/path-to-relative)
|
(for-syntax syntax/parse setup/path-to-relative)
|
||||||
setup/path-to-relative
|
setup/path-to-relative
|
||||||
racket/runtime-path)
|
racket/runtime-path)
|
||||||
(provide test test-syn-err tests reset-count
|
(provide test tests reset-count
|
||||||
syn-err-test-namespace
|
|
||||||
print-tests-passed
|
print-tests-passed
|
||||||
equal/bindings?
|
equal/bindings?
|
||||||
test-contract-violation
|
test-contract-violation
|
||||||
test-runtime-err
|
test/proc)
|
||||||
exec-syntax-error-tests
|
|
||||||
exec-runtime-error-tests)
|
|
||||||
|
|
||||||
(define-runtime-path this-dir ".")
|
|
||||||
|
|
||||||
(define syn-err-test-namespace (make-base-namespace))
|
|
||||||
(parameterize ([current-namespace syn-err-test-namespace])
|
|
||||||
(eval '(require redex/reduction-semantics)))
|
|
||||||
|
|
||||||
(define (read-syntax-test path)
|
(define (read-syntax-test path)
|
||||||
(call-with-input-file path
|
(call-with-input-file path
|
||||||
|
|
@ -35,100 +26,6 @@
|
||||||
"<unknown file>")])
|
"<unknown file>")])
|
||||||
(syntax/loc stx (test/proc (λ () expected) got line fn)))]))
|
(syntax/loc stx (test/proc (λ () expected) got line fn)))]))
|
||||||
|
|
||||||
(define (syntax-error-test-setup thunk)
|
|
||||||
(parameterize ([current-namespace syn-err-test-namespace])
|
|
||||||
(with-handlers ([exn:fail:syntax?
|
|
||||||
(λ (exn)
|
|
||||||
(values (exn-message exn)
|
|
||||||
(map source-location (exn:fail:syntax-exprs exn))))])
|
|
||||||
(thunk))))
|
|
||||||
(define (runtime-error-test-setup thunk)
|
|
||||||
(define errortrace-key (dynamic-require 'errortrace/errortrace-key 'errortrace-key))
|
|
||||||
(parameterize ([current-compile ((dynamic-require 'errortrace/errortrace-lib 'make-errortrace-compile-handler))])
|
|
||||||
(with-handlers ([exn:fail?
|
|
||||||
(λ (exn)
|
|
||||||
(values (exn-message exn)
|
|
||||||
(let ([ans (let ([marks (continuation-mark-set->list
|
|
||||||
(exn-continuation-marks exn)
|
|
||||||
errortrace-key)])
|
|
||||||
(if (null? marks) '() (list (cdar marks))))])
|
|
||||||
(let loop ([ans ans])
|
|
||||||
(cond
|
|
||||||
[(pair? ans) (cons (loop (car ans)) (loop (cdr ans)))]
|
|
||||||
[(path? ans) (path->relative-string/library ans)]
|
|
||||||
[else ans])))))])
|
|
||||||
(thunk))))
|
|
||||||
|
|
||||||
(define ((exec-error-tests setup exec) path)
|
|
||||||
(for ([test (read-tests (build-path this-dir path))])
|
|
||||||
(exec-error-test test exec setup)))
|
|
||||||
(define exec-syntax-error-tests
|
|
||||||
(exec-error-tests syntax-error-test-setup expand))
|
|
||||||
(define exec-runtime-error-tests
|
|
||||||
(exec-error-tests runtime-error-test-setup eval))
|
|
||||||
|
|
||||||
(define (exec-error-test spec exec setup)
|
|
||||||
(define-values (file line expected-message expected-sources test)
|
|
||||||
(make-error-test spec))
|
|
||||||
(let-values ([(actual-message actual-sources)
|
|
||||||
(setup (λ () (begin (exec test) (values "" '()))))])
|
|
||||||
(test/proc (λ () actual-message) expected-message line file)
|
|
||||||
(test/proc (λ () actual-sources) expected-sources line file)))
|
|
||||||
|
|
||||||
(define (make-error-test spec)
|
|
||||||
(syntax-case spec ()
|
|
||||||
[(message named-pieces body)
|
|
||||||
(make-error-test (syntax/loc spec (message named-pieces () body)))]
|
|
||||||
[(message ([loc-name loc-piece] ...) ([non-loc-name non-loc-piece] ...) body)
|
|
||||||
(values (and (path? (syntax-source spec))
|
|
||||||
(path->relative-string/library (syntax-source spec)))
|
|
||||||
(syntax-line spec)
|
|
||||||
(syntax-e #'message)
|
|
||||||
(map source-location (syntax->list #'(loc-piece ...)))
|
|
||||||
#'(let-syntax ([subst
|
|
||||||
(λ (stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ loc-name ... non-loc-name ...)
|
|
||||||
#'body]))])
|
|
||||||
(subst loc-piece ... non-loc-piece ...)
|
|
||||||
(void)))]))
|
|
||||||
|
|
||||||
(define (source-location stx)
|
|
||||||
(list (and (path? (syntax-source stx))
|
|
||||||
(path->relative-string/library (syntax-source stx)))
|
|
||||||
(syntax-line stx)
|
|
||||||
(syntax-column stx)
|
|
||||||
(syntax-position stx)
|
|
||||||
(syntax-span stx)))
|
|
||||||
|
|
||||||
(define (read-tests path)
|
|
||||||
(call-with-input-file path
|
|
||||||
(λ (port)
|
|
||||||
(port-count-lines! port)
|
|
||||||
(let loop ()
|
|
||||||
(define test (read-syntax path port))
|
|
||||||
(if (eof-object? test)
|
|
||||||
'()
|
|
||||||
(cons test (loop)))))))
|
|
||||||
|
|
||||||
(define-syntax (test-syn-err stx)
|
|
||||||
#'(void))
|
|
||||||
|
|
||||||
(define-syntax (test-runtime-err stx)
|
|
||||||
#'(void)
|
|
||||||
#;
|
|
||||||
#`(parameterize ([current-compile (make-errortrace-compile-handler)])
|
|
||||||
#,(test-error-location
|
|
||||||
stx
|
|
||||||
eval
|
|
||||||
#'[exn:fail?
|
|
||||||
(λ (exn)
|
|
||||||
(values (exn-message exn)
|
|
||||||
(let ([marks (continuation-mark-set->list
|
|
||||||
(exn-continuation-marks exn)
|
|
||||||
errortrace-key)])
|
|
||||||
(if (null? marks) #f (list (cdar marks))))))])))
|
|
||||||
|
|
||||||
(define tests 0)
|
(define tests 0)
|
||||||
(define failures 0)
|
(define failures 0)
|
||||||
(define (reset-count)
|
(define (reset-count)
|
||||||
|
|
@ -137,8 +34,15 @@
|
||||||
|
|
||||||
(define (print-tests-passed filename)
|
(define (print-tests-passed filename)
|
||||||
(cond
|
(cond
|
||||||
|
[(= 0 tests)
|
||||||
|
(printf "~a: no tests were run.\n" filename)]
|
||||||
[(= 0 failures)
|
[(= 0 failures)
|
||||||
(printf "~a: all ~a tests passed.\n" filename tests)]
|
(printf "~a: ~a passed.\n"
|
||||||
|
filename
|
||||||
|
(case tests
|
||||||
|
[(1) "1 test"]
|
||||||
|
[(2) "both tests"]
|
||||||
|
[else (format "~a tests" tests)]))]
|
||||||
[else
|
[else
|
||||||
(printf "~a: ~a test~a failed.\n" filename failures (if (= 1 failures) "" "s"))]))
|
(printf "~a: ~a test~a failed.\n" filename failures (if (= 1 failures) "" "s"))]))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -8,21 +8,6 @@
|
||||||
|
|
||||||
(reset-count)
|
(reset-count)
|
||||||
|
|
||||||
(define-namespace-anchor this-namespace)
|
|
||||||
(parameterize ([current-namespace syn-err-test-namespace])
|
|
||||||
(eval (quote-syntax
|
|
||||||
(define-language syn-err-lang
|
|
||||||
(M (M M)
|
|
||||||
number)
|
|
||||||
(E hole
|
|
||||||
(E M)
|
|
||||||
(number E))
|
|
||||||
(X (number any)
|
|
||||||
(any number))
|
|
||||||
(Q (Q ...)
|
|
||||||
variable)
|
|
||||||
(UN (add1 UN)
|
|
||||||
zero)))))
|
|
||||||
|
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
|
|
@ -534,17 +519,6 @@
|
||||||
(test (redex-match empty-language number 'a) #f)
|
(test (redex-match empty-language number 'a) #f)
|
||||||
(test (redex-match empty-language (in-hole hole number) 'a) #f))
|
(test (redex-match empty-language (in-hole hole number) 'a) #f))
|
||||||
|
|
||||||
(parameterize ([current-namespace (make-base-namespace)])
|
|
||||||
(eval '(require redex/reduction-semantics redex/pict))
|
|
||||||
(eval '(define-language L
|
|
||||||
(s a b c)))
|
|
||||||
(exec-runtime-error-tests "run-err-tests/define-union-language.rktd"))
|
|
||||||
|
|
||||||
(exec-syntax-error-tests "syn-err-tests/language-definition.rktd")
|
|
||||||
|
|
||||||
;; term with #:lang tests
|
|
||||||
(exec-syntax-error-tests "syn-err-tests/term-lang.rktd")
|
|
||||||
|
|
||||||
(let ()
|
(let ()
|
||||||
(define-language L
|
(define-language L
|
||||||
(a number)
|
(a number)
|
||||||
|
|
@ -1194,22 +1168,19 @@
|
||||||
"")
|
"")
|
||||||
#rx"returned different results"))
|
#rx"returned different results"))
|
||||||
|
|
||||||
(parameterize ([current-namespace (make-base-namespace)])
|
|
||||||
(eval '(require redex/reduction-semantics))
|
|
||||||
(exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd"))
|
|
||||||
|
|
||||||
;; errors for not-yet-defined metafunctions
|
;; errors for not-yet-defined metafunctions
|
||||||
(test (parameterize ([current-namespace (make-empty-namespace)])
|
(test (let ([on (current-namespace)])
|
||||||
(namespace-attach-module (namespace-anchor->namespace this-namespace) 'redex/reduction-semantics)
|
(parameterize ([current-namespace (make-base-namespace)])
|
||||||
(namespace-require 'racket)
|
(namespace-attach-module on 'redex/reduction-semantics)
|
||||||
(eval '(module m racket
|
(namespace-require 'racket/base)
|
||||||
(require redex/reduction-semantics)
|
(eval '(module m racket
|
||||||
(term (q))
|
(require redex/reduction-semantics)
|
||||||
(define-language L)
|
(term (q))
|
||||||
(define-metafunction L [(q) ()])))
|
(define-language L)
|
||||||
(with-handlers ([exn:fail:redex? exn-message])
|
(define-metafunction L [(q) ()])))
|
||||||
(eval '(require 'm))
|
(with-handlers ([exn:fail:redex? exn-message])
|
||||||
#f))
|
(eval '(require 'm))
|
||||||
|
#f)))
|
||||||
"reference to metafunction q before its definition")
|
"reference to metafunction q before its definition")
|
||||||
(test (with-handlers ([exn:fail:redex? exn-message])
|
(test (with-handlers ([exn:fail:redex? exn-message])
|
||||||
(let ()
|
(let ()
|
||||||
|
|
@ -1219,7 +1190,6 @@
|
||||||
#f))
|
#f))
|
||||||
"reference to metafunction q before its definition")
|
"reference to metafunction q before its definition")
|
||||||
|
|
||||||
(exec-syntax-error-tests "syn-err-tests/metafunction-definition.rktd")
|
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
|
|
@ -1419,8 +1389,6 @@
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
(exec-syntax-error-tests "syn-err-tests/relation-definition.rktd")
|
|
||||||
|
|
||||||
; ;; ; ;; ;
|
; ;; ; ;; ;
|
||||||
; ; ; ; ;
|
; ; ; ; ;
|
||||||
; ;; ;; ;;; ;; ; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;;; ; ;;; ;;;;; ;;; ;;; ;; ;;
|
; ;; ;; ;;; ;; ; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;;; ; ;;; ;;;;; ;;; ;;; ;; ;;
|
||||||
|
|
@ -1829,8 +1797,6 @@
|
||||||
(test (apply-reduction-relation R (term (0 2 3 4 5))) '())
|
(test (apply-reduction-relation R (term (0 2 3 4 5))) '())
|
||||||
(test (apply-reduction-relation R (term (1 2 3 4 5 () (6) (7 8) (9 10 11)))) '(yes)))
|
(test (apply-reduction-relation R (term (1 2 3 4 5 () (6) (7 8) (9 10 11)))) '(yes)))
|
||||||
|
|
||||||
(exec-syntax-error-tests "syn-err-tests/reduction-relation-definition.rktd")
|
|
||||||
|
|
||||||
;; expect union with duplicate names to fail
|
;; expect union with duplicate names to fail
|
||||||
(test (with-handlers ((exn? (λ (x) 'passed)))
|
(test (with-handlers ((exn? (λ (x) 'passed)))
|
||||||
(union-reduction-relations
|
(union-reduction-relations
|
||||||
|
|
@ -2218,8 +2184,7 @@
|
||||||
1)
|
1)
|
||||||
(test
|
(test
|
||||||
(redex-let* L ([(n_1) '(1)] [n_1 1]) (term n_1))
|
(redex-let* L ([(n_1) '(1)] [n_1 1]) (term n_1))
|
||||||
1)
|
1))
|
||||||
(exec-syntax-error-tests "syn-err-tests/redex-let.rktd"))
|
|
||||||
|
|
||||||
|
|
||||||
;
|
;
|
||||||
|
|
@ -2238,9 +2203,6 @@
|
||||||
; ; ; ;
|
; ; ; ;
|
||||||
; ;; ;;;
|
; ;; ;;;
|
||||||
|
|
||||||
(exec-syntax-error-tests "syn-err-tests/judgment-form-definition.rktd")
|
|
||||||
(exec-syntax-error-tests "syn-err-tests/judgment-holds.rktd")
|
|
||||||
|
|
||||||
(let ()
|
(let ()
|
||||||
(define-language nats
|
(define-language nats
|
||||||
(n z (s n)))
|
(n z (s n)))
|
||||||
|
|
@ -2710,22 +2672,6 @@
|
||||||
[(J b)]))
|
[(J b)]))
|
||||||
(test (eval '(judgment-holds (J a))) #t))
|
(test (eval '(judgment-holds (J a))) #t))
|
||||||
|
|
||||||
(parameterize ([current-namespace (make-base-namespace)])
|
|
||||||
(eval '(require redex/reduction-semantics))
|
|
||||||
(eval '(define-language L
|
|
||||||
(s a b c)))
|
|
||||||
(eval '(define-judgment-form L
|
|
||||||
#:mode (ctc-fail I O)
|
|
||||||
#:contract (ctc-fail s s)
|
|
||||||
[(ctc-fail a q)]
|
|
||||||
[(ctc-fail b s)
|
|
||||||
(ctc-fail q s)]
|
|
||||||
[(ctc-fail c s)
|
|
||||||
(ctc-fail a s)]))
|
|
||||||
(exec-runtime-error-tests "run-err-tests/judgment-form-contracts.rktd")
|
|
||||||
(exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")
|
|
||||||
(exec-runtime-error-tests "run-err-tests/judgment-form-ellipses.rktd"))
|
|
||||||
|
|
||||||
|
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user