From e417da359863bf75ae6e089b279f2b70c80e041b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 22 Feb 2010 17:58:18 +0000 Subject: [PATCH] Switch to the current version of schemeunit. svn: r18263 --- collects/tests/match/examples.ss | 12 +- collects/tests/match/match-tests.ss | 84 ++-- collects/tests/match/other-plt-tests.ss | 24 +- collects/tests/match/other-tests.ss | 21 +- collects/tests/match/plt-match-tests.ss | 590 +++++++++++++----------- 5 files changed, 381 insertions(+), 350 deletions(-) diff --git a/collects/tests/match/examples.ss b/collects/tests/match/examples.ss index 132f459439..6c8a284526 100644 --- a/collects/tests/match/examples.ss +++ b/collects/tests/match/examples.ss @@ -5,16 +5,14 @@ scheme/control (for-syntax scheme/base) (prefix-in m: mzlib/match) - (only-in srfi/13 string-contains)) -(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) - - + (only-in srfi/13 string-contains) + schemeunit) (define-syntax (comp stx) (syntax-case stx () [(mytest tst exp) - #`(make-test-case (format "test: ~a" (syntax->datum (quote-syntax tst))) - #,(syntax/loc stx (assert-equal? tst exp)))])) + #`(test-case (format "test: ~a" (syntax->datum (quote-syntax tst))) + #,(syntax/loc stx (check-equal? tst exp)))])) (define-struct X (a b c)) (define-match-expander X: @@ -56,7 +54,7 @@ (provide new-tests) (define new-tests - (make-test-suite + (test-suite "new tests for match" (comp diff --git a/collects/tests/match/match-tests.ss b/collects/tests/match/match-tests.ss index e65d7fbb49..0f480701ab 100644 --- a/collects/tests/match/match-tests.ss +++ b/collects/tests/match/match-tests.ss @@ -1,75 +1,73 @@ (module match-tests mzscheme - (require mzlib/match) + (require mzlib/match schemeunit) - (require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) - (provide match-tests) (define match-expander-tests - (make-test-suite + (test-suite "Tests for define-match-expander" - (make-test-case "Trivial expander" + (test-case "Trivial expander" (let () (define-match-expander bar #f (lambda (x) #'_) +) - (assert = 4 (match 3 [(= add1 x) x])) ; other stuff still works - (assert-true (match 3 [(bar) #t])) ; (bar) matches anything - (assert = 12 (bar 3 4 5)) - (assert = 12 (apply bar '(3 4 5))))) ; bar works like + - (make-test-case "Trivial expander w/ keywords" + (check = 4 (match 3 [(= add1 x) x])) ; other stuff still works + (check-true (match 3 [(bar) #t])) ; (bar) matches anything + (check = 12 (bar 3 4 5)) + (check = 12 (apply bar '(3 4 5))))) ; bar works like + + (test-case "Trivial expander w/ keywords" (let () (define-match-expander bar #:match (lambda (x) #'_) #:expression +) - (assert = 4 (match 3 [(= add1 x) x])) ; other stuff still works - (assert-true (match 3 [(bar) #t])) ; (bar) matches anything - (assert = 12 (bar 3 4 5)) - (assert = 12 (apply bar '(3 4 5))))) ; bar works like + + (check = 4 (match 3 [(= add1 x) x])) ; other stuff still works + (check-true (match 3 [(bar) #t])) ; (bar) matches anything + (check = 12 (bar 3 4 5)) + (check = 12 (apply bar '(3 4 5))))) ; bar works like + )) (define simple-tests - (make-test-suite + (test-suite "Some Simple Tests" - (make-test-case "Trivial" - (assert = 3 (match 3 [x x]))) - (make-test-case "= pattern" - (assert = 4 (match 3 [(= add1 y) y]))) - (make-test-case "struct patterns" + (test-case "Trivial" + (check = 3 (match 3 [x x]))) + (test-case "= pattern" + (check = 4 (match 3 [(= add1 y) y]))) + (test-case "struct patterns" (let () (define-struct point (x y)) (define (origin? pt) (match pt (($ point 0 0) #t) (else #f))) - (assert-true (origin? (make-point 0 0))) - (assert-false (origin? (make-point 1 1))))) + (check-true (origin? (make-point 0 0))) + (check-false (origin? (make-point 1 1))))) )) (define nonlinear-tests - (make-test-suite + (test-suite "Non-linear patterns" - (make-test-case "Very simple" - (assert = 3 (match '(3 3) [(a a) a]))) - (make-test-case "Fails" - (assert-exn exn:misc:match? (lambda () (match '(3 4) [(a a) a])))) - (make-test-case "Use parameter" + (test-case "Very simple" + (check = 3 (match '(3 3) [(a a) a]))) + (test-case "Fails" + (check-exn exn:misc:match? (lambda () (match '(3 4) [(a a) a])))) + (test-case "Use parameter" (parameterize ([match-equality-test eq?]) - (assert = 5 (match '((3) (3)) [(a a) a] [_ 5])))) - (make-test-case "Uses equal?" - (assert equal? '(3) (match '((3) (3)) [(a a) a] [_ 5]))))) + (check = 5 (match '((3) (3)) [(a a) a] [_ 5])))) + (test-case "Uses equal?" + (check equal? '(3) (match '((3) (3)) [(a a) a] [_ 5]))))) (define doc-tests - (make-test-suite + (test-suite "Tests from Help Desk Documentation" - (make-test-case "match-let" - (assert = 6 (match-let ([(x y z) (list 1 2 3)]) (+ x y z)))) + (test-case "match-let" + (check = 6 (match-let ([(x y z) (list 1 2 3)]) (+ x y z)))) #; - (make-test-case "set! pattern" + (test-case "set! pattern" (let () (define x (list 1 (list 2 3))) (match x [(_ (_ (set! setit))) (setit 4)]) - (assert-equal? x '(1 (2 4))))) - (make-test-case "lambda calculus" + (check-equal? x '(1 (2 4))))) + (test-case "lambda calculus" (let () (define-struct Lam (args body)) (define-struct Var (s)) @@ -102,9 +100,9 @@ [($ Lam args body) `(lambda ,args ,(unparse body))] [($ 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 () (match-define (inc value reset) (let ([val 0]) @@ -114,16 +112,16 @@ (lambda () (set! val 0))))) (inc) (inc) - (assert = 2 (value)) + (check = 2 (value)) (inc) - (assert = 3 (value)) + (check = 3 (value)) (reset) - (assert = 0 (value)))) + (check = 0 (value)))) )) (define match-tests - (make-test-suite "Tests for match.ss" + (test-suite "Tests for match.ss" doc-tests simple-tests nonlinear-tests diff --git a/collects/tests/match/other-plt-tests.ss b/collects/tests/match/other-plt-tests.ss index dfa241117f..5054c49d75 100644 --- a/collects/tests/match/other-plt-tests.ss +++ b/collects/tests/match/other-plt-tests.ss @@ -1,13 +1,7 @@ (module other-plt-tests mzscheme - (require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) - (require net/uri-codec) - (require mzlib/pregexp) - - (require mzlib/plt-match) - - (require mzlib/list - mzlib/etc) + (require schemeunit net/uri-codec mzlib/pregexp mzlib/plt-match + mzlib/list mzlib/etc) (define-struct shape (color)) (define-struct (ovoid shape) (x-diam y-diam)) @@ -30,17 +24,17 @@ (define-syntax (mytest stx) (syntax-case stx () [(mytest tst exp) - #`(make-test-case (format "test: ~a" (syntax-object->datum (quote-syntax tst))) - #,(syntax/loc stx (assert-equal? tst exp)))])) + #`(test-case (format "test: ~a" (syntax-object->datum (quote-syntax tst))) + #,(syntax/loc stx (check-equal? tst exp)))])) (define-syntax mytest-no-order (syntax-rules () [(mytest tst exp) - (make-test-case (format "no-order test: ~a" (syntax-object->datum (quote-syntax tst))) - (assert set-equal? tst exp))])) + (test-case (format "no-order test: ~a" (syntax-object->datum (quote-syntax tst))) + (check set-equal? tst exp))])) (define other-plt-tests - (make-test-suite + (test-suite "Tests copied from plt-match-test.ss" (mytest (match "hello" @@ -726,14 +720,14 @@ (mytest (let ((f 7)) (match-define (list a b c) (list 1 2 f)) (list a b c f)) '(1 2 7 7)) - (make-test-case "match-define" + (test-case "match-define" (let () (match-define (list a b) (list (lambda (x) (if (zero? x) '() (cons (b x) (a (sub1 x))))) (lambda (x) (if (= x 10) '() (cons x (b (add1 x))))))) - (assert-equal? + (check-equal? (a 10) '(() (9) diff --git a/collects/tests/match/other-tests.ss b/collects/tests/match/other-tests.ss index da5036a7e8..a1a1c857c2 100644 --- a/collects/tests/match/other-tests.ss +++ b/collects/tests/match/other-tests.ss @@ -1,25 +1,22 @@ (module other-tests mzscheme - (require mzlib/match) - - - (require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) - + (require mzlib/match schemeunit) + (provide other-tests) (define-syntax (mytest stx) (syntax-case stx () [(mytest tst exp) - #`(make-test-case (format "test: ~a" (syntax-object->datum (quote-syntax tst))) - #,(syntax/loc stx (assert-equal? tst exp)))])) + #`(test-case (format "test: ~a" (syntax-object->datum (quote-syntax tst))) + #,(syntax/loc stx (check-equal? tst exp)))])) (define-syntax mytest-no-order (syntax-rules () [(mytest tst exp) - (make-test-case (format "no-order test: ~a" (syntax-object->datum (quote-syntax tst))) - (assert set-equal? tst exp))])) + (test-case (format "no-order test: ~a" (syntax-object->datum (quote-syntax tst))) + (check set-equal? tst exp))])) (define other-tests - (make-test-suite "Tests copied from match-test.ss" + (test-suite "Tests copied from match-test.ss" (mytest (letrec ((z (lambda (x) @@ -138,10 +135,10 @@ '(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))))) (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) (3 4 5 6 7 8 9) (2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9))))) diff --git a/collects/tests/match/plt-match-tests.ss b/collects/tests/match/plt-match-tests.ss index 013c2b0a82..64ed34e595 100644 --- a/collects/tests/match/plt-match-tests.ss +++ b/collects/tests/match/plt-match-tests.ss @@ -1,316 +1,360 @@ #lang scheme/base -(require (for-syntax scheme/base)) - -(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) -(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10))) +(require (for-syntax scheme/base) + "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss" + schemeunit schemeunit/text-ui) (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 - (make-test-suite "Tests for regressions" - (make-test-case "quote in qp" - (assert eq? #t (match '(tile a b c) - [`(tile ,@'(a b c)) - #t] - [else #f])) - (assert eq? #t (match '(tile a b c) - [`(tile ,@`(a b c)) - #t] - [else #f]))))) + (test-suite "Tests for regressions" + (test-case "quote in qp" + (check eq? #t (match '(tile a b c) + [`(tile ,@'(a b c)) + #t] + [else #f])) + (check eq? #t (match '(tile a b c) + [`(tile ,@`(a b c)) + #t] + [else #f]))))) (define cons-tests - (make-test-suite "Tests for cons pattern" - (make-test-case "simple" - (assert = 3 (match (cons 1 2) [(cons a b) (+ a b)]))))) + (test-suite "Tests for cons pattern" + (test-case "simple" + (check = 3 (match (cons 1 2) [(cons a b) (+ a b)]))))) (define match-expander-tests - (make-test-suite + (test-suite "Tests for define-match-expander" - (make-test-case "Trivial expander" - (let () - (define-match-expander bar (lambda (x) #'_) +) - (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works - (assert-true (match 3 [(bar) #t])) ; (bar) matches anything - (assert = 12 (bar 3 4 5)) - (assert = 12 (apply bar '(3 4 5))))) ; bar works like + + (test-case "Trivial expander" + (let () + (define-match-expander bar (lambda (x) #'_) +) + (check = 4 (match 3 [(app add1 x) x])) ; other stuff still works + (check-true (match 3 [(bar) #t])) ; (bar) matches anything + (check = 12 (bar 3 4 5)) + (check = 12 (apply bar '(3 4 5))))) ; bar works like + - (make-test-case "Trivial expander w/ keywords" - (let () - (define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +) - (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works - (assert-true (match 3 [(bar) #t])) ; (bar) matches anything - (assert = 12 (bar 3 4 5)) - (assert = 12 (apply bar '(3 4 5))))) ; bar works like + + (test-case "Trivial expander w/ keywords" + (let () + (define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +) + (check = 4 (match 3 [(app add1 x) x])) ; other stuff still works + (check-true (match 3 [(bar) #t])) ; (bar) matches anything + (check = 12 (bar 3 4 5)) + (check = 12 (apply bar '(3 4 5))))) ; bar works like + ;; gross hack to check for syntax errors - (make-test-case "Only one xform gives syntax error" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-match-expander bar (lambda (x) #'_)) - (bar 3 4)))))) + (test-case "Only one xform gives syntax error" + (check-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-match-expander bar (lambda (x) #'_)) + (bar 3 4)))))) ;; more complex example from Dale - (make-test-case "Point structs" - (let () - (define-struct point (x y)) - (define-match-expander Point - (lambda (x) - (syntax-case x () - ((Point a b) #'(struct point (a b))))) - make-point) - ;; check that it works as expression and as pattern - (assert = 5 (match (Point 2 3) - [(Point x y) (+ x y)])) - ;; check that sub-patterns still work - (assert = 7 (match (make-point 2 3) - [(Point (app add1 x) (app add1 y)) (+ x y)])) - ;; check that it works inside a list - (assert = 7 (match (list (make-point 2 3)) - [(list (Point (app add1 x) (app add1 y))) (+ x y)])) - )) + (test-case "Point structs" + (let () + (define-struct point (x y)) + (define-match-expander Point + (lambda (x) + (syntax-case x () + ((Point a b) #'(struct point (a b))))) + make-point) + ;; check that it works as expression and as pattern + (check = 5 (match (Point 2 3) + [(Point x y) (+ x y)])) + ;; check that sub-patterns still work + (check = 7 (match (make-point 2 3) + [(Point (app add1 x) (app add1 y)) (+ x y)])) + ;; check that it works inside a list + (check = 7 (match (list (make-point 2 3)) + [(list (Point (app add1 x) (app add1 y))) (+ x y)])) + )) ;; from richard's view documentation - (make-test-case "Natural number views" - (let () - (define natural-number? - (lambda (x) - (and (integer? x) - (>= x 0)))) - (define natural-zero? (lambda (x) (and (integer? x) (zero? x)))) - - (define-view peano-zero natural-zero? ()) - (define-view peano-succ natural-number? (sub1)) - - (define factorial - (match-lambda - [(peano-zero) 1] - [(and (peano-succ pred) n) (* n (factorial pred))])) - (assert = 120 (factorial 5)))) + (test-case "Natural number views" + (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? + (lambda (x) + (and (integer? x) + (>= x 0)))) + (define natural-zero? (lambda (x) (and (integer? x) (zero? x)))) + + (define-view peano-zero natural-zero? ()) + (define-view peano-succ natural-number? (sub1)) + + (define factorial + (match-lambda + [(peano-zero) 1] + [(and (peano-succ pred) n) (* n (factorial pred))])) + (check = 120 (factorial 5)))) ;; more complex example from Dale - (make-test-case "Point structs with keywords" - (let () - (define-struct point (x y)) - (define-match-expander Point - #:plt-match - (lambda (x) - (syntax-case x () - ((Point a b) #'(struct point (a b))))) - #:expression make-point) - ;; check that it works as expression and as pattern - (assert = 5 (match (Point 2 3) - [(Point x y) (+ x y)])) - ;; check that sub-patterns still work - (assert = 7 (match (make-point 2 3) - [(Point (app add1 x) (app add1 y)) (+ x y)])) - ;; check that it works inside a list - (assert = 7 (match (list (make-point 2 3)) - [(list (Point (app add1 x) (app add1 y))) (+ x y)])) - )) + (test-case "Point structs with keywords" + (let () + (define-struct point (x y)) + (define-match-expander Point + #:plt-match + (lambda (x) + (syntax-case x () + ((Point a b) #'(struct point (a b))))) + #:expression make-point) + ;; check that it works as expression and as pattern + (check = 5 (match (Point 2 3) + [(Point x y) (+ x y)])) + ;; check that sub-patterns still work + (check = 7 (match (make-point 2 3) + [(Point (app add1 x) (app add1 y)) (+ x y)])) + ;; check that it works inside a list + (check = 7 (match (list (make-point 2 3)) + [(list (Point (app add1 x) (app add1 y))) (+ x y)])) + )) )) (define simple-tests - (make-test-suite + (test-suite "Some Simple Tests" - (make-test-case "Trivial" - (assert = 3 (match 3 [x x]))) - (make-test-case "no order" - (assert equal? #t (match '(1 2 3 1) - [(list-no-order 3 2 1 1) #t] - [_ #f]))) - (make-test-case "app pattern" - (assert = 4 (match 3 [(app add1 y) y]))) - (make-test-case "struct patterns" - (let () - (define-struct point (x y)) - (define (origin? pt) - (match pt - ((struct point (0 0)) #t) - (else #f))) - (assert-true (origin? (make-point 0 0))) - (assert-false (origin? (make-point 1 1))))) + (test-case "Trivial" + (check = 3 (match 3 [x x]))) + (test-case "no order" + (check equal? #t (match '(1 2 3 1) + [(list-no-order 3 2 1 1) #t] + [_ #f]))) + (test-case "app pattern" + (check = 4 (match 3 [(app add1 y) y]))) + (test-case "struct patterns" + (let () + (define-struct point (x y)) + (define (origin? pt) + (match pt + ((struct point (0 0)) #t) + (else #f))) + (check-true (origin? (make-point 0 0))) + (check-false (origin? (make-point 1 1))))) )) (define nonlinear-tests - (make-test-suite + (test-suite "Non-linear patterns" - (make-test-case "Very simple" - (assert = 3 (match '(3 3) [(list a a) a]))) - (make-test-case "Fails" - (assert-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a])))) - (make-test-case "Use parameter" - (parameterize ([match-equality-test eq?]) - (assert = 5 (match '((3) (3)) [(list a a) a] [_ 5])))) - (make-test-case "Nonlinear patterns use equal?" - (assert equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5]))))) + (test-case "Very simple" + (check = 3 (match '(3 3) [(list a a) a]))) + (test-case "Fails" + (check-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a])))) + (test-case "Use parameter" + (parameterize ([match-equality-test eq?]) + (check = 5 (match '((3) (3)) [(list a a) a] [_ 5])))) + (test-case "Nonlinear patterns use equal?" + (check equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5]))))) (define doc-tests - (make-test-suite + (test-suite "Tests from Help Desk Documentation" - (make-test-case "match-let" - (assert = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z)))) - (make-test-case "lambda calculus" - (let () - (define-struct Lam (args body)) - (define-struct Var (s)) - (define-struct Const (n)) - (define-struct App (fun args)) - - (define parse - (match-lambda - [(and s (? symbol?) (not 'lambda)) - (make-Var s)] - [(? number? n) - (make-Const n)] - [(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body) - (make-Lam args (parse body))] - [(list f args ...) - (make-App - (parse f) - (map parse args))] - [x (error 'syntax "invalid expression")])) - - (define repeats? - (lambda (l) - (and (not (null? l)) - (or (memq (car l) (cdr l)) (repeats? (cdr l)))))) - - (define unparse - (match-lambda - [(struct Var (s)) s] - [(struct Const (n)) n] - [(struct Lam (args body)) `(lambda ,args ,(unparse body))] - [(struct App (f args)) `(,(unparse f) ,@(map unparse args))])) - - (assert equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x)))))) + (test-case "match-let" + (check = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z)))) + (test-case "lambda calculus" + (let () + (define-struct Lam (args body)) + (define-struct Var (s)) + (define-struct Const (n)) + (define-struct App (fun args)) + + (define parse + (match-lambda + [(and s (? symbol?) (not 'lambda)) + (make-Var s)] + [(? number? n) + (make-Const n)] + [(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body) + (make-Lam args (parse body))] + [(list f args ...) + (make-App + (parse f) + (map parse args))] + [x (error 'syntax "invalid expression")])) + + (define repeats? + (lambda (l) + (and (not (null? l)) + (or (memq (car l) (cdr l)) (repeats? (cdr l)))))) + + (define unparse + (match-lambda + [(struct Var (s)) s] + [(struct Const (n)) n] + [(struct Lam (args body)) `(lambda ,args ,(unparse body))] + [(struct App (f args)) `(,(unparse f) ,@(map unparse args))])) + + (check equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x)))))) - (make-test-case "counter : match-define" - (let () - (match-define (list inc value reset) - (let ([val 0]) - (list - (lambda () (set! val (add1 val))) - (lambda () val) - (lambda () (set! val 0))))) - (inc) - (inc) - (assert = 2 (value)) - (inc) - (assert = 3 (value)) - (reset) - (assert = 0 (value)))) + (test-case "counter : match-define" + (let () + (match-define (list inc value reset) + (let ([val 0]) + (list + (lambda () (set! val (add1 val))) + (lambda () val) + (lambda () (set! val 0))))) + (inc) + (inc) + (check = 2 (value)) + (inc) + (check = 3 (value)) + (reset) + (check = 0 (value)))) )) (define struct*-tests - (make-test-suite + (test-suite "Tests of struct*" - (make-test-case "not an id for struct" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-struct tree (val left right)) - (match (make-tree 0 1 2) - [(struct* 4 ()) - #f])))))) - (make-test-case "not a struct-info for struct" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-syntax tree 1) - (match 1 - [(struct* tree ()) - #f])))))) - (make-test-case "bad form" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-struct tree (val left right)) - (match (make-tree 0 1 2) - [(struct* tree ([val])) - #f])))))) - (make-test-case "bad form" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-struct tree (val left right)) - (match (make-tree 0 1 2) - [(struct* tree (val)) - #f])))))) - (make-test-case "field appears twice" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-struct tree (val left right)) - (match (make-tree 0 1 2) - [(struct* tree ([val 0] [val 0])) - #f])))))) - (make-test-case "not a field" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-struct tree (val left right)) - (match (make-tree 0 1 2) - [(struct* tree ([feet 0])) - #f])))))) - (make-test-case "super structs don't work" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-struct extra (foo)) - (define-struct (tree extra) (val left right)) - (match (make-tree #f 0 1 2) - [(struct* tree ([extra #f] [val 0])) - #f])))))) - (make-test-case "super struct kinda work" - (let () - (define-struct extra (foo)) - (define-struct (tree extra) (val left right)) - (match (make-tree #f 0 1 2) - [(struct* tree ([val a])) - (assert = 0 a)]))) - (make-test-case "from documentation" - (let () - (define-struct tree (val left right)) - (match-define - (struct* - tree - ([val a] - [left - (struct* - tree - ([right #f] - [val b]))])) - (make-tree 0 (make-tree 1 #f #f) #f)) - (assert = 0 a) - (assert = 1 b))))) + (test-case "not an id for struct" + (check-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-struct tree (val left right)) + (match (make-tree 0 1 2) + [(struct* 4 ()) + #f])))))) + (test-case "not a struct-info for struct" + (check-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-syntax tree 1) + (match 1 + [(struct* tree ()) + #f])))))) + (test-case "bad form" + (check-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-struct tree (val left right)) + (match (make-tree 0 1 2) + [(struct* tree ([val])) + #f])))))) + (test-case "bad form" + (check-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-struct tree (val left right)) + (match (make-tree 0 1 2) + [(struct* tree (val)) + #f])))))) + (test-case "field appears twice" + (check-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-struct tree (val left right)) + (match (make-tree 0 1 2) + [(struct* tree ([val 0] [val 0])) + #f])))))) + (test-case "not a field" + (check-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-struct tree (val left right)) + (match (make-tree 0 1 2) + [(struct* tree ([feet 0])) + #f])))))) + (test-case "super structs don't work" + (check-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-struct extra (foo)) + (define-struct (tree extra) (val left right)) + (match (make-tree #f 0 1 2) + [(struct* tree ([extra #f] [val 0])) + #f])))))) + (test-case "super struct kinda work" + (let () + (define-struct extra (foo)) + (define-struct (tree extra) (val left right)) + (match (make-tree #f 0 1 2) + [(struct* tree ([val a])) + (check = 0 a)]))) + (test-case "from documentation" + (let () + (define-struct tree (val left right)) + (match-define + (struct* + tree + ([val a] + [left + (struct* + tree + ([right #f] + [val b]))])) + (make-tree 0 (make-tree 1 #f #f) #f)) + (check = 0 a) + (check = 1 b))))) (define plt-match-tests - (make-test-suite "Tests for plt-match.ss" - doc-tests - cons-tests - simple-tests - nonlinear-tests - match-expander-tests - reg-tests - struct*-tests - )) + (test-suite "Tests for plt-match.ss" + doc-tests + cons-tests + simple-tests + nonlinear-tests + match-expander-tests + reg-tests + struct*-tests)) -(define (run-tests) - (test/text-ui (make-test-suite "Match Tests" - plt-match-tests - match-tests - new-tests - ;; from bruce - other-tests - other-plt-tests - ))) -(unless (= 0 (run-tests)) +(define (run-all-tests) + (run-tests (test-suite "Match Tests" + plt-match-tests + match-tests + new-tests + ;; from bruce + other-tests + other-plt-tests) + 'verbose)) + +(unless (= 0 (run-all-tests)) (error "Match Tests did not pass."))