;;; run.scm
;;;
;;; Some tests for srfi-34 egg
;;;

(require-extension srfi-34)

(unless (eq? 'bizarre-exception 
	     (guard ( e [(eq? e 'weird-exception) e]
			[(eq? e 'odd-exception) e]
			[else e])
		    (raise 'bizarre-exception)))
	(error "Failed test 1"))

(unless (eq? 42 
	     (guard (condition
		     ((assq 'a condition) => cdr)
		     ((assq 'b condition)))
		    (raise (list (cons 'a 42)))))
	(error "Failed test 2"))

(unless (equal? (cons 'b 23)
		(guard (condition
			((assq 'a condition) => cdr)
			((assq 'b condition)))
		       (raise (list (cons 'b 23)))))
	(error "Failed test 3"))

(unless (eq? 'an-exception
	     (call-with-current-continuation 
	      (lambda (k)
		(with-exception-handler 
		 (lambda (e) (k e))
		 (lambda ()
		   (raise 'an-exception))))))
	(error "Failed test 4"))

;; From the SRFI document

(assert
 (equal?
  "condition: an-error\n"
  (with-output-to-string
    (lambda ()
      (call-with-current-continuation
       (lambda (k)
         (with-exception-handler (lambda (x)
                                   (display "condition: ")
                                   (write x)
                                   (newline)
                                   (k 'exception))
                                 (lambda ()
                                   (+ 1 (raise 'an-error))))))))))

;; This prints something went wrong and then "behaves in an
;; unspecified way", according to the SRFI.  Here, it raises
;; an exception but we can't really catch it...
#;
(assert
 (equal?
  "something went wrong\n"
  (with-output-to-string
    (lambda ()
      (call-with-current-continuation
       (lambda (k)
         (with-exception-handler (lambda (x)
                                   (display "something went wrong")
                                   (newline)
                                   'dont-care)
                                 (lambda ()
                                   (+ 1 (raise 'an-error))))))))))

(assert
 (equal?
  "condition: an-error\n"
  (with-output-to-string
    (lambda ()
      (assert (equal?
               'exception
               (guard (condition
                       (else
                        (display "condition: ")
                        (write condition)
                        (newline)
                        'exception))
                      (+ 1 (raise 'an-error)))))))))

(assert
 (equal?
  ""
  (with-output-to-string
    (lambda ()
      (assert
       (equal?
        "something went wrong\n"
        (with-output-to-string
          (lambda ()
            (guard (condition
                    (else
                     (display "something went wrong")
                     (newline)
                     'dont-care))
                   (+ 1 (raise 'an-error)))))))))))


(assert
 (equal?
  ""
  (with-output-to-string
    (lambda ()
      (assert
       (equal?
        'positive
        (call-with-current-continuation
         (lambda (k)
           (with-exception-handler (lambda (x)
                                     (display "reraised ") (write x) (newline)
                                     (k 'zero))
                                   (lambda ()
                                     (guard (condition
                                             ((positive? condition) 'positive)
                                             ((negative? condition) 'negative))
                                            (raise 1))))))))))))

(assert
 (equal?
  ""
  (with-output-to-string
    (lambda ()
      (assert
       (equal?
        'negative
        (call-with-current-continuation
         (lambda (k)
           (with-exception-handler (lambda (x)
                                     (display "reraised ") (write x) (newline)
                                     (k 'zero))
                                   (lambda ()
                                     (guard (condition
                                             ((positive? condition) 'positive)
                                             ((negative? condition) 'negative))
                                            (raise -1))))))))))))

(assert
 (equal?
  "reraised 0\n"
  (with-output-to-string
   (lambda ()
     (assert
      (equal?
       'zero
       (call-with-current-continuation
        (lambda (k)
          (with-exception-handler (lambda (x)
                                    (display "reraised ") (write x) (newline)
                                    (k 'zero))
                                  (lambda ()
                                    (guard (condition
                                            ((positive? condition) 'positive)
                                            ((negative? condition) 'negative))
                                           (raise 0))))))))))))

(assert
 (equal?
  42
  (guard (condition
          ((assq 'a condition) => cdr)
          ((assq 'b condition)))
         (raise (list (cons 'a 42))))))

(assert
 (equal?
  '(b . 23)
  (guard (condition
          ((assq 'a condition) => cdr)
          ((assq 'b condition)))
         (raise (list (cons 'b 23))))))

(display "srfi-34 tests succeeded")(newline)