;;;
;;; <assert-base.ss> ---- Base of the assertion language
;;; Time-stamp: <2004-12-21 08:39:05 noel>
;;;
;;; Copyright (C) 2004 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.

;;; SchemeUnit is 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-base mzscheme

  (provide (all-defined))

  ;; struct assert-info : symbol any
  (define-struct assertion-info (name value) (current-inspector))

  (define (make-assertion-name name)
    (make-assertion-info 'name name))
  (define (make-assertion-params params)
    (make-assertion-info 'params params))
  (define (make-assertion-location loc)
    (make-assertion-info 'location loc))
  (define (make-assertion-expression msg)
    (make-assertion-info 'expression msg))
  (define (make-assertion-message msg)
    (make-assertion-info 'message msg))

  (define (assertion-name? info)
    (eq? (assertion-info-name info) 'name))
  (define (assertion-params? info)
    (eq? (assertion-info-name info) 'params))
  (define (assertion-location? info)
    (eq? (assertion-info-name info) 'location))
  (define (assertion-expression? info)
    (eq? (assertion-info-name info) 'expression))
  (define (assertion-message? info)
    (eq? (assertion-info-name info) 'message))
  
  ;;!
  ;; A list of assertion-info structures
  (define assertion-stack
    (make-parameter
     (list)
     (lambda (v)
       (if (list? v)
           v
           (raise-type-error 'assertion-stack "list" v)))))

  ;; with-assertion-info* : (list-of assertion-info) thunk -> any
  (define (with-assertion-info* info thunk)
    (parameterize
      ((assertion-stack (append info (assertion-stack))))
      (thunk)))

  (define-syntax with-assertion-info
    (syntax-rules ()
      ((_ ((name val) ...) body ...)
       (with-assertion-info*
        (list (make-assertion-info name val) ...)
        (lambda ()
          body ...)))))
  
  
  
  ;;!
  ;; (struct (exn:test exn) ())
  ;;
  ;; The exception throw by test failures
  (define-struct (exn:test exn) ())
  
  
  ;;!
  ;; (struct (exn:test:assertion struct:exn:test) (name location params))
  ;;  String String (list-of Any)
  ;;
  ;; The exception thrown to indicate an assertion has failed
  (define-struct (exn:test:assertion exn:test) (stack))

  ;; Exception thrown to indicate an internal failure in an
  ;; exception, distinguished from a failure in user code.
  (define-struct (exn:test:assertion:internal exn:test:assertion)
    ())

  (define-syntax fail-assertion
    (syntax-rules ()
     ((_)
      (raise
       (make-exn:test:assertion
        "Assertion failure"
        (current-continuation-marks)
        (assertion-stack))))))

  (define-syntax fail-internal
    (syntax-rules ()
      ((_)
       (raise
        (make-exn:test:assertion:internal
         "Internal failure"
         (current-continuation-marks)
         (assertion-stack))))))

  ;; refail-assertion : exn:test:assertion -> (exception raised)
  ;;
  ;; Raises an exn:test:assertion with the contents of the
  ;; given parameter.  Useful for propogating internal
  ;; errors to the outside world.
  (define (refail-assertion exn)
    (raise
     (make-exn:test:assertion "Assertion failure"
                              (exn-continuation-marks exn)
                              (exn:test:assertion-stack exn))))
)

;;; assert-base.ss ends here