test-suite/tests/r6rs-conditions.test

   1 ;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions)
   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-conditions)
  21   :use-module ((rnrs base) :version (6))
  22   :use-module ((rnrs conditions) :version (6))
  23   :use-module (test-suite lib))
  24
  25 (define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
  26 (define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))
  27 (define-condition-type &c &condition make-c-condition c-condition?
  28   (baz c-baz)
  29   (qux c-qux)
  30   (frobotz c-frobotz))
  31
  32 (with-test-prefix "condition?"
  33   (pass-if "condition? is #t for simple conditions"
  34     (condition? (make-error)))
  35
  36   (pass-if "condition? is #t for compound conditions"
  37     (condition? (condition (make-error) (make-assertion-violation))))
  38
  39   (pass-if "condition? is #f for non-conditions"
  40     (not (condition? 'foo))))
  41
  42 (with-test-prefix "simple-conditions"
  43   (pass-if "simple-conditions returns condition components"
  44     (let* ((error (make-error))
  45            (assertion (make-assertion-violation))
  46            (c (condition error assertion))
  47            (scs (simple-conditions c)))
  48       (equal? scs (list error assertion))))
  49
  50   (pass-if "simple-conditions flattens compound conditions"
  51     (let* ((implementation-restriction
  52             (make-implementation-restriction-violation))
  53            (error1 (make-error))
  54            (c1 (condition implementation-restriction error1))
  55            (error2 (make-error))
  56            (assertion (make-assertion-violation))
  57            (c2 (condition error2 assertion c1))
  58            (scs (simple-conditions c2)))
  59       (equal? scs (list error2 assertion implementation-restriction error1)))))
  60
  61 (with-test-prefix "condition-predicate"
  62   (pass-if "returned procedure identifies matching simple conditions"
  63     (let ((mp (condition-predicate &message))
  64           (mc (make-message-condition "test")))
  65       (mp mc)))
  66
  67   (pass-if "returned procedure identifies matching compound conditions"
  68     (let* ((sp (condition-predicate &serious))
  69            (vp (condition-predicate &violation))
  70            (sc (make-serious-condition))
  71            (vc (make-violation))
  72            (c (condition sc vc)))
  73       (and (sp c) (vp c))))
  74
  75   (pass-if "returned procedure is #f for non-matching simple"
  76     (let ((sp (condition-predicate &serious)))
  77       (not (sp 'foo))))
  78
  79   (pass-if "returned procedure is #f for compound without match"
  80     (let* ((ip (condition-predicate &irritants))
  81            (sc (make-serious-condition))
  82            (vc (make-violation))
  83            (c (condition sc vc)))
  84       (not (ip c)))))
  85
  86 (with-test-prefix "condition-accessor"
  87   (pass-if "accessor applies proc to field from simple condition"
  88     (let* ((proc (lambda (c) (condition-message c)))
  89            (ma (condition-accessor &message proc))
  90            (mc (make-message-condition "foo")))
  91       (equal? (ma mc) "foo")))
  92
  93   (pass-if "accessor applies proc to field from compound condition"
  94     (let* ((proc (lambda (c) (condition-message c)))
  95            (ma (condition-accessor &message proc))
  96            (mc (make-message-condition "foo"))
  97            (vc (make-violation))
  98            (c (condition vc mc)))
  99       (equal? (ma c) "foo"))))
 100
 101 (with-test-prefix "define-condition-type"
 102   (pass-if "define-condition-type produces proper accessors"
 103     (let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
 104       (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
 105   (pass-if "define-condition-type works for multiple fields"
 106     (let ((c (condition (make-a-condition 'foo)
 107                         (make-c-condition 1 2 3))))
 108       (and (eq? (a-foo c) 'foo)
 109            (= (c-baz c) 1)
 110            (= (c-qux c) 2)
 111            (= (c-frobotz c) 3)))))