test-suite/tests/r6rs-enums.test

   1 ;;; r6rs-enums.test --- Test suite for R6RS (rnrs enums)
   2
   3 ;;      Copyright (C) 2010 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 \f
  19
  20 (define-module (test-suite test-rnrs-enums)
  21   :use-module ((rnrs conditions) :version (6))
  22   :use-module ((rnrs enums) :version (6))
  23   :use-module ((rnrs exceptions) :version (6))
  24   :use-module (test-suite lib))
  25
  26 (define-enumeration foo-enumeration (foo bar baz) make-foo-set)
  27
  28 (with-test-prefix "enum-set-universe"
  29   (pass-if "universe of an enumeration is itself"
  30     (let ((et (make-enumeration '(a b c))))
  31       (eq? (enum-set-universe et) et)))
  32
  33   (pass-if "enum-set-universe returns universe"
  34     (let* ((et (make-enumeration '(a b c)))
  35            (es ((enum-set-constructor et) '(a b))))
  36       (eq? (enum-set-universe es) et))))
  37
  38 (with-test-prefix "enum-set-indexer"
  39   (pass-if "indexer returns index of symbol in universe"
  40     (let* ((universe (make-enumeration '(a b c)))
  41            (set ((enum-set-constructor universe) '(a c)))
  42            (indexer (enum-set-indexer set)))
  43       (and (eqv? (indexer 'a) 0) (eqv? (indexer 'c) 2))))
  44
  45   (pass-if "indexer returns index of symbol in universe but not set"
  46     (let* ((universe (make-enumeration '(a b c)))
  47            (set ((enum-set-constructor universe) '(a c)))
  48            (indexer (enum-set-indexer set)))
  49       (eqv? (indexer 'b) 1)))
  50
  51   (pass-if "indexer returns #f for symbol not in universe"
  52     (let* ((universe (make-enumeration '(a b c)))
  53            (set ((enum-set-constructor universe) '(a b c)))
  54            (indexer (enum-set-indexer set)))
  55       (eqv? (indexer 'd) #f))))
  56
  57 (with-test-prefix "enum-set->list"
  58   (pass-if "enum-set->list returns members in universe order"
  59     (let* ((universe (make-enumeration '(a b c d e)))
  60            (set ((enum-set-constructor universe) '(d a e c))))
  61       (equal? (enum-set->list set) '(a c d e)))))
  62
  63 (with-test-prefix "enum-set-member?"
  64   (pass-if "enum-set-member? is #t for set members"
  65     (let* ((universe (make-enumeration '(a b c)))
  66            (set ((enum-set-constructor universe) '(a b c))))
  67       (enum-set-member? 'a set)))
  68
  69   (pass-if "enum-set-member? is #f for set non-members"
  70     (let* ((universe (make-enumeration '(a b c)))
  71            (set ((enum-set-constructor universe) '(a b c))))
  72       (not (enum-set-member? 'd set))))
  73
  74   (pass-if "enum-set-member? is #f for universe but not set members"
  75     (let* ((universe (make-enumeration '(a b c d)))
  76            (set ((enum-set-constructor universe) '(a b c))))
  77       (not (enum-set-member? 'd set)))))
  78
  79 (with-test-prefix "enum-set-subset?"
  80   (pass-if "enum-set-subset? is #t when set1 subset of set2"
  81     (let* ((universe (make-enumeration '(a b c d e)))
  82            (set1 ((enum-set-constructor universe) '(a b c)))
  83            (set2 ((enum-set-constructor universe) '(a b c d))))
  84       (enum-set-subset? set1 set2)))
  85
  86   (pass-if "enum-set-subset? is #t when universe and set are subsets"
  87     (let* ((universe1 (make-enumeration '(a b c d)))
  88            (universe2 (make-enumeration '(a b c d e)))
  89            (set1 ((enum-set-constructor universe1) '(a b c)))
  90            (set2 ((enum-set-constructor universe2) '(a b c d))))
  91       (enum-set-subset? set1 set2)))
  92
  93   (pass-if "enum-set-subset? is #f when set not subset"
  94     (let* ((universe (make-enumeration '(a b c d e)))
  95            (set1 ((enum-set-constructor universe) '(a b c d)))
  96            (set2 ((enum-set-constructor universe) '(a b c))))
  97       (not (enum-set-subset? set1 set2))))
  98
  99   (pass-if "enum-set-subset? is #f when universe not subset"
 100     (let* ((universe1 (make-enumeration '(a b c d e)))
 101            (universe2 (make-enumeration '(a b c d)))
 102            (set1 ((enum-set-constructor universe1) '(a b c)))
 103            (set2 ((enum-set-constructor universe2) '(a b c d))))
 104       (not (enum-set-subset? set1 set2)))))
 105
 106 (with-test-prefix "enum-set=?"
 107   (pass-if "enum-set=? is #t when sets are equal"
 108     (let* ((universe1 (make-enumeration '(a b c)))
 109            (universe2 (make-enumeration '(a b c)))
 110            (set1 ((enum-set-constructor universe1) '(a b c)))
 111            (set2 ((enum-set-constructor universe2) '(a b c))))
 112       (enum-set=? set1 set2)))
 113
 114   (pass-if "enum-set=? is #f when sets are not equal"
 115     (let* ((universe (make-enumeration '(a b c d)))
 116            (set1 ((enum-set-constructor universe) '(a b)))
 117            (set2 ((enum-set-constructor universe) '(c d))))
 118       (not (enum-set=? set1 set2))))
 119
 120   (pass-if "enum-set=? is #f when universes are not equal"
 121     (let* ((universe1 (make-enumeration '(a b c d)))
 122            (universe2 (make-enumeration '(a b c d e)))
 123            (set1 ((enum-set-constructor universe1) '(a b c d)))
 124            (set2 ((enum-set-constructor universe2) '(a b c d))))
 125       (not (enum-set=? set1 set2)))))
 126
 127 (with-test-prefix "enum-set-union"
 128   (pass-if "&assertion raised on different universes"
 129     (guard (condition ((assertion-violation? condition) #t))
 130            (let* ((universe1 (make-enumeration '(a b c)))
 131                   (universe2 (make-enumeration '(d e f)))
 132                   (set1 ((enum-set-constructor universe1) '(a b c)))
 133                   (set2 ((enum-set-constructor universe2) '(d e f))))
 134              (enum-set-union set1 set2)
 135              #f)))
 136
 137   (pass-if "enum-set-union creates union on overlapping sets"
 138     (let* ((universe (make-enumeration '(a b c d e)))
 139            (set1 ((enum-set-constructor universe) '(a b c)))
 140            (set2 ((enum-set-constructor universe) '(c d e)))
 141            (union (enum-set-union set1 set2)))
 142       (equal? (enum-set->list union) '(a b c d e))))
 143
 144   (pass-if "enum-set-union creates union on disjoint sets"
 145     (let* ((universe (make-enumeration '(a b c d e f)))
 146            (set1 ((enum-set-constructor universe) '(a b c)))
 147            (set2 ((enum-set-constructor universe) '(d e f)))
 148            (union (enum-set-union set1 set2)))
 149       (equal? (enum-set->list union) '(a b c d e f))))
 150
 151   (pass-if "enum-set-union operates on syntactically-generated sets"
 152     (let* ((set1 (make-foo-set foo))
 153            (set2 (make-foo-set bar))
 154            (union (enum-set-union set1 set2)))
 155       (equal? (enum-set->list union) '(foo bar)))))
 156
 157 (with-test-prefix "enum-set-intersection"
 158   (pass-if "&assertion raised on different universes"
 159     (guard (condition ((assertion-violation? condition) #t))
 160            (let* ((universe1 (make-enumeration '(a b c)))
 161                   (universe2 (make-enumeration '(d e f)))
 162                   (set1 ((enum-set-constructor universe1) '(a b c)))
 163                   (set2 ((enum-set-constructor universe2) '(d e f))))
 164              (enum-set-intersection set1 set2)
 165              #f)))
 166
 167   (pass-if "enum-set-intersection on overlapping sets"
 168     (let* ((universe (make-enumeration '(a b c d e)))
 169            (set1 ((enum-set-constructor universe) '(a b c)))
 170            (set2 ((enum-set-constructor universe) '(c d e)))
 171            (intersection (enum-set-intersection set1 set2)))
 172       (equal? (enum-set->list intersection) '(c))))
 173
 174   (pass-if "enum-set-intersection on disjoint sets"
 175     (let* ((universe (make-enumeration '(a b c d e f)))
 176            (set1 ((enum-set-constructor universe) '(a b c)))
 177            (set2 ((enum-set-constructor universe) '(d e f)))
 178            (intersection (enum-set-intersection set1 set2)))
 179       (null? (enum-set->list intersection))))
 180
 181   (pass-if "enum-set-intersection on syntactically-generated sets"
 182     (let* ((set1 (make-foo-set foo bar))
 183            (set2 (make-foo-set bar baz))
 184            (intersection (enum-set-intersection set1 set2)))
 185       (equal? (enum-set->list intersection) '(bar)))))
 186
 187 (with-test-prefix "enum-set-difference"
 188   (pass-if "&assertion raised on different universes"
 189     (guard (condition ((assertion-violation? condition) #t))
 190            (let* ((universe1 (make-enumeration '(a b c)))
 191                   (universe2 (make-enumeration '(d e f)))
 192                   (set1 ((enum-set-constructor universe1) '(a b c)))
 193                   (set2 ((enum-set-constructor universe2) '(d e f))))
 194              (enum-set-difference set1 set2)
 195              #f)))
 196
 197   (pass-if "enum-set-difference with subset"
 198     (let* ((universe (make-enumeration '(a b c)))
 199            (set1 ((enum-set-constructor universe) '(a b c)))
 200            (set2 ((enum-set-constructor universe) '(a)))
 201            (difference (enum-set-difference set1 set2)))
 202       (equal? (enum-set->list difference) '(b c))))
 203
 204   (pass-if "enum-set-difference with superset is empty"
 205     (let* ((universe (make-enumeration '(a b c d)))
 206            (set1 ((enum-set-constructor universe) '(a b c)))
 207            (set2 ((enum-set-constructor universe) '(a b c d)))
 208            (difference (enum-set-difference set1 set2)))
 209       (null? (enum-set->list difference))))
 210
 211   (pass-if "enum-set-difference on syntactically-generated sets"
 212     (let* ((set1 (make-foo-set foo bar baz))
 213            (set2 (make-foo-set foo baz))
 214            (difference (enum-set-difference set1 set2)))
 215       (equal? (enum-set->list difference) '(bar)))))
 216
 217 (with-test-prefix "enum-set-complement"
 218   (pass-if "complement of empty set is universe"
 219     (let* ((universe (make-enumeration '(a b c)))
 220            (set ((enum-set-constructor universe) '()))
 221            (complement (enum-set-complement set)))
 222       (equal? (enum-set->list complement) (enum-set->list universe))))
 223
 224   (pass-if "simple complement"
 225     (let* ((universe (make-enumeration '(a b c d)))
 226            (set ((enum-set-constructor universe) '(a c)))
 227            (complement (enum-set-complement set)))
 228       (equal? (enum-set->list complement) '(b d)))))
 229
 230 (with-test-prefix "enum-set-projection"
 231   (pass-if "projection onto subset universe"
 232     (let* ((universe1 (make-enumeration '(a b c d)))
 233            (universe2 (make-enumeration '(a b c)))
 234            (set1 ((enum-set-constructor universe1) '(a d)))
 235            (set2 ((enum-set-constructor universe2) '(b c)))
 236            (projection (enum-set-projection set1 set2)))
 237       (equal? (enum-set->list projection) '(a))))
 238
 239   (pass-if "projection onto superset universe"
 240     (let* ((universe1 (make-enumeration '(a b c)))
 241            (universe2 (make-enumeration '(a b c d)))
 242            (set1 ((enum-set-constructor universe1) '(a c)))
 243            (set2 ((enum-set-constructor universe2) '(b d)))
 244            (projection (enum-set-projection set1 set2)))
 245       (equal? (enum-set->list projection) '(a c))))
 246
 247   (pass-if "projection onto disjoint universe"
 248     (let* ((universe1 (make-enumeration '(a b c)))
 249            (universe2 (make-enumeration '(d e f)))
 250            (set1 ((enum-set-constructor universe1) '(a c)))
 251            (set2 ((enum-set-constructor universe2) '(d f)))
 252            (projection (enum-set-projection set1 set2)))
 253       (equal? (enum-set->list projection) '()))))
 254
 255 (with-test-prefix "define-enumeration"
 256   (pass-if "define-enumeration creates bindings"
 257     (and (defined? 'foo-enumeration) (defined? 'make-foo-set)))
 258
 259   (pass-if "type-name syntax raises &syntax on non-member"
 260     (guard (condition ((syntax-violation? condition) #t))
 261            (begin (eval '(foo-enumeration a) (current-module)) #f)))
 262
 263   (pass-if "type-name evaluates to quote on member"
 264     (guard (condition ((syntax-violation? condition) #f))
 265            (eq? (eval '(foo-enumeration foo) (current-module)) 'foo)))
 266
 267   (pass-if "constructor-syntax raises &syntax on non-members"
 268     (guard (condition ((syntax-violation? condition) #t))
 269            (begin (eval '(make-foo-set foo bar not-baz) (current-module)) #f)))
 270
 271   (pass-if "constructor-syntax evaluates to new set"
 272     (guard (condition ((syntax-violation? condition) #f))
 273            (equal? (enum-set->list (eval '(make-foo-set foo bar)
 274                                          (current-module)))
 275                    '(foo bar)))))