;;;; condition-utils-test.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(import test)
(import (only (chicken format) format) (test-utils gloss))

(cond-expand
  (compiling
    (print)
    (print #<<EOS
*****
* Expect compiler wornings for type errors
*****
EOS
    ) )
  (else) )

(test-begin "Condition Utils")

;;;

(import condition-utils exn-condition)
(import (chicken condition) (chicken port))

(test-error "condition kind not false" (make-condition+ #f))
(test-error "property tag not false" (make-condition+ '(test a b #f ())))

(test-error "condition kind not false" (condition-predicate* #f))
(test-assert "condition kind * otherwise" (condition-predicate* '(foo)))
(test-error "property tag not false" (condition-property-accessor* 'foo #f))
(test-assert "property tag * otherwise" (condition-property-accessor* 'foo 23 'skidoo))

(define testc (make-exn-condition+ 'test "test" '(test) 'misc '(extra test 23)))
(define testc? (make-condition-predicate exn misc extra))

(test-assert "composite of exn test extra" (testc? testc))
(test "extra component of (exn test extra)" 23 ((condition-property-accessor 'extra 'test) testc))

(define testc-extra-test (make-condition-property-accessor extra test))
(define testc-extra-foo (make-condition-property-accessor extra foo 'foobar))

(test 23 (testc-extra-test testc))
(test 'foobar (testc-extra-foo testc))

(define testcc)
(let ((chn (get-call-chain 1)))
  (set! testcc
    (make-exn-condition+
      'test "test" '(test)              ;std
      chn                               ;+ 1
      'misc '(extra test 23))) )        ;cnds
(test-assert "composite of exn test extra (set!)" (testc? testcc))

;C5 is a plist
(define wr-exn-res "\nError: (test) test: test\n    +: misc:\n    +: extra: test 23\n")
(test "may fail - order an issue" wr-exn-res
  (with-output-to-string (lambda () (write-exn-condition testc))))

(test-assert (exn-condition? testc))
(test 'test (exn-location testc))
(test "test" (exn-message testc))
(test '(test) (exn-arguments testc))
(test #f (exn-call-chain testc))
(test #f (exn-errno testc))

(define testc1 (make-exn-condition+ 'test "test" '(test) #f -42 'misc '(extra test 23)))
(define testc1? (make-condition-predicate exn misc extra))

(test-assert "composite of exn test extra" (testc1? testc1))
(test #f (exn-call-chain testc1))
(test -42 (exn-errno testc1))
(test "extra component of (exn test extra)" 23 ((condition-property-accessor 'extra 'test) testc1))

(define testc2 (make-exn-condition* #:errno -42 #:location 'test #:arguments '(test)))
(test "unknown" (exn-message testc2))
(test #f (exn-call-chain testc2))
(test -42 (exn-errno testc2))

(import standard-conditions)
(import http-client-conditions)
(import intarweb-conditions)

(define thttpc (make-exn-condition+ 'test "test" '(test) 'http '(extra test 23)))
(test-assert (http-condition? thttpc))

;C5 is a plist
(define irr-res '(location test message "test" arguments (test) test 23))
(test irr-res (condition-irritants thttpc))

#| ;relies on knowledge of stacktrace layout
(gloss)
(gloss "Writing exn condition")
(gloss " (expect an \"error\")")
(gloss "---------------------")
(gloss (call-with-output-string (lambda (port) (write-exn-condition testcc port))))
(test "write exn-condition"
  (cond-expand
    (compiling
      "
Error: (test) test: test
    +: misc:
    +: extra: test 23
" )
    (else
      "
Error: (test) test: test
    +: misc:
    +: extra: test 23

\tCall history:

\t<syntax>\t  (let ((chn (get-call-chain 1))) (set! testcc (make-exn-condition+ (quote test) \"test\" (quote (test))...
\t<syntax>\t  (##core#let ((chn (get-call-chain 1))) (set! testcc (make-exn-condition+ (quote test) \"test\" (quote ...
\t<syntax>\t  (##core#begin (##core#set! testcc (make-exn-condition+ (quote test) \"test\" (quote (test)) chn (quote...
\t<syntax>\t  (##core#set! testcc (make-exn-condition+ (quote test) \"test\" (quote (test)) chn (quote misc) (quote ...
\t<syntax>\t  (make-exn-condition+ (quote test) \"test\" (quote (test)) chn (quote misc) (quote (extra test 23)))
\t<syntax>\t  (quote test)
\t<syntax>\t  (##core#quote test)
\t<syntax>\t  (quote (test))
\t<syntax>\t  (##core#quote (test))
\t<syntax>\t  (quote misc)
\t<syntax>\t  (##core#quote misc)
\t<syntax>\t  (quote (extra test 23))
\t<syntax>\t  (##core#quote (extra test 23))
\t<syntax>\t  (get-call-chain 1)
\t<eval>\t  (get-call-chain 1)\t<--
" ) )
      (with-output-to-string (lambda () (write-exn-condition testcc))))
|#
(test-assert "writes exn-condition" (with-output-to-string (lambda () (write-exn-condition testcc))))
;;;

(test-end "Condition Utils")

(test-exit)