fix for automated running
svn: r11903
This commit is contained in:
Sam Tobin-Hochstadt
parent
5844ef4a3d
commit
b81ba54dae
|
|
@ -1,233 +1,232 @@
|
||||||
(module plt-match-tests mzscheme
|
#lang scheme/base
|
||||||
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10)))
|
|
||||||
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10)))
|
|
||||||
|
|
||||||
(require mzlib/plt-match)
|
(require (for-syntax scheme/base))
|
||||||
|
|
||||||
(require "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss")
|
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10)))
|
||||||
|
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10)))
|
||||||
|
|
||||||
(require (planet "views.ss" ("cobbe" "views.plt" 1 1)))
|
(require mzlib/plt-match)
|
||||||
|
|
||||||
(define reg-tests
|
(require "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss")
|
||||||
(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])))))
|
|
||||||
(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)])))))
|
|
||||||
|
|
||||||
(define match-expander-tests
|
(require (planet "views.ss" ("cobbe" "views.plt" 1 1)))
|
||||||
(make-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 +
|
|
||||||
|
|
||||||
(make-test-case "Trivial expander w/ keywords"
|
(define reg-tests
|
||||||
(let ()
|
(make-test-suite "Tests for regressions"
|
||||||
(define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +)
|
(make-test-case "quote in qp"
|
||||||
(assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works
|
(assert eq? #t (match '(tile a b c)
|
||||||
(assert-true (match 3 [(bar) #t])) ; (bar) matches anything
|
[`(tile ,@'(a b c))
|
||||||
(assert = 12 (bar 3 4 5))
|
#t]
|
||||||
(assert = 12 (apply bar '(3 4 5))))) ; bar works like +
|
[else #f]))
|
||||||
|
(assert 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)])))))
|
||||||
|
|
||||||
;; gross hack to check for syntax errors
|
(define match-expander-tests
|
||||||
(make-test-case "Only one xform gives syntax error"
|
(make-test-suite
|
||||||
(assert-exn exn:fail:syntax?
|
"Tests for define-match-expander"
|
||||||
(lambda ()
|
(make-test-case "Trivial expander"
|
||||||
(expand #'(let ()
|
(let ()
|
||||||
(define-match-expander bar (lambda (x) #'_))
|
(define-match-expander bar (lambda (x) #'_) +)
|
||||||
(bar 3 4))))))
|
(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 +
|
||||||
|
|
||||||
;; more complex example from Dale
|
(make-test-case "Trivial expander w/ keywords"
|
||||||
(make-test-case "Point structs"
|
(let ()
|
||||||
(let ()
|
(define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +)
|
||||||
(define-struct point (x y))
|
(assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works
|
||||||
(define-match-expander Point
|
(assert-true (match 3 [(bar) #t])) ; (bar) matches anything
|
||||||
(lambda (x)
|
(assert = 12 (bar 3 4 5))
|
||||||
(syntax-case x ()
|
(assert = 12 (apply bar '(3 4 5))))) ; bar works like +
|
||||||
((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)]))
|
|
||||||
))
|
|
||||||
|
|
||||||
;; from richard's view documentation
|
;; 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))))))
|
||||||
|
|
||||||
(make-test-case "Natural number views"
|
;; more complex example from Dale
|
||||||
(let ()
|
(make-test-case "Point structs"
|
||||||
(define natural-number?
|
(let ()
|
||||||
(lambda (x)
|
(define-struct point (x y))
|
||||||
(and (integer? x)
|
(define-match-expander Point
|
||||||
(>= x 0))))
|
(lambda (x)
|
||||||
(define natural-zero? (lambda (x) (and (integer? x) (zero? x))))
|
(syntax-case x ()
|
||||||
|
((Point a b) #'(struct point (a b)))))
|
||||||
(define-view peano-zero natural-zero? ())
|
make-point)
|
||||||
(define-view peano-succ natural-number? (sub1))
|
;; check that it works as expression and as pattern
|
||||||
|
(assert = 5 (match (Point 2 3)
|
||||||
(define factorial
|
[(Point x y) (+ x y)]))
|
||||||
(match-lambda
|
;; check that sub-patterns still work
|
||||||
[(peano-zero) 1]
|
(assert = 7 (match (make-point 2 3)
|
||||||
[(and (peano-succ pred) n) (* n (factorial pred))]))
|
[(Point (app add1 x) (app add1 y)) (+ x y)]))
|
||||||
(assert = 120 (factorial 5))))
|
;; check that it works inside a list
|
||||||
|
(assert = 7 (match (list (make-point 2 3))
|
||||||
;; more complex example from Dale
|
[(list (Point (app add1 x) (app add1 y))) (+ x y)]))
|
||||||
(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)]))
|
|
||||||
))
|
|
||||||
))
|
|
||||||
|
|
||||||
(define simple-tests
|
|
||||||
(make-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)))))
|
|
||||||
))
|
|
||||||
|
|
||||||
(define nonlinear-tests
|
|
||||||
(make-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])))))
|
|
||||||
|
|
||||||
|
|
||||||
(define doc-tests
|
|
||||||
(make-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))))))
|
|
||||||
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
))
|
|
||||||
|
|
||||||
(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
|
|
||||||
))
|
))
|
||||||
|
|
||||||
(define (run-tests)
|
;; from richard's view documentation
|
||||||
(test/text-ui (make-test-suite "Match Tests"
|
|
||||||
plt-match-tests
|
(make-test-case "Natural number views"
|
||||||
match-tests
|
(let ()
|
||||||
new-tests
|
(define natural-number?
|
||||||
;; from bruce
|
(lambda (x)
|
||||||
other-tests
|
(and (integer? x)
|
||||||
other-plt-tests
|
(>= x 0))))
|
||||||
)))
|
(define natural-zero? (lambda (x) (and (integer? x) (zero? x))))
|
||||||
(if (getenv "PLT_TESTS")
|
|
||||||
(unless (parameterize ([current-output-port (open-output-string)])
|
(define-view peano-zero natural-zero? ())
|
||||||
(= 0 (run-tests)))
|
(define-view peano-succ natural-number? (sub1))
|
||||||
(error "Match Tests did not pass."))
|
|
||||||
(run-tests))
|
(define factorial
|
||||||
)
|
(match-lambda
|
||||||
|
[(peano-zero) 1]
|
||||||
|
[(and (peano-succ pred) n) (* n (factorial pred))]))
|
||||||
|
(assert = 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)]))
|
||||||
|
))
|
||||||
|
))
|
||||||
|
|
||||||
|
(define simple-tests
|
||||||
|
(make-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)))))
|
||||||
|
))
|
||||||
|
|
||||||
|
(define nonlinear-tests
|
||||||
|
(make-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])))))
|
||||||
|
|
||||||
|
|
||||||
|
(define doc-tests
|
||||||
|
(make-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))))))
|
||||||
|
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
))
|
||||||
|
|
||||||
|
(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
|
||||||
|
))
|
||||||
|
|
||||||
|
(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))
|
||||||
|
(error "Match Tests did not pass."))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user