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
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)))))
112