1#lang racket/base
2
3(provide all-match-tests)
4
5(require rackunit
6	 deinprogramm/DMdA/define-record-procedures
7	 (only-in deinprogramm/DMdA/private/primitives match empty make-pair))
8
9(define-record-procedures pare
10  kons pare?
11  (kar kdr))
12
13(define-record-procedures bare
14  gons bare?
15  (gar gdr))
16
17(define-record-procedures nullary
18  make-nullary nullary?
19  ())
20
21(define all-match-tests
22  (test-suite
23   "Tests for DeinProgramm match form."
24
25   (test-case
26    "literals"
27    (define foo
28      (lambda (x)
29	(match x
30	  (#t 'true)
31	  (#f 'false)
32	  ('() 'nil)
33	  ('(foo bar) 'foobar)
34	  ("foo" 'foo)
35	  ("bar" 'bar)
36	  (5 'five)
37	  (2 'two))))
38
39    (check-equal? (foo #t) 'true)
40    (check-equal? (foo #f) 'false)
41    (check-equal? (foo '()) 'nil)
42    (check-equal? (foo '(foo bar)) 'foobar)
43    (check-equal? (foo "foo") 'foo)
44    (check-equal? (foo "bar") 'bar)
45    (check-equal? (foo 5) 'five)
46    (check-equal? (foo 2) 'two))
47
48
49   (test-case
50    "variables"
51    (define foo
52      (lambda (x)
53	(match x
54	  (#t  'true)
55	  (foo (list 'foo foo)))))
56    (check-equal? (foo #t) 'true)
57    (check-equal? (foo "foo") '(foo "foo")))
58
59   (test-case
60    "lists"
61    (define foo
62      (lambda (x)
63	(match x
64	  (empty 'empty)
65	  ((make-pair 'foo empty) 'fooempty)
66	  ((list 'foo 'bar) 'listfoobar)
67	  ((list 'bar 'foo) 'listbarfoo)
68	  ((list a b c) (list 'list a b c))
69	  ((make-pair 5 b) (list 'make-pair5 b))
70	  ((make-pair a (make-pair b c)) (list 'make-pair a b c))
71	  ((make-pair a b) (list 'make-pair a b))
72	  (x (list 'x x)))))
73
74    (check-equal? (foo empty) 'empty)
75    (check-equal? (foo "empty") '(x "empty"))
76    (check-equal? (foo (list 1 2 3)) '(list 1 2 3))
77    (check-equal? (foo (make-pair 'foo empty)) 'fooempty)
78    (check-equal? (foo (make-pair 1 empty)) '(make-pair 1 ()))
79    (check-equal? (foo (make-pair 5 empty)) '(make-pair5 ()))
80    (check-equal? (foo (list 1 2)) '(make-pair 1 2 ()))
81    (check-equal? (match empty ((list) 'bingo)) 'bingo)
82    (check-equal? (match (list 1) ((list) 'bingo) (foo foo)) (list 1))
83    (check-equal? (foo (list 'foo 'bar)) 'listfoobar)
84    (check-equal? (foo (list 'bar 'foo)) 'listbarfoo))
85
86   (test-case
87    "anything"
88    (check-equal? (match 5 (_ 7)) 7)
89    (check-equal? (match '(1 2) (_ 7)) 7)
90    (check-equal? (match #f (_ 7)) 7)
91    (check-equal? (let ((_ 5)) (match #f (_ _))) 5)
92    (check-equal? (match #f
93		    ((kons _ _) 7)
94		    (_ 5))
95		  5)
96    (check-equal? (match (kons 1 2)
97		    ((kons _ _) 7)
98		    (_ 5))
99		  7))
100
101   (test-case
102    "records"
103    (define foo
104      (lambda (x)
105	(match x
106	  ((make-pair foo empty) 'pairfoo)
107	  ((make-nullary) 'nullary)
108	  ((kons a b) (list 'kons a b))
109	  ((gons a b) (list 'gons a b)))))
110
111    (check-equal? (foo (make-pair foo empty)) 'pairfoo)
112    (check-equal? (foo (make-nullary)) 'nullary)
113    (check-equal? (foo (kons 1 2)) '(kons 1 2))
114    (check-equal? (foo (gons 1 2)) '(gons 1 2)))))
115