assert.ss
;;!
;; Assertions perform the core action of a test fixture: checking
;; actual output equals expected output.
(module assert
  mzscheme
  
  (require (lib "etc.ss")
           (lib "list.ss" "srfi" "1"))
  
  (require "assert-base.ss"
           "assert-util.ss")

  (require-for-syntax "assert-util.ss")
  
  (provide (struct exn:test:assertion (stack))
           (struct assertion-info (name value))
            
           with-assertion-info
           with-assertion-info*

           fail-assertion

           define-assertion
           define-simple-assertion
           
           assert
           assert*
           assert-exn
           assert-exn*
           assert-not-exn
           assert-not-exn*
           assert-true
           assert-true*
           assert-false
           assert-false*
           assert-pred
           assert-pred*
           assert-eq?
           assert-eq?*
           assert-eqv?
           assert-eqv?*
           assert-equal?
           assert-equal?*
           assert-not-false
           assert-not-false*
           fail
           fail*)

  (define-syntax define-assertion
    (lambda (stx)
      (syntax-case stx ()
        ((define-assertion (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 assertion arguments
              ;; more than once.  This technique is based on advice
              ;; received from Ryan Culpepper.
              
              (define function-name
                (opt-lambda (formal ... [message ""])
                  (with-assertion-info*
                   (cons*
                    (make-assertion-name reported-name)
                    (make-assertion-params (list formal ...))
                    (if (> (string-length message) 0)
                        (list (make-assertion-message message))
                        (list)))
                   (lambda () expr ...))))
                      
              (define-syntax name
                (lambda (stx)
                  (with-syntax 
                      ([location (syntax->location-values stx)])
                    (syntax-case stx ()
                      ((name actual ...)
                       (syntax/loc 
                         stx
                         (let ((args (list actual ...)))
                           (with-assertion-info*
                            (list (make-assertion-name reported-name)
                                  (make-assertion-location 'location)
                                  (make-assertion-expression
                                   (quote (name actual  ...)))
                                  (make-assertion-params args))
                           (lambda () 
                             (apply (lambda (formal ...) expr ...) args))))))
                      
                      ((name actual ... message)
                       (syntax/loc 
                         stx
                         (let ((args (list actual ...)))
                           (with-assertion-info*
                            (list (make-assertion-name reported-name)
                                  (make-assertion-location 'location)
                                  (make-assertion-expression
                                   (quote (name actual ...)))
                                  (make-assertion-params args)
                                  (make-assertion-message message))
                           (lambda () 
                             (apply (lambda (formal ...) expr ...) args))))))
                      (name
                       (identifier? #'name)
                       (syntax/loc stx
                         (opt-lambda (formal ... [message ""])
                           (with-assertion-info*
                            (list
                             (make-assertion-location 'location))
                            (lambda ()
                              (function-name formal ... message))))))
                      ))))
              )))))))


  (define-syntax define-simple-assertion
    (syntax-rules ()
      ((_ (name param ...) expr ...)
       (define-assertion (name param ...)
         (let ((result (begin expr ...)))
           (if result
               result
               (fail-assertion)))))))
  
  ;;!
  ;; (function (assert operator expected actual))
  ;;
  ;; (param operator (-> (Any Any) (union #t #f)) "The operator
  ;; to use to compare the results of the two expressions")
  ;;
  ;; (param actual Any "The actual value")
  ;;
  ;; (param expected Any "The expected value")
  (define-simple-assertion (assert operator expr1 expr2)
    (operator expr1 expr2))
  
  (define-simple-assertion (assert-pred predicate expr)
    (predicate expr))
  
  (define-simple-assertion (assert-eq? expr1 expr2)
    (eq? expr1 expr2))
  
  
  (define-simple-assertion (assert-eqv? expr1 expr2)
    (eqv? expr1 expr2))
  
  
  (define-simple-assertion (assert-equal? expr1 expr2)
    (equal? expr1 expr2))
  
  (define-simple-assertion (assert-true expr)
    (eq? expr #t))
  
  (define-simple-assertion (assert-false expr)
    (eq? expr #f))

  (define-simple-assertion (fail)
    #f)


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

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