plt/check.ss
;;;
;;; Time-stamp: <06/03/11 12:09:59 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-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
    (lambda (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
            (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
                (lambda (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
          (('actual expr1)
           ('expected expr2))
          (let ((result (begin expr ...)))
            (if result
                result
                (fail-check))))))
      ((_ (name pred expr1 expr2))
       (define-check (name expr1 expr2)
         (with-check-info
          (('actual expr1)
           ('expected expr2))
            (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))
             (fail-check)))])
      (thunk)))

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

  )