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