r6rs-conditions.test 4.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112
  1. ;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions)
  2. ;; Copyright (C) 2010 Free Software Foundation, Inc.
  3. ;;
  4. ;; This library is free software; you can redistribute it and/or
  5. ;; modify it under the terms of the GNU Lesser General Public
  6. ;; License as published by the Free Software Foundation; either
  7. ;; version 3 of the License, or (at your option) any later version.
  8. ;;
  9. ;; This library is distributed in the hope that it will be useful,
  10. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;; Lesser General Public License for more details.
  13. ;;
  14. ;; You should have received a copy of the GNU Lesser General Public
  15. ;; License along with this library; if not, write to the Free Software
  16. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17. (define-module (test-suite test-rnrs-conditions)
  18. :use-module ((rnrs base) :version (6))
  19. :use-module ((rnrs conditions) :version (6))
  20. :use-module (test-suite lib))
  21. (define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
  22. (define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))
  23. (define-condition-type &c &condition make-c-condition c-condition?
  24. (baz c-baz)
  25. (qux c-qux)
  26. (frobotz c-frobotz))
  27. (with-test-prefix "condition?"
  28. (pass-if "condition? is #t for simple conditions"
  29. (condition? (make-error)))
  30. (pass-if "condition? is #t for compound conditions"
  31. (condition? (condition (make-error) (make-assertion-violation))))
  32. (pass-if "condition? is #f for non-conditions"
  33. (not (condition? 'foo))))
  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. (pass-if "simple-conditions flattens compound conditions"
  42. (let* ((implementation-restriction
  43. (make-implementation-restriction-violation))
  44. (error1 (make-error))
  45. (c1 (condition implementation-restriction error1))
  46. (error2 (make-error))
  47. (assertion (make-assertion-violation))
  48. (c2 (condition error2 assertion c1))
  49. (scs (simple-conditions c2)))
  50. (equal? scs (list error2 assertion implementation-restriction error1)))))
  51. (with-test-prefix "condition-predicate"
  52. (pass-if "returned procedure identifies matching simple conditions"
  53. (let ((mp (condition-predicate &message))
  54. (mc (make-message-condition "test")))
  55. (mp mc)))
  56. (pass-if "returned procedure identifies matching compound conditions"
  57. (let* ((sp (condition-predicate &serious))
  58. (vp (condition-predicate &violation))
  59. (sc (make-serious-condition))
  60. (vc (make-violation))
  61. (c (condition sc vc)))
  62. (and (sp c) (vp c))))
  63. (pass-if "returned procedure is #f for non-matching simple"
  64. (let ((sp (condition-predicate &serious)))
  65. (not (sp 'foo))))
  66. (pass-if "returned procedure is #f for compound without match"
  67. (let* ((ip (condition-predicate &irritants))
  68. (sc (make-serious-condition))
  69. (vc (make-violation))
  70. (c (condition sc vc)))
  71. (not (ip c)))))
  72. (with-test-prefix "condition-accessor"
  73. (pass-if "accessor applies proc to field from simple condition"
  74. (let* ((proc (lambda (c) (condition-message c)))
  75. (ma (condition-accessor &message proc))
  76. (mc (make-message-condition "foo")))
  77. (equal? (ma mc) "foo")))
  78. (pass-if "accessor applies proc to field from compound condition"
  79. (let* ((proc (lambda (c) (condition-message c)))
  80. (ma (condition-accessor &message proc))
  81. (mc (make-message-condition "foo"))
  82. (vc (make-violation))
  83. (c (condition vc mc)))
  84. (equal? (ma c) "foo"))))
  85. (with-test-prefix "define-condition-type"
  86. (pass-if "define-condition-type produces proper accessors"
  87. (let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
  88. (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
  89. (pass-if "define-condition-type works for multiple fields"
  90. (let ((c (condition (make-a-condition 'foo)
  91. (make-c-condition 1 2 3))))
  92. (and (eq? (a-foo c) 'foo)
  93. (= (c-baz c) 1)
  94. (= (c-qux c) 2)
  95. (= (c-frobotz c) 3)))))