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 conditions) :version (6))
  22   :use-module (test-suite lib))
  23
  24 (with-test-prefix "condition?"
  25   (pass-if "condition? is #t for simple conditions"
  26     (condition? (make-error)))
  27
  28   (pass-if "condition? is #t for compound conditions"
  29     (condition? (condition (make-error) (make-assertion-violation))))
  30
  31   (pass-if "condition? is #f for non-conditions"
  32     (not (condition? 'foo))))
  33
  34 (with-test-prefix "simple-conditions"
  35   (pass-if "simple-conditions returns condition components"
  36     (let* ((error (make-error))
  37            (assertion (make-assertion-violation))
  38            (c (condition error assertion))
  39            (scs (simple-conditions c)))
  40       (equal? scs (list error assertion))))
  41
  42   (pass-if "simple-conditions flattens compound conditions"
  43     (let* ((implementation-restriction
  44             (make-implementation-restriction-violation))
  45            (error1 (make-error))
  46            (c1 (condition implementation-restriction error1))
  47            (error2 (make-error))
  48            (assertion (make-assertion-violation))
  49            (c2 (condition error2 assertion c1))
  50            (scs (simple-conditions c2)))
  51       (equal? scs (list error2 assertion implementation-restriction error1)))))
  52
  53 (with-test-prefix "condition-predicate"
  54   (pass-if "returned procedure identifies matching simple conditions"
  55     (let ((mp (condition-predicate &message))
  56           (mc (make-message-condition "test")))
  57       (mp mc)))
  58
  59   (pass-if "returned procedure identifies matching compound conditions"
  60     (let* ((sp (condition-predicate &serious))
  61            (vp (condition-predicate &violation))
  62            (sc (make-serious-condition))
  63            (vc (make-violation))
  64            (c (condition sc vc)))
  65       (and (sp c) (vp c))))
  66
  67   (pass-if "returned procedure is #f for non-matching simple"
  68     (let ((sp (condition-predicate &serious)))
  69       (not (sp 'foo))))
  70
  71   (pass-if "returned procedure is #f for compound without match"
  72     (let* ((ip (condition-predicate &irritants))
  73            (sc (make-serious-condition))
  74            (vc (make-violation))
  75            (c (condition sc vc)))
  76       (not (ip c)))))
  77
  78 (with-test-prefix "condition-accessor"
  79   (pass-if "accessor applies proc to field from simple condition"
  80     (let* ((proc (lambda (c) (condition-message c)))
  81            (ma (condition-accessor &message proc))
  82            (mc (make-message-condition "foo")))
  83       (equal? (ma mc) "foo")))
  84
  85   (pass-if "accessor applies proc to field from compound condition"
  86     (let* ((proc (lambda (c) (condition-message c)))
  87            (ma (condition-accessor &message proc))
  88            (mc (make-message-condition "foo"))
  89            (vc (make-violation))
  90            (c (condition vc mc)))
  91       (equal? (ma c) "foo"))))