suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Switch to the current version of schemeunit.

Browse Source 
svn: r18263
This commit is contained in:
Sam Tobin-Hochstadt 2010-02-22 17:58:18 +00:00
parent 1eea5163cc
commit e417da3598
5 changed files with 381 additions and 350 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/tests/match/examples.ss
View File

@ -5,16 +5,14 @@
scheme/control scheme/control
(for-syntax scheme/base) (for-syntax scheme/base)
(prefix-in m: mzlib/match) (prefix-in m: mzlib/match)
(only-in srfi/13 string-contains)) (only-in srfi/13 string-contains)
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) schemeunit)
(define-syntax (comp stx) (define-syntax (comp stx)
(syntax-case stx () (syntax-case stx ()
[(mytest tst exp) [(mytest tst exp)
#`(make-test-case (format "test: ~a" (syntax->datum (quote-syntax tst))) #`(test-case (format "test: ~a" (syntax->datum (quote-syntax tst)))
#,(syntax/loc stx (assert-equal? tst exp)))])) #,(syntax/loc stx (check-equal? tst exp)))]))
(define-struct X (a b c)) (define-struct X (a b c))
(define-match-expander X: (define-match-expander X:
@ -56,7 +54,7 @@
(provide new-tests) (provide new-tests)
(define new-tests (define new-tests
(make-test-suite (test-suite
"new tests for match" "new tests for match"
(comp (comp

84
collects/tests/match/match-tests.ss
View File

@ -1,75 +1,73 @@
(module match-tests mzscheme (module match-tests mzscheme
(require mzlib/match) (require mzlib/match schemeunit)
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10)))
(provide match-tests) (provide match-tests)
(define match-expander-tests (define match-expander-tests
(make-test-suite (test-suite
"Tests for define-match-expander" "Tests for define-match-expander"
(make-test-case "Trivial expander" (test-case "Trivial expander"
(let () (let ()
(define-match-expander bar #f (lambda (x) #'_) +) (define-match-expander bar #f (lambda (x) #'_) +)
(assert = 4 (match 3 [(= add1 x) x])) ; other stuff still works (check = 4 (match 3 [(= add1 x) x])) ; other stuff still works
(assert-true (match 3 [(bar) #t])) ; (bar) matches anything (check-true (match 3 [(bar) #t])) ; (bar) matches anything
(assert = 12 (bar 3 4 5)) (check = 12 (bar 3 4 5))
(assert = 12 (apply bar '(3 4 5))))) ; bar works like + (check = 12 (apply bar '(3 4 5))))) ; bar works like +
(make-test-case "Trivial expander w/ keywords" (test-case "Trivial expander w/ keywords"
(let () (let ()
(define-match-expander bar #:match (lambda (x) #'_) #:expression +) (define-match-expander bar #:match (lambda (x) #'_) #:expression +)
(assert = 4 (match 3 [(= add1 x) x])) ; other stuff still works (check = 4 (match 3 [(= add1 x) x])) ; other stuff still works
(assert-true (match 3 [(bar) #t])) ; (bar) matches anything (check-true (match 3 [(bar) #t])) ; (bar) matches anything
(assert = 12 (bar 3 4 5)) (check = 12 (bar 3 4 5))
(assert = 12 (apply bar '(3 4 5))))) ; bar works like + (check = 12 (apply bar '(3 4 5))))) ; bar works like +
)) ))
(define simple-tests (define simple-tests
(make-test-suite (test-suite
"Some Simple Tests" "Some Simple Tests"
(make-test-case "Trivial" (test-case "Trivial"
(assert = 3 (match 3 [x x]))) (check = 3 (match 3 [x x])))
(make-test-case "= pattern" (test-case "= pattern"
(assert = 4 (match 3 [(= add1 y) y]))) (check = 4 (match 3 [(= add1 y) y])))
(make-test-case "struct patterns" (test-case "struct patterns"
(let () (let ()
(define-struct point (x y)) (define-struct point (x y))
(define (origin? pt) (define (origin? pt)
(match pt (match pt
(($ point 0 0) #t) (($ point 0 0) #t)
(else #f))) (else #f)))
(assert-true (origin? (make-point 0 0))) (check-true (origin? (make-point 0 0)))
(assert-false (origin? (make-point 1 1))))) (check-false (origin? (make-point 1 1)))))
)) ))
(define nonlinear-tests (define nonlinear-tests
(make-test-suite (test-suite
"Non-linear patterns" "Non-linear patterns"
(make-test-case "Very simple" (test-case "Very simple"
(assert = 3 (match '(3 3) [(a a) a]))) (check = 3 (match '(3 3) [(a a) a])))
(make-test-case "Fails" (test-case "Fails"
(assert-exn exn:misc:match? (lambda () (match '(3 4) [(a a) a])))) (check-exn exn:misc:match? (lambda () (match '(3 4) [(a a) a]))))
(make-test-case "Use parameter" (test-case "Use parameter"
(parameterize ([match-equality-test eq?]) (parameterize ([match-equality-test eq?])
(assert = 5 (match '((3) (3)) [(a a) a] [_ 5])))) (check = 5 (match '((3) (3)) [(a a) a] [_ 5]))))
(make-test-case "Uses equal?" (test-case "Uses equal?"
(assert equal? '(3) (match '((3) (3)) [(a a) a] [_ 5]))))) (check equal? '(3) (match '((3) (3)) [(a a) a] [_ 5])))))
(define doc-tests (define doc-tests
(make-test-suite (test-suite
"Tests from Help Desk Documentation" "Tests from Help Desk Documentation"
(make-test-case "match-let" (test-case "match-let"
(assert = 6 (match-let ([(x y z) (list 1 2 3)]) (+ x y z)))) (check = 6 (match-let ([(x y z) (list 1 2 3)]) (+ x y z))))
#; #;
(make-test-case "set! pattern" (test-case "set! pattern"
(let () (let ()
(define x (list 1 (list 2 3))) (define x (list 1 (list 2 3)))
(match x [(_ (_ (set! setit))) (setit 4)]) (match x [(_ (_ (set! setit))) (setit 4)])
(assert-equal? x '(1 (2 4))))) (check-equal? x '(1 (2 4)))))
(make-test-case "lambda calculus" (test-case "lambda calculus"
(let () (let ()
(define-struct Lam (args body)) (define-struct Lam (args body))
(define-struct Var (s)) (define-struct Var (s))
@ -102,9 +100,9 @@
[($ Lam args body) `(lambda ,args ,(unparse body))] [($ Lam args body) `(lambda ,args ,(unparse body))]
[($ App f args) `(,(unparse f) ,@(map unparse args))])) [($ App f args) `(,(unparse f) ,@(map unparse args))]))
(assert equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x)))))) (check equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x))))))
(make-test-case "counter : match-define" (test-case "counter : match-define"
(let () (let ()
(match-define (inc value reset) (match-define (inc value reset)
(let ([val 0]) (let ([val 0])
@ -114,16 +112,16 @@
(lambda () (set! val 0))))) (lambda () (set! val 0)))))
(inc) (inc)
(inc) (inc)
(assert = 2 (value)) (check = 2 (value))
(inc) (inc)
(assert = 3 (value)) (check = 3 (value))
(reset) (reset)
(assert = 0 (value)))) (check = 0 (value))))
)) ))
(define match-tests (define match-tests
(make-test-suite "Tests for match.ss" (test-suite "Tests for match.ss"
doc-tests doc-tests
simple-tests simple-tests
nonlinear-tests nonlinear-tests

24
collects/tests/match/other-plt-tests.ss
View File

@ -1,13 +1,7 @@
(module other-plt-tests mzscheme (module other-plt-tests mzscheme
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) (require schemeunit net/uri-codec mzlib/pregexp mzlib/plt-match
(require net/uri-codec) mzlib/list mzlib/etc)
(require mzlib/pregexp)
(require mzlib/plt-match)
(require mzlib/list
mzlib/etc)
(define-struct shape (color)) (define-struct shape (color))
(define-struct (ovoid shape) (x-diam y-diam)) (define-struct (ovoid shape) (x-diam y-diam))
@ -30,17 +24,17 @@
(define-syntax (mytest stx) (define-syntax (mytest stx)
(syntax-case stx () (syntax-case stx ()
[(mytest tst exp) [(mytest tst exp)
#`(make-test-case (format "test: ~a" (syntax-object->datum (quote-syntax tst))) #`(test-case (format "test: ~a" (syntax-object->datum (quote-syntax tst)))
#,(syntax/loc stx (assert-equal? tst exp)))])) #,(syntax/loc stx (check-equal? tst exp)))]))
(define-syntax mytest-no-order (define-syntax mytest-no-order
(syntax-rules () (syntax-rules ()
[(mytest tst exp) [(mytest tst exp)
(make-test-case (format "no-order test: ~a" (syntax-object->datum (quote-syntax tst))) (test-case (format "no-order test: ~a" (syntax-object->datum (quote-syntax tst)))
(assert set-equal? tst exp))])) (check set-equal? tst exp))]))
(define other-plt-tests (define other-plt-tests
(make-test-suite (test-suite
"Tests copied from plt-match-test.ss" "Tests copied from plt-match-test.ss"
(mytest (match "hello" (mytest (match "hello"
@ -726,14 +720,14 @@
(mytest (mytest
(let ((f 7)) (match-define (list a b c) (list 1 2 f)) (list a b c f)) (let ((f 7)) (match-define (list a b c) (list 1 2 f)) (list a b c f))
'(1 2 7 7)) '(1 2 7 7))
(make-test-case "match-define" (test-case "match-define"
(let () (let ()
(match-define (match-define
(list a b) (list a b)
(list (list
(lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x))))) (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x)))))
(lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))) (lambda (x) (if (= x 10) '() (cons x (b (add1 x)))))))
(assert-equal? (check-equal?
(a 10) (a 10)
'(() '(()
(9) (9)

19
collects/tests/match/other-tests.ss
View File

@ -1,25 +1,22 @@
(module other-tests mzscheme (module other-tests mzscheme
(require mzlib/match) (require mzlib/match schemeunit)
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10)))
(provide other-tests) (provide other-tests)
(define-syntax (mytest stx) (define-syntax (mytest stx)
(syntax-case stx () (syntax-case stx ()
[(mytest tst exp) [(mytest tst exp)
#`(make-test-case (format "test: ~a" (syntax-object->datum (quote-syntax tst))) #`(test-case (format "test: ~a" (syntax-object->datum (quote-syntax tst)))
#,(syntax/loc stx (assert-equal? tst exp)))])) #,(syntax/loc stx (check-equal? tst exp)))]))
(define-syntax mytest-no-order (define-syntax mytest-no-order
(syntax-rules () (syntax-rules ()
[(mytest tst exp) [(mytest tst exp)
(make-test-case (format "no-order test: ~a" (syntax-object->datum (quote-syntax tst))) (test-case (format "no-order test: ~a" (syntax-object->datum (quote-syntax tst)))
(assert set-equal? tst exp))])) (check set-equal? tst exp))]))
(define other-tests (define other-tests
(make-test-suite "Tests copied from match-test.ss" (test-suite "Tests copied from match-test.ss"
(mytest (letrec ((z (mytest (letrec ((z
(lambda (x) (lambda (x)
@ -138,10 +135,10 @@
'(1 2 7 7)) '(1 2 7 7))
(make-test-case "match-define" (test-case "match-define"
(let () (match-define (a b) (list (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x))))) (let () (match-define (a b) (list (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x)))))
(lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))) (lambda (x) (if (= x 10) '() (cons x (b (add1 x)))))))
(assert-equal? (a 10) (check-equal? (a 10)
'(() (9) (8 9) (7 8 9) (6 7 8 9) (5 6 7 8 9) (4 5 6 7 8 9) '(() (9) (8 9) (7 8 9) (6 7 8 9) (5 6 7 8 9) (4 5 6 7 8 9)
(3 4 5 6 7 8 9) (2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9))))) (3 4 5 6 7 8 9) (2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9)))))

230
collects/tests/match/plt-match-tests.ss
View File

@ -1,61 +1,58 @@
#lang scheme/base #lang scheme/base
(require (for-syntax scheme/base)) (require (for-syntax scheme/base)
"match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss"
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) schemeunit schemeunit/text-ui)
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10)))
(require mzlib/plt-match) (require mzlib/plt-match)
(require "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss") ;(require (planet "views.ss" ("cobbe" "views.plt" 1 1)))
(require (planet "views.ss" ("cobbe" "views.plt" 1 1)))
(define reg-tests (define reg-tests
(make-test-suite "Tests for regressions" (test-suite "Tests for regressions"
(make-test-case "quote in qp" (test-case "quote in qp"
(assert eq? #t (match '(tile a b c) (check eq? #t (match '(tile a b c)
[`(tile ,@'(a b c)) [`(tile ,@'(a b c))
#t] #t]
[else #f])) [else #f]))
(assert eq? #t (match '(tile a b c) (check eq? #t (match '(tile a b c)
[`(tile ,@`(a b c)) [`(tile ,@`(a b c))
#t] #t]
[else #f]))))) [else #f])))))
(define cons-tests (define cons-tests
(make-test-suite "Tests for cons pattern" (test-suite "Tests for cons pattern"
(make-test-case "simple" (test-case "simple"
(assert = 3 (match (cons 1 2) [(cons a b) (+ a b)]))))) (check = 3 (match (cons 1 2) [(cons a b) (+ a b)])))))
(define match-expander-tests (define match-expander-tests
(make-test-suite (test-suite
"Tests for define-match-expander" "Tests for define-match-expander"
(make-test-case "Trivial expander" (test-case "Trivial expander"
(let () (let ()
(define-match-expander bar (lambda (x) #'_) +) (define-match-expander bar (lambda (x) #'_) +)
(assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works (check = 4 (match 3 [(app add1 x) x])) ; other stuff still works
(assert-true (match 3 [(bar) #t])) ; (bar) matches anything (check-true (match 3 [(bar) #t])) ; (bar) matches anything
(assert = 12 (bar 3 4 5)) (check = 12 (bar 3 4 5))
(assert = 12 (apply bar '(3 4 5))))) ; bar works like + (check = 12 (apply bar '(3 4 5))))) ; bar works like +
(make-test-case "Trivial expander w/ keywords" (test-case "Trivial expander w/ keywords"
(let () (let ()
(define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +) (define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +)
(assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works (check = 4 (match 3 [(app add1 x) x])) ; other stuff still works
(assert-true (match 3 [(bar) #t])) ; (bar) matches anything (check-true (match 3 [(bar) #t])) ; (bar) matches anything
(assert = 12 (bar 3 4 5)) (check = 12 (bar 3 4 5))
(assert = 12 (apply bar '(3 4 5))))) ; bar works like + (check = 12 (apply bar '(3 4 5))))) ; bar works like +
;; gross hack to check for syntax errors ;; gross hack to check for syntax errors
(make-test-case "Only one xform gives syntax error" (test-case "Only one xform gives syntax error"
(assert-exn exn:fail:syntax? (check-exn exn:fail:syntax?
(lambda () (lambda ()
(expand #'(let () (expand #'(let ()
(define-match-expander bar (lambda (x) #'_)) (define-match-expander bar (lambda (x) #'_))
(bar 3 4)))))) (bar 3 4))))))
;; more complex example from Dale ;; more complex example from Dale
(make-test-case "Point structs" (test-case "Point structs"
(let () (let ()
(define-struct point (x y)) (define-struct point (x y))
(define-match-expander Point (define-match-expander Point
@ -64,20 +61,67 @@
((Point a b) #'(struct point (a b))))) ((Point a b) #'(struct point (a b)))))
make-point) make-point)
;; check that it works as expression and as pattern ;; check that it works as expression and as pattern
(assert = 5 (match (Point 2 3) (check = 5 (match (Point 2 3)
[(Point x y) (+ x y)])) [(Point x y) (+ x y)]))
;; check that sub-patterns still work ;; check that sub-patterns still work
(assert = 7 (match (make-point 2 3) (check = 7 (match (make-point 2 3)
[(Point (app add1 x) (app add1 y)) (+ x y)])) [(Point (app add1 x) (app add1 y)) (+ x y)]))
;; check that it works inside a list ;; check that it works inside a list
(assert = 7 (match (list (make-point 2 3)) (check = 7 (match (list (make-point 2 3))
[(list (Point (app add1 x) (app add1 y))) (+ x y)])) [(list (Point (app add1 x) (app add1 y))) (+ x y)]))
)) ))
;; from richard's view documentation ;; from richard's view documentation
(make-test-case "Natural number views" (test-case "Natural number views"
(let () (let ()
;; the view implementation from planet:
(define-match-expander view
(lambda (stx)
(syntax-case stx ()
[(_ pred? ([selector pattern] ...))
#'(? pred? (app selector pattern) ...)]))
(lambda (stx)
(syntax-case stx ()
[(_ pred? ([selector pattern] ...))
#'(? pred? (= selector pattern) ...)]))
(lambda (stx)
(raise-syntax-error #f "may only be used as match pattern" stx)))
(define-syntax define-view
(lambda (stx)
(syntax-case stx ()
[(_ view-name pred? (selector ...))
(identifier? #'view-name)
(with-syntax ([(pattern-var ...)
(generate-temporaries #'(selector ...))]
[(pred-var) (generate-temporaries #'(pred?))]
[(selector-var ...)
(generate-temporaries #'(selector ...))])
#'(begin
(define pred-var pred?)
(define selector-var selector) ...
(define-match-expander view-name
(lambda (stx)
(syntax-case stx ()
[(_ pattern-var ...)
#'(? pred-var (app selector-var pattern-var) ...)]))
(lambda (stx)
(syntax-case stx ()
[(_ pattern-var ...)
#'(? pred-var (= selector-var pattern-var) ...)]))
(lambda (stx)
(raise-syntax-error #f
"may only be used as match pattern"
stx)))))]
[(_ bad-name pred? (selector ...))
(raise-syntax-error #f "bad view name" stx #'bad-name)]
[_
(raise-syntax-error
#f
"bad view defn: expected (define-view view-name pred? (selector ...))"
stx)])))
(define natural-number? (define natural-number?
(lambda (x) (lambda (x)
(and (integer? x) (and (integer? x)
@ -91,10 +135,10 @@
(match-lambda (match-lambda
[(peano-zero) 1] [(peano-zero) 1]
[(and (peano-succ pred) n) (* n (factorial pred))])) [(and (peano-succ pred) n) (* n (factorial pred))]))
(assert = 120 (factorial 5)))) (check = 120 (factorial 5))))
;; more complex example from Dale ;; more complex example from Dale
(make-test-case "Point structs with keywords" (test-case "Point structs with keywords"
(let () (let ()
(define-struct point (x y)) (define-struct point (x y))
(define-match-expander Point (define-match-expander Point
@ -104,59 +148,59 @@
((Point a b) #'(struct point (a b))))) ((Point a b) #'(struct point (a b)))))
#:expression make-point) #:expression make-point)
;; check that it works as expression and as pattern ;; check that it works as expression and as pattern
(assert = 5 (match (Point 2 3) (check = 5 (match (Point 2 3)
[(Point x y) (+ x y)])) [(Point x y) (+ x y)]))
;; check that sub-patterns still work ;; check that sub-patterns still work
(assert = 7 (match (make-point 2 3) (check = 7 (match (make-point 2 3)
[(Point (app add1 x) (app add1 y)) (+ x y)])) [(Point (app add1 x) (app add1 y)) (+ x y)]))
;; check that it works inside a list ;; check that it works inside a list
(assert = 7 (match (list (make-point 2 3)) (check = 7 (match (list (make-point 2 3))
[(list (Point (app add1 x) (app add1 y))) (+ x y)])) [(list (Point (app add1 x) (app add1 y))) (+ x y)]))
)) ))
)) ))
(define simple-tests (define simple-tests
(make-test-suite (test-suite
"Some Simple Tests" "Some Simple Tests"
(make-test-case "Trivial" (test-case "Trivial"
(assert = 3 (match 3 [x x]))) (check = 3 (match 3 [x x])))
(make-test-case "no order" (test-case "no order"
(assert equal? #t (match '(1 2 3 1) (check equal? #t (match '(1 2 3 1)
[(list-no-order 3 2 1 1) #t] [(list-no-order 3 2 1 1) #t]
[_ #f]))) [_ #f])))
(make-test-case "app pattern" (test-case "app pattern"
(assert = 4 (match 3 [(app add1 y) y]))) (check = 4 (match 3 [(app add1 y) y])))
(make-test-case "struct patterns" (test-case "struct patterns"
(let () (let ()
(define-struct point (x y)) (define-struct point (x y))
(define (origin? pt) (define (origin? pt)
(match pt (match pt
((struct point (0 0)) #t) ((struct point (0 0)) #t)
(else #f))) (else #f)))
(assert-true (origin? (make-point 0 0))) (check-true (origin? (make-point 0 0)))
(assert-false (origin? (make-point 1 1))))) (check-false (origin? (make-point 1 1)))))
)) ))
(define nonlinear-tests (define nonlinear-tests
(make-test-suite (test-suite
"Non-linear patterns" "Non-linear patterns"
(make-test-case "Very simple" (test-case "Very simple"
(assert = 3 (match '(3 3) [(list a a) a]))) (check = 3 (match '(3 3) [(list a a) a])))
(make-test-case "Fails" (test-case "Fails"
(assert-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a])))) (check-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a]))))
(make-test-case "Use parameter" (test-case "Use parameter"
(parameterize ([match-equality-test eq?]) (parameterize ([match-equality-test eq?])
(assert = 5 (match '((3) (3)) [(list a a) a] [_ 5])))) (check = 5 (match '((3) (3)) [(list a a) a] [_ 5]))))
(make-test-case "Nonlinear patterns use equal?" (test-case "Nonlinear patterns use equal?"
(assert equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5]))))) (check equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5])))))
(define doc-tests (define doc-tests
(make-test-suite (test-suite
"Tests from Help Desk Documentation" "Tests from Help Desk Documentation"
(make-test-case "match-let" (test-case "match-let"
(assert = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z)))) (check = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z))))
(make-test-case "lambda calculus" (test-case "lambda calculus"
(let () (let ()
(define-struct Lam (args body)) (define-struct Lam (args body))
(define-struct Var (s)) (define-struct Var (s))
@ -189,9 +233,9 @@
[(struct Lam (args body)) `(lambda ,args ,(unparse body))] [(struct Lam (args body)) `(lambda ,args ,(unparse body))]
[(struct App (f args)) `(,(unparse f) ,@(map unparse args))])) [(struct App (f args)) `(,(unparse f) ,@(map unparse args))]))
(assert equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x)))))) (check equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x))))))
(make-test-case "counter : match-define" (test-case "counter : match-define"
(let () (let ()
(match-define (list inc value reset) (match-define (list inc value reset)
(let ([val 0]) (let ([val 0])
@ -201,67 +245,67 @@
(lambda () (set! val 0))))) (lambda () (set! val 0)))))
(inc) (inc)
(inc) (inc)
(assert = 2 (value)) (check = 2 (value))
(inc) (inc)
(assert = 3 (value)) (check = 3 (value))
(reset) (reset)
(assert = 0 (value)))) (check = 0 (value))))
)) ))
(define struct*-tests (define struct*-tests
(make-test-suite (test-suite
"Tests of struct*" "Tests of struct*"
(make-test-case "not an id for struct" (test-case "not an id for struct"
(assert-exn exn:fail:syntax? (check-exn exn:fail:syntax?
(lambda () (lambda ()
(expand #'(let () (expand #'(let ()
(define-struct tree (val left right)) (define-struct tree (val left right))
(match (make-tree 0 1 2) (match (make-tree 0 1 2)
[(struct* 4 ()) [(struct* 4 ())
#f])))))) #f]))))))
(make-test-case "not a struct-info for struct" (test-case "not a struct-info for struct"
(assert-exn exn:fail:syntax? (check-exn exn:fail:syntax?
(lambda () (lambda ()
(expand #'(let () (expand #'(let ()
(define-syntax tree 1) (define-syntax tree 1)
(match 1 (match 1
[(struct* tree ()) [(struct* tree ())
#f])))))) #f]))))))
(make-test-case "bad form" (test-case "bad form"
(assert-exn exn:fail:syntax? (check-exn exn:fail:syntax?
(lambda () (lambda ()
(expand #'(let () (expand #'(let ()
(define-struct tree (val left right)) (define-struct tree (val left right))
(match (make-tree 0 1 2) (match (make-tree 0 1 2)
[(struct* tree ([val])) [(struct* tree ([val]))
#f])))))) #f]))))))
(make-test-case "bad form" (test-case "bad form"
(assert-exn exn:fail:syntax? (check-exn exn:fail:syntax?
(lambda () (lambda ()
(expand #'(let () (expand #'(let ()
(define-struct tree (val left right)) (define-struct tree (val left right))
(match (make-tree 0 1 2) (match (make-tree 0 1 2)
[(struct* tree (val)) [(struct* tree (val))
#f])))))) #f]))))))
(make-test-case "field appears twice" (test-case "field appears twice"
(assert-exn exn:fail:syntax? (check-exn exn:fail:syntax?
(lambda () (lambda ()
(expand #'(let () (expand #'(let ()
(define-struct tree (val left right)) (define-struct tree (val left right))
(match (make-tree 0 1 2) (match (make-tree 0 1 2)
[(struct* tree ([val 0] [val 0])) [(struct* tree ([val 0] [val 0]))
#f])))))) #f]))))))
(make-test-case "not a field" (test-case "not a field"
(assert-exn exn:fail:syntax? (check-exn exn:fail:syntax?
(lambda () (lambda ()
(expand #'(let () (expand #'(let ()
(define-struct tree (val left right)) (define-struct tree (val left right))
(match (make-tree 0 1 2) (match (make-tree 0 1 2)
[(struct* tree ([feet 0])) [(struct* tree ([feet 0]))
#f])))))) #f]))))))
(make-test-case "super structs don't work" (test-case "super structs don't work"
(assert-exn exn:fail:syntax? (check-exn exn:fail:syntax?
(lambda () (lambda ()
(expand #'(let () (expand #'(let ()
(define-struct extra (foo)) (define-struct extra (foo))
@ -269,14 +313,14 @@
(match (make-tree #f 0 1 2) (match (make-tree #f 0 1 2)
[(struct* tree ([extra #f] [val 0])) [(struct* tree ([extra #f] [val 0]))
#f])))))) #f]))))))
(make-test-case "super struct kinda work" (test-case "super struct kinda work"
(let () (let ()
(define-struct extra (foo)) (define-struct extra (foo))
(define-struct (tree extra) (val left right)) (define-struct (tree extra) (val left right))
(match (make-tree #f 0 1 2) (match (make-tree #f 0 1 2)
[(struct* tree ([val a])) [(struct* tree ([val a]))
(assert = 0 a)]))) (check = 0 a)])))
(make-test-case "from documentation" (test-case "from documentation"
(let () (let ()
(define-struct tree (val left right)) (define-struct tree (val left right))
(match-define (match-define
@ -289,28 +333,28 @@
([right #f] ([right #f]
[val b]))])) [val b]))]))
(make-tree 0 (make-tree 1 #f #f) #f)) (make-tree 0 (make-tree 1 #f #f) #f))
(assert = 0 a) (check = 0 a)
(assert = 1 b))))) (check = 1 b)))))
(define plt-match-tests (define plt-match-tests
(make-test-suite "Tests for plt-match.ss" (test-suite "Tests for plt-match.ss"
doc-tests doc-tests
cons-tests cons-tests
simple-tests simple-tests
nonlinear-tests nonlinear-tests
match-expander-tests match-expander-tests
reg-tests reg-tests
struct*-tests struct*-tests))
))
(define (run-tests) (define (run-all-tests)
(test/text-ui (make-test-suite "Match Tests" (run-tests (test-suite "Match Tests"
plt-match-tests plt-match-tests
match-tests match-tests
new-tests new-tests
;; from bruce ;; from bruce
other-tests other-tests
other-plt-tests other-plt-tests)
))) 'verbose))
(unless (= 0 (run-tests))
(unless (= 0 (run-all-tests))
(error "Match Tests did not pass.")) (error "Match Tests did not pass."))