1;;;; match.test --- (ice-9 match)  -*- mode: scheme; coding: utf-8; -*-
2;;;;
3;;;; 	Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
4;;;;
5;;;; This library is free software; you can redistribute it and/or
6;;;; modify it under the terms of the GNU Lesser General Public
7;;;; License as published by the Free Software Foundation; either
8;;;; version 3 of the License, or (at your option) any later version.
9;;;;
10;;;; This library is distributed in the hope that it will be useful,
11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13;;;; Lesser General Public License for more details.
14;;;;
15;;;; You should have received a copy of the GNU Lesser General Public
16;;;; License along with this library; if not, write to the Free Software
17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19(define-module (test-match)
20  #:use-module (ice-9 match)
21  #:use-module (srfi srfi-9)
22  #:use-module (test-suite lib))
23
24(define exception:match-error
25  (cons 'match-error "^.*$"))
26
27(define-record-type rtd-2-slots
28  (make-2-slot-record a b)
29  two-slot-record?
30  (a slot-first)
31  (b slot-second))
32
33(define-record-type rtd-3-slots
34  (make-3-slot-record a b c)
35  three-slot-record?
36  (a slot-one)
37  (b slot-two)
38  (c slot-three))
39
40
41(with-test-prefix "matches"
42
43  (pass-if "wildcard"
44    (match "hello" (_ #t)))
45
46  (pass-if "symbol"
47    (match 'foo ('foo #t)))
48
49  (pass-if "string"
50    (match "bar" ("bar" #t)))
51
52  (pass-if "number"
53    (match 777 (777 #t)))
54
55  (pass-if "char"
56    (match #\g (#\g #t)))
57
58  (pass-if "sexp"
59    (match '(a b c) ('(a b c) #t)))
60
61  (pass-if "predicate"
62    (match '(a 1 2)
63      (('a (and (? odd?) one) (? even?))
64       (= one 1))))
65
66  (pass-if "list"
67    (let ((lst '(a b c)))
68      (match lst
69        ((x y z)
70         (equal? (list x y z) lst)))))
71
72  (pass-if "list rest..."
73    (let ((lst '(a b c)))
74      (match lst
75        ((x rest ...)
76         (and (eq? x 'a) (equal? rest '(b c)))))))
77
78  (pass-if "list . rest"
79    (let ((lst '(a b c)))
80      (match lst
81        ((x . rest)
82         (and (eq? x 'a) (equal? rest '(b c)))))))
83
84  (pass-if "list ..1"
85    (match '(a b c)
86      ((x ..1)
87       (equal? x '(a b c)))))
88
89  (pass-if "list ..1, with predicate"
90    (match '(a b c)
91      (((and x (? symbol?)) ..1)
92       (equal? x '(a b c)))))
93
94  (pass-if "list ..1, nested"
95    (match '((1 2) (3 4))
96      (((x ..1) ..1)
97       (equal? x '((1 2) (3 4))))))
98
99  (pass-if "tree"
100    (let ((tree '(one (two 2) (three 3 (and 4 (and 5))))))
101      (match tree
102        (('one ('two x) ('three y ('and z '(and 5))))
103         (equal? (list x y z) '(2 3 4))))))
104
105  (pass-if "and, unique names"
106    (let ((tree '(1 2)))
107      (match tree
108        ((and (a 2) (1 b))
109         (equal? 3 (+ a b))))))
110
111  (pass-if "and, same names"
112    (let ((a '(1 2)))
113      (match a
114        ((and (a 2) (1 b))
115         (equal? 3 (+ a b))))))
116
117  (with-test-prefix "records"
118
119    (pass-if "all slots, bind"
120      (let ((r (make-3-slot-record 1 2 3)))
121        (match r
122          (($ rtd-3-slots a b c)
123           (equal? (list a b c) '(1 2 3))))))
124
125    (pass-if "all slots, literals"
126      (let ((r (make-3-slot-record 1 2 3)))
127        (match r
128          (($ rtd-3-slots 1 2 3)
129           #t))))
130
131    (pass-if "2 slots"
132      (let ((r (make-3-slot-record 1 2 3)))
133        (match r
134          (($ rtd-3-slots x y)
135           (equal? (list x y) '(1 2))))))
136
137    (pass-if "RTD correctly checked"
138      (let ((r (make-2-slot-record 1 2)))
139        (match r
140          (($ rtd-3-slots a b)
141           #f)
142          (($ rtd-2-slots a b)
143           (equal? (list a b) '(1 2))))))
144
145    (pass-if "getter"
146      (match (make-2-slot-record 1 2)
147        (($ rtd-2-slots (get! first) (get! second))
148         (equal? (list (first) (second)) '(1 2)))))
149
150    (pass-if "setter"
151      (let ((r (make-2-slot-record 1 2)))
152        (match r
153          (($ rtd-2-slots (set! set-first!) (set! set-second!))
154           (set-first! 'one)
155           (set-second! 'two)
156           (equal? (list (slot-first r) (slot-second r))
157                   '(one two))))))))
158
159
160(with-test-prefix "doesn't match"
161
162  (pass-if-exception "tree"
163    exception:match-error
164    (match '(a (b c))
165      ((foo (bar)) #t)))
166
167  (pass-if-exception "list ..1"
168    exception:match-error
169    (match '()
170      ((x ..1) #f)))
171
172  (pass-if-exception "list ..1, with predicate"
173    exception:match-error
174    (match '(a 0)
175      (((and x (? symbol?)) ..1)
176       (equal? x '(a b c)))))
177
178  (with-test-prefix "records"
179
180    (pass-if "not a record"
181      (match "hello"
182        (($ rtd-2-slots) #f)
183        (_               #t)))
184
185    (pass-if-exception "too many slots"
186      exception:out-of-range
187      (let ((r (make-3-slot-record 1 2 3)))
188        (match r
189          (($ rtd-3-slots a b c d)
190           #f))))))
191
192
193;;;
194;;; Upstream tests, from Chibi-Scheme (3-clause BSD license).
195;;;
196
197(let-syntax ((load       (syntax-rules ()
198                           ((_ file) #t)))
199             (test       (syntax-rules ()
200                           ((_ name expected expr)
201                            (pass-if name
202                                     (equal? expected expr)))))
203             (test-begin (syntax-rules ()
204                           ((_ name) #t)))
205             (test-end   (syntax-rules ()
206                           ((_) #t))))
207  (with-test-prefix "upstream tests"
208    (include-from-path "tests/match.test.upstream")))
209