exn-test.ss
#lang scheme/base

(require mzlib/etc
         srfi/13/string
         (file "test-base.ss"))

; (struct immutable-string contunation-marks any)
(define-struct (exn:test exn) (extra-arg) #:transparent)

; Tests ------------------------------------------

(define exn-tests
  (test-suite "exn.ss"
    
    (test-case "raise-exn raises an exception"
      (check-exn
          exn:fail:unlib?
        (lambda ()
          (raise-exn exn:fail:unlib
            "This is an exception."))))
    
    (test-case "raise-exn passes extra arguments to exception constructor"
      (with-handlers ([exn:test?
                       (lambda (exn)
                         (check-equal? (exn:test-extra-arg exn) 
                                       123))])
        (raise-exn exn:test "Message" 123)))
    
    (test-case "reraise-exn raises an exception"
      (check-exn
          exn:unlib?
        (lambda ()
          (reraise-exn (make-exn "Boo!" (current-continuation-marks))
                       exn:unlib
                       "Foo!"))))
    
    (test-case "reraise-exn includes old and new messages"
      (with-handlers 
          ([exn:unlib?
            (lambda (exn)
              (let ([msg (exn-message exn)])
                (check string-contains msg "Boo!")
                (check string-contains msg "Foo!")))])
        (reraise-exn (make-exn "Boo!" (current-continuation-marks))
                     exn:unlib
                     "Foo!")))
    
    (test-case "reraise-exn includes continuation marks of original exn"
      (let ([marks #f]
            [exn #f])
        (with-handlers
            ([exn?
              (lambda (e)
                (set! marks (exn-continuation-marks e))
                (set! exn e))])
          (raise (make-exn "This is an exception" (current-continuation-marks))))
        (with-handlers
            ([exn:unlib?
              (lambda (e)
                (check-equal? (exn-continuation-marks e) marks))])
          (reraise-exn exn exn:unlib "Foo!"))))
    
    (test-case "reraise-exn passes extra arguments to exception constructor"
      (with-handlers ([exn:test?
                       (lambda (exn)
                         (check-equal? (exn:test-extra-arg exn) 
                                       123))])
        (reraise-exn (with-handlers ([exn? identity])
                       (raise-exn exn "Message 1"))
                     exn:test
                     "Message 2"
                     123)))
    
    ))

; Provide statements -----------------------------

(provide exn-tests)