(module tl-test mzscheme
(require "../reduction-semantics.ss")
(define-syntax (test stx)
(syntax-case stx ()
[(_ expected got)
(with-syntax ([line (syntax-line stx)]
[col (syntax-column stx)])
(syntax (test/proc (λ () expected) got line col)))]))
(define tests 0)
(define (test/proc run expected line col)
(let ([got (run)])
(set! tests (+ tests 1))
(unless (equal? got expected)
(error 'test/proc "line ~a col ~a got ~s expected ~s"
line col
got
expected))))
(define grammar
(language (M (M M)
number)
(E hole
(E M)
(number E))
(X (number any)
(any number))))
(define add (reduction grammar
(number_1 number_2)
(+ (term number_1) (term number_2))))
(test (reduce (list add) '(2 3)) (list 5))
(test (reduce (list (context-closure add grammar 'E))
'(2 3))
(list 5))
(test (reduce (list (compatible-closure add grammar 'M))
'(2 3))
(list 5))
(test (reduce (list (compatible-closure add grammar 'M))
'((2 3) (4 5)))
(list '(5 (4 5))
'((2 3) 9)))
(test (reduce/tag-with-reduction (list add) '(2 3))
(list (list add '5)))
(test ((language->predicate grammar 'M) '(1 2))
#t)
(test ((language->predicate grammar 'M) '(3))
#f)
(define f
(metafunction
grammar
[(side-condition (number_1 number_2)
(< (term number_1)
(term number_2)))
x]
[(number 1) y]
[(number_1 2) ,(+ (term number_1) 2)]
[(4 4) q]
[(4 4) r]))
(define g
(metafunction
grammar
[X x]))
(test (f '(1 17)) 'x)
(test (f '(11 1)) 'y)
(test (f '(11 2)) 13)
(test (f '(4 4)) 'q)
(test (with-handlers ((exn? (λ (x) 'exn-raised))) (g '(4 4)) 'no-exn)
'exn-raised)
(test (with-handlers ((exn? (λ (x) 'exn-raised))) (f 'mis-match) 'no-exn)
'exn-raised)
(test (object-name g) 'g)
(test (pair? (test-match grammar M '(1 1))) #t)
(test (pair? (test-match grammar M '(1 1 1))) #f)
(test (pair? (test-match grammar
(side-condition (M_1 M_2) (equal? (term M_1) (term M_2)))
'(1 1)))
#t)
(test (pair? (test-match grammar
(side-condition (M_1 M_2) (equal? (term M_1) (term M_2)))
'(1 2)))
#f)
(test (pair? ((test-match grammar M) '(1 1)))
#t)
(printf "tl-test.ss: all ~a tests passed.\n" tests))