plt/check.ss
;;;
;;; Time-stamp: <2007-04-04 11:22:51 noel>
;;;
;;; Copyright (C) by Noel Welsh.
;;;

;;; This library 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.

;;; This library 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 this library; 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:

;;!
;; Checks perform the core action of a test fixture: checking
;; actual output equals expected output.
(module check mzscheme

  (require (lib "include.ss")
           (lib "etc.ss")
           (lib "list.ss" "srfi" "1")
           "base.ss"
           "check-info.ss"
           "location.ss")

  (require-for-syntax "location.ss")

  (provide fail-check

           define-check
           define-binary-check
           define-simple-check

           check
           check*
           check-exn
           check-exn*
           check-not-exn
           check-not-exn*
           check-true
           check-true*
           check-false
           check-false*
           check-pred
           check-pred*
           check-eq?
           check-eq?*
           check-eqv?
           check-eqv?*
           check-equal?
           check-equal?*
           check-=
           check-=*
           check-not-false
           check-not-false*
           fail
           fail*)

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

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

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

  (define-syntax (define-check stx)
    (syntax-case stx ()
      ((define-check (name formal ...) expr ...)
       (with-syntax (((reported-name function-name)
                      (let ((reported-name
                             (symbol->string
                              (syntax-object->datum (syntax name)))))
                        (list
                         reported-name
                         (datum->syntax-object
                          (syntax name)
                          (string->symbol
                           (string-append reported-name "*"))))))
                     ((actual ...)
                      (datum->syntax-object
                       stx
                       (map gensym
                            (syntax-object->datum (syntax (formal ...)))))))
         (syntax/loc stx
           (begin
             ;; The distinction between formal and actual parameters
             ;; is made to avoid evaluating the check arguments
             ;; more than once.  This technique is based on advice
             ;; received from Ryan Culpepper.

             (define function-name
               (opt-lambda (formal ... [message ""])
                 (with-check-info*
                  (cons*
                   (make-check-name reported-name)
                   (make-check-params (list formal ...))
                   (if (> (string-length message) 0)
                       (list (make-check-message message))
                       (list)))
                  (lambda () expr ...))))

             (define-syntax (name stx)
               (with-syntax
                   ([location (syntax->location stx)])
                 (syntax-case stx ()
                   ((name actual ...)
                    (syntax/loc stx
                      (let ((args (list actual ...)))
                        (with-check-info*
                         (list (make-check-name reported-name)
                               (make-check-location (quote location))
                               (make-check-expression
                                (quote (name actual  ...)))
                               (make-check-params args))
                         (lambda ()
                           (apply (lambda (formal ...) expr ...) args))))))

                   ((name actual ... message)
                    (syntax/loc stx
                      (let ((args (list actual ...)))
                        (with-check-info*
                         (list (make-check-name reported-name)
                               (make-check-location (quote location))
                               (make-check-expression
                                (quote (name actual ...)))
                               (make-check-params args)
                               (make-check-message message))
                         (lambda ()
                           (apply (lambda (formal ...) expr ...) args))))))
                   (name
                    (identifier? #'name)
                    (syntax/loc stx
                      (opt-lambda (formal ... [message ""])
                        (with-check-info*
                         (list
                          (make-check-location (quote location)))
                         (lambda ()
                           (function-name formal ... message))))))
                     )))
             ))))))

  (define-syntax define-simple-check
    (syntax-rules ()
      ((_ (name param ...) expr ...)
       (define-check (name param ...)
         (let ((result (begin expr ...)))
           (if result
               result
               (fail-check)))))))

  (define-syntax define-binary-check
    (syntax-rules ()
      ((_ (name expr1 expr2) expr ...)
       (define-check (name expr1 expr2)
         (with-check-info*
          (list (make-check-actual expr1)
                (make-check-expected expr2))
          (lambda ()
            (let ((result (begin expr ...)))
              (if result
                  result
                  (fail-check)))))))
      ((_ (name pred expr1 expr2))
       (define-check (name expr1 expr2)
         (with-check-info*
          (list (make-check-actual expr1)
                (make-check-expected expr2))
          (lambda ()
            (if (pred expr1 expr2)
                #t
                (fail-check))))))))

  (define-check (check-exn pred thunk)
    (let/ec succeed
      (with-handlers
          (;; catch the exception we are looking for and
           ;; succeed
           [pred
            (lambda (exn) (succeed #t))]
           ;; rethrow check failures if we aren't looking
           ;; for them
           [exn:test:check?
            (lambda (exn)
              (refail-check exn))]
           ;; catch any other exception and raise an check
           ;; failure
           [exn:fail?
            (lambda (exn)
              (with-check-info*
               (list
                (make-check-message "Wrong exception raised")
                (make-check-info 'exception-message (exn-message exn))
                (make-check-info 'exception exn))
               (lambda () (fail-check))))])
        (thunk))
      (with-check-info*
       (list (make-check-message "No exception raised"))
       (lambda () (fail-check)))))

  (define-check (check-not-exn thunk)
    (with-handlers
        ([exn:test:check?
          (lambda (exn) (refail-check exn))]
         [exn?
          (lambda (exn)
            (with-check-info*
             (list
              (make-check-message "Exception raised")
              (make-check-info 'exception-message (exn-message exn))
              (make-check-info 'exception exn))
             (lambda () (fail-check))))])
      (thunk)))

  (include "../generic/check.ss")

  )