361 lines
15 KiB
Racket
361 lines
15 KiB
Racket
#lang scheme/base
|
|
|
|
(require (for-syntax scheme/base)
|
|
"match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss"
|
|
rackunit rackunit/text-ui)
|
|
|
|
(require mzlib/plt-match)
|
|
|
|
;(require (planet "views.ss" ("cobbe" "views.plt" 1 1)))
|
|
|
|
(define reg-tests
|
|
(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
|
|
(test-suite "Tests for cons pattern"
|
|
(test-case "simple"
|
|
(check = 3 (match (cons 1 2) [(cons a b) (+ a b)])))))
|
|
|
|
(define match-expander-tests
|
|
(test-suite
|
|
"Tests for define-match-expander"
|
|
(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 +
|
|
|
|
(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
|
|
(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
|
|
(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
|
|
|
|
(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
|
|
(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
|
|
(test-suite
|
|
"Some Simple Tests"
|
|
(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
|
|
(test-suite
|
|
"Non-linear patterns"
|
|
(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
|
|
(test-suite
|
|
"Tests from Help Desk Documentation"
|
|
(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))))))
|
|
|
|
(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
|
|
(test-suite
|
|
"Tests of struct*"
|
|
(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
|
|
(test-suite "Tests for plt-match.ss"
|
|
doc-tests
|
|
cons-tests
|
|
simple-tests
|
|
nonlinear-tests
|
|
match-expander-tests
|
|
reg-tests
|
|
struct*-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."))
|