test-suite/tests/match.test

   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 \f
  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 \f
 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 \f
 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")))