assert-util-test.ss
;;;
;;; <assert-util-test.ss> ---- Tests for assert-util
;;; Time-stamp: <2004-10-08 07:39:30 noel>
;;;
;;; Copyright (C) 2003 by Noel Welsh.
;;;
;;; This file is part of SchemeUnit.

;;; SchemeUnit is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.

;;; SchemeUnitis distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.

;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SchemeUnit; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA

;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:

(module assert-util-test mzscheme

  (require "test.ss"
           "assert-util.ss"
           "assert-base.ss")

  (provide assert-util-tests)

  (define assert-util-tests
    (make-test-suite
     "All assert-util tests"
     (make-test-case 
      "syntax->location-values ok"
      (assert equal?
              '("assert-util-test.ss" 42 38 1240 2 #f)
              (syntax->location-values
               (datum->syntax-object #f '() (list "assert-util-test.ss" 42 38 1240 2) #f))))
     (make-test-case
      "Emacs compatible location strings"
      (begin
        (assert string=?
                (location->string (list "file.ss" 42 38 1240 2 #f))
                "file.ss:42:38")
        (assert string=?
                (location->string (list #f 42 38 1240 2 #f))
                "unknown:42:38")
        (assert string=?
                (location->string (list 'foo.ss 42 38 1240 2 #f))
                "foo.ss:42:38")))

     (make-test-case
      "Stack inspection functions are correct"
      (with-handlers
       ((exn:test:assertion?
         (lambda (exn)
           (let ((stack (exn:test:assertion-stack exn)))
             (assert-eq? (get-assertion-location stack)
                         'location)
             (assert-eq? (get-assertion-name stack)
                         'name)
             (assert-eq? (get-assertion-params stack)
                         'params)
             (assert-eq? (get-assertion-expression stack)
                         'expression)
             (assert-eq? (get-assertion-message stack)
                         'message)
             (assert-eq? (get-assertion-info 'foo stack) 'bar)
             (assert-eq? (get-assertion-info 'not-there stack)
                         #f)))))
       (with-assertion-info*
        (list
         (make-assertion-name 'name)
         (make-assertion-params 'params)
         (make-assertion-location 'location)
         (make-assertion-expression 'expression)
         (make-assertion-message 'message)
         (make-assertion-info 'foo 'bar))
        (lambda ()
          (fail-assertion)))))
     (make-test-case
      "Stack inspection functions find latest values"
      (with-handlers
       ((exn:test:assertion?
         (lambda (exn)
           (let ((stack (exn:test:assertion-stack exn)))
             (assert-eq? (get-assertion-location stack)
                         'location)))))
       (with-assertion-info*
        (list (make-assertion-location 'foo))
        (lambda ()
          (with-assertion-info*
           (list (make-assertion-location 'location))
           (lambda ()
             (fail-assertion)))))))
     (make-test-case
      "Stack inspection functions handle empty stack"
      (begin
        (assert-eq? (get-assertion-location null)
                    #f)
        (assert-eq? (get-assertion-name null)
                    #f)
        (assert-eq? (get-assertion-params null)
                    #f)
        (assert-eq? (get-assertion-expression null)
                    #f)
        (assert-eq? (get-assertion-message null)
                    #f)
        (assert-eq? (get-assertion-info 'foo null) #f)
        (assert-eq? (get-assertion-info 'not-there null)
                    #f)))
     ))

  )

;;; assert-util-test.ss ends here