Switch to the current version of schemeunit.
svn: r18263
This commit is contained in:
Sam Tobin-Hochstadt
parent
1eea5163cc
commit
e417da3598
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,75 +1,73 @@
|
|||
(module match-tests mzscheme
|
||||
(require mzlib/match)
|
||||
|
||||
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10)))
|
||||
(require mzlib/match schemeunit)
|
||||
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
(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-view peano-zero natural-zero? ())
|
||||
(define-view peano-succ natural-number? (sub1))
|
||||
(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 factorial
|
||||
(match-lambda
|
||||
[(peano-zero) 1]
|
||||
[(and (peano-succ pred) n) (* n (factorial pred))]))
|
||||
(assert = 120 (factorial 5))))
|
||||
(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))
|
||||
(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 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 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))]))
|
||||
(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))))))
|
||||
(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."))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user