;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

;; (%trace-on)
;; (%trace-off)

;;; Some of these bugs app to tests/driver, and some to tests/language,
;;; I think.
;;;
;;; BUGS
;;;
;;; 1. need element-type and generator therein (fabs <str> 0 1)
;;; 2. fab <range> 2 causes nyi which should be a real condition
;;; 3. warnings shouldn't result in failure
;;; 4. need way to debug object system and retest with undef?
;;; 5. need split to debug <map>'s

(use goo)

(dv *tests* '())

(dm add-test (name)
  (set *tests* (del-dups (cat *tests* (lst name)))))

(dm del-test (name)
  (set *tests* (del-vals *tests* name)))

(dg run-tests (group-name|<sym>))

(ds test-group (,name ,@tests)
  (mif ((,name disabled) name)
    `(del-test ',name)
    `(seq (add-test ',name) 
        (dm run-tests (group-name|(t= ',name)) ,@tests ))))

(export
  add-test
  del-test
  run-tests
  test-group)

(dv *test-trace?* #t)
(dv *test-doc*    #f)

(export *test-trace?*)

(dm do-test (group-name doc input-thunk)
  (dlet ((*test-doc* doc))
    (when *test-trace?* (msg out "  %s\n" doc))
    (input-thunk)))

(dc <test-warning> (<simple-condition>))

(dm recurring-write
    (port|<out-port> x|<test-warning> d|<int> recur|<fun>)
  (write port (condition-message x)))

(dm recurring-write
    (port|<out-port> x|<simple-condition> d|<int> recur|<fun>)
  (app msg (cat (lst port (condition-message x)) (condition-arguments x))))

(dm do-test-fn (group-name doc compare input-thunk output-thunk)
  (dlet ((*test-doc* doc))
    (when *test-trace?* (msg out "  %s\n" doc))
    (def input  (input-thunk))
    (def output (output-thunk))
    (unless (compare input output)
      (sig (new <test-warning> 
             condition-message
               (cat (as <str> group-name) ": " doc " was %=, not %=")
             condition-arguments
               (list input output))))))

(dm do-test-eq (group-name doc input-thunk out-thunk)
  (do-test-fn group-name doc == input-thunk out-thunk))

(dm do-test-eqv (group-name doc input-thunk out-thunk)
  (do-test-fn group-name doc = input-thunk out-thunk))

(dm do-test-neq (group-name doc input-thunk out-thunk)
  (do-test-fn group-name doc ~== input-thunk out-thunk))

(dm do-test-neqv (group-name doc input-thunk out-thunk)
  (do-test-fn group-name doc ~= input-thunk out-thunk))

(export
  do-test
  <test-warning>
  do-test-fn
  do-test-eq
  do-test-eqv
  do-test-neq
  do-test-neqv)

(ds test (,input)
  `(do-test group-name 
            ,(to-str input)
            (fun () ,input)))

(ds test= (,input ,output)
  `(do-test-eqv group-name
                ,(to-str input)
                (fun () ,input) (fun () ,output)))

(ds test== (,input ,output)
  `(do-test-eq group-name
               ,(to-str input)
               (fun () ,input) (fun () ,output)))

(ds test~= (,input ,output)
  `(do-test-neqv group-name
                ,(to-str input)
                (fun () ,input) (fun () ,output)))

(ds test~== (,input ,output)
  `(do-test-neq group-name
               ,(to-str input)
               (fun () ,input) (fun () ,output)))

(export
  test
  test=
  test==
  test~=
  test~==)

;; (def `(out ,@objects)
;;   `(do puts (lst ,@(map (fun (x) `(to-str ,x)) objects))))

(dv *catch-test-errors* #t)

(dm run-tests-in (tst => (tup errors|<lst> warnings|<lst>))
  (def errors   '())
  (def warnings '())
  (if *catch-test-errors*
      (esc break
        (try <condition>
          (fun (condition resume)
            (post "Failure: %s\n" (describe-condition condition))
            (if (isa? condition <test-warning>)
                (seq (pushf warnings (lst condition *test-doc*))
                     (resume #f))
                (seq (pushf errors (lst condition *test-doc*))
                     (break #f))))
          (tst)))
      (tst))
  (tup errors warnings))

(dv *all-warnings* #f)
(dv *all-errors*   #f)

(dm run-all-tests (=> <Int>)
  (newline out)
  (def all-warnings '()) (def all-errors '())
  (do (fun (tst)
        (when tst
          (post "Testing %=\n" tst)
          (def (tup errors warnings) (run-tests-in (fun () (run-tests tst))))
          (set all-warnings (cat! all-warnings warnings))
          (set all-errors   (cat! all-errors   errors))))
      *tests*)
  (post "WARNING AND ERROR SUMMARY\n")
  (set *all-warnings* all-warnings)
  (set *all-errors*   all-errors)
  (do (fun (c) (post "Warning: %=. Continuing...\n"
                     (describe-condition (head c))))
      (rev all-warnings))
  (do (fun (c) (post "Error: %=.\n" (describe-condition (head c))))
      (rev all-errors))
  (post "Tautology completed with %= warnings and %= errors\n"
        (len all-warnings) (len all-errors))
  (+ (len all-warnings) (len all-errors)))

(export run-all-tests)
