(require-library simple-tests simple-exceptions)
(import simple-tests simple-exceptions)

(define-test (simple-exceptions?)
  (check
    "NAMED LAMBDA"
    (= ((named-lambda ! (n)
          (if (zero? n)
            1
            (* n (! (- n 1)))))
        5)
       120)
    "CHECKS"
    (= (>> 5) 5)
    (= (<< 5) 5)
    (= (<< 5 integer? odd? (named-lambda 5<= (x) (<= 5 x))) 5)
    (not (condition-case
           (>> 5 integer? even?)
           ((exn result) #f))) 
    (not (<< ((lambda () #f)) boolean?))
    (define (baz n)
      (abs (<< n 'baz number?)))
    (not (condition-case (baz "baz")
           ((exn argument) #f)))
    (not (with-exn-handler
           (lambda (exn)
             (if ((exn-of? 'argument) exn)
               #f
               #t))
           (lambda () (baz "baz"))))

    "EXCEPTIONS" 
    (define foo-exn (make-exn "foo-msg"))
    (define bar-exn (make-exn "bar-msg" 'bar))
    (exn? (foo-exn 'nowhere))

    (bar-exn 'nowhere)
    (exn? (bar-exn 'nowhere))

    ((exn-of? 'bar) (bar-exn 'nowhere))
    (not ((exn-of? 'bar) (foo-exn 'nowhere)))
    
    (equal?
      (arguments ((make-exn "msg" 'baz) 'nowhere "bar"))
      (list "bar"))

    ((exn-of? 'key)
     ((make-exn "msg" 'key) 'nowhere))

    (define list-empty-exn
      (make-exn "argument list empty" 'list-empty))

    (define (try-car lst)
      (if (null? lst)
        (raise (list-empty-exn 'try-car lst))
        (car lst)))
    
    ;; exception handler procedure
    (not (with-exn-handler
           (lambda (exn)
             (if ((exn-of? 'list-empty) exn)
               #f
               #t))
           (lambda () (try-car '()))))
    
    (zero? (with-exn-handler (lambda (e) 0) (lambda () (/ 5 0))))

    ;; the three high-level exception handler macros
    (not (condition-case (try-car '())
           ((exn list-empty) #f)))

    "GUARD"
    (null? (guard
             (exn (((exn-of? 'list-empty) exn)
                   (car (arguments exn)))
                  (else #f))
             (try-car '())))

    (null? (handle-exceptions exn
             (if ((exn-of? 'list-empty) exn)
               (car (arguments exn))
               #f)
             (try-car '())))

    (= (guard
         (exn ((assq 'a exn) => cdr)
              ((assq 'b exn)))
         (raise (list (cons 'a 42))))
       42)
    (equal? (guard
              (exn ((assq 'a exn) => cdr)
                   ((assq 'b exn)))
              (raise (list (cons 'b 23))))
            '(b . 23))
    (eq? (guard
           (exn (((exn-of? 'foo) exn)
                 (location exn))
                ((exn? exn)
                 (message exn))
                (else
                  (arguments exn)))
           (raise ((make-exn "msg" 'foo)
                    'location-unknown)))
          'location-unknown)
    (string=? (guard
                (exn (((exn-of? 'foo) exn)
                      (location exn))
                     ((exn? exn)
                      (message exn))
                     (else
                       (arguments exn)))
                (raise ((make-exn "nothing" 'bar) 'loc)))
              "nothing")
    (not (guard (exn (((exn-of? 'foo) exn)
                      (location exn))
                     ((exn? exn)
                      (message exn))
                     (else
                       #f)) 
                (raise 'bar)))

    (not (condition-case (assert* 'nowhere
                                  (= 1 1)
                                  (= 1 2))
           ((exn assert) #f)))
    ))

(compound-test (SIMPLE-EXEPTIONS)
  (simple-exceptions?)
  )