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)))))

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

@ -1,316 +1,360 @@
#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
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((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 ()
(define natural-number? ;; the view implementation from planet:
(lambda (x) (define-match-expander view
(and (integer? x) (lambda (stx)
(>= x 0)))) (syntax-case stx ()
(define natural-zero? (lambda (x) (and (integer? x) (zero? x)))) [(_ 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-view peano-zero natural-zero? ()) (define-syntax define-view
(define-view peano-succ natural-number? (sub1)) (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 factorial (define natural-number?
(match-lambda (lambda (x)
[(peano-zero) 1] (and (integer? x)
[(and (peano-succ pred) n) (* n (factorial pred))])) (>= x 0))))
(assert = 120 (factorial 5)))) (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 ;; 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
#:plt-match #:plt-match
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((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))
(define-struct Const (n)) (define-struct Const (n))
(define-struct App (fun args)) (define-struct App (fun args))
(define parse (define parse
(match-lambda (match-lambda
[(and s (? symbol?) (not 'lambda)) [(and s (? symbol?) (not 'lambda))
(make-Var s)] (make-Var s)]
[(? number? n) [(? number? n)
(make-Const n)] (make-Const n)]
[(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body) [(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body)
(make-Lam args (parse body))] (make-Lam args (parse body))]
[(list f args ...) [(list f args ...)
(make-App (make-App
(parse f) (parse f)
(map parse args))] (map parse args))]
[x (error 'syntax "invalid expression")])) [x (error 'syntax "invalid expression")]))
(define repeats? (define repeats?
(lambda (l) (lambda (l)
(and (not (null? l)) (and (not (null? l))
(or (memq (car l) (cdr l)) (repeats? (cdr l)))))) (or (memq (car l) (cdr l)) (repeats? (cdr l))))))
(define unparse (define unparse
(match-lambda (match-lambda
[(struct Var (s)) s] [(struct Var (s)) s]
[(struct Const (n)) n] [(struct Const (n)) n]
[(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])
(list (list
(lambda () (set! val (add1 val))) (lambda () (set! val (add1 val)))
(lambda () val) (lambda () val)
(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))
(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 ([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
(struct* (struct*
tree tree
([val a] ([val a]
[left [left
(struct* (struct*
tree tree
([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."))