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