112 lines
3.8 KiB
Racket
112 lines
3.8 KiB
Racket
(module term-test scheme
|
|
(require "../private/term.rkt"
|
|
"../private/matcher.rkt"
|
|
"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)
|
|
(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 'term-test.rkt))
|