plt/check-test.ss
;;;
;;; Time-stamp: <2007-03-10 15:01:09 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:

(module check-test mzscheme

  (require (lib "list.ss" "srfi" "1")
           "test.ss")
  (require (planet "require.ss" ("ryanc" "require.plt" 1 3)))

  (provide check-tests)

  (define-module check "check.ss")
  
  (define (make-failure-test name pred . args)
    (test-case
     name
     (check-exn exn:test:check?
                 (lambda ()
                   (apply pred args)))))

  (define-check (good)
    #t)

  (define-check (bad)
    (fail-check))

  (define check-tests
    (test-suite
     "Check tests"
     ;; Successes
     (test-case "Simple check-equal? test"
                (check-equal? 1 1))
     (test-case "Simple check-eq? test"
                (check-eq? 'a 'a))
     (test-case "Simple check-eqv? test"
                (check-eqv? 'a 'a))
     (test-case "Simple check test"
                (check string=? "hello" "hello"))
     (test-case "Simple check-true test"
                (check-true (eq? 'a 'a)))
     (test-case "Simple check-pred test"
                (check-pred null? (list)))
     (test-case "Simple check-exn test"
                (check-exn exn:test:check?
                            (lambda ()
                              (check = 1 2))))
     (test-case "Simple check-not-exn test"
                (check-not-exn
                 (lambda ()
                   (check = 1 1))))
     (test-case "Defined check succeeds"
                (good))
     (test-case "Simple check-not-false test"
                (check-not-false 3))
     (test-case "Simple check-= test"
                (check-= 1.0 1.0 0.0001))

     (test-case "Use of check as expression"
                (for-each check-false '(#f #f #f)))
     (test-case "Use of local check as expression"
                (let ()
                  (define-simple-check (check-symbol? x)
                    (symbol? x))
                  (for-each check-symbol? '(a b c))))

     ;; Failures
     (make-failure-test "check-equal? failure"
                        check-equal?* 1 2)
     (make-failure-test "check-eq? failure"
                        check-eq?* 'a 'b)
     (make-failure-test "check-eqv? failure"
                        check-eqv?* 'a 'b)
     (make-failure-test "check failure"
                        check* string=? "hello" "bye")
     (make-failure-test "check-true failure"
                        check-true* (eq? 'a 'b))
     (make-failure-test "check-pred failure"
                        check-pred* null? (list 1 2 3))
     (make-failure-test "check-exn failure"
                        check-exn* exn:test:check? (lambda () (check = 1 1)))
     (make-failure-test "check-exn wrong exception"
                        check-exn* exn:fail:contract:arity? (lambda () (+ 1 2)))
     (make-failure-test "check-not-exn"
                        check-not-exn* (lambda () (/ 1 0)))
     (make-failure-test "fail with message failure"
                        fail* "With message")
     (make-failure-test "fail without message failure"
                        fail*)
     (make-failure-test "Defined check fails"
                        bad*)
     (make-failure-test "check-not-false failure"
                        check-not-false* #f)
     (make-failure-test "check-= failure"
                        check-=* 1.0 2.0 0.0)

     (test-case "check-= allows differences within epsilon"
                (check-= 1.0 1.09 1.1))

     (make-failure-test "check-= failure at epsilon"
                        check-=* 1 11/10 1/10)
     (make-failure-test "check-= failure > epsilon"
                        check-=* 1 12/10 1/10)
     
     (test-case "check-as-expression failure"
                (check-exn exn:test:check?
                            (lambda ()
                              (for-each check-false '(#f not-false)))))

     (test-case
      "Check allows optional message"
      (begin
        (check* = 1 1 "message")
        (check = 1 1 "message")))

     ;; Some necessary semantics
     (test-case
      "Check macro parameters evaluated once (simple-check)"
      (let ((counter 0))
        (check-true (begin (set! counter (add1 counter))
                            #t))
        (check = counter 1)))
     (test-case
      "Check macro parameters evaluated once (binary-check)"
      (let ((counter 0))
        (check-equal? (begin (set! counter (add1 counter))
                              1)
                       (begin (set! counter (add1 counter))
                              1))
        (check = counter 2)))
     (test-case
      "Check function parameters evaluated once (simple-check)"
      (let ((counter 0))
        (check-true* (begin (set! counter (add1 counter))
                             #t))
        (check = counter 1)))
     (test-case
      "Check function parameters evaluated once (binary-check)"
      (let ((counter 0))
        (check-equal?* (begin (set! counter (add1 counter))
                               1)
                        (begin (set! counter (add1 counter))
                               1))
        (check = counter 2)))

     ;; Exceptions have the correct types
     (test-case
      "Macro w/ no message, message is a string"
      (let ((exn (with-handlers ([exn? (lambda (exn)
                                         exn)])
                   (check-true #f))))
        (check-pred string? (exn-message exn))))
     (test-case
      "Function w/ no message, message is a string"
      (let ((exn (with-handlers ([exn? (lambda (exn)
                                         exn)])
                   (check-true* #f))))
        (check-pred string? (exn-message exn))))

     ;; The check construction language
     (test-case
      "with-check-info* captures information"
      (let ((name (make-check-info 'name "name"))
            (info (make-check-info 'info "info")))
        (with-handlers
            [(exn:test:check?
              (lambda (exn)
                (let ((stack (exn:test:check-stack exn)))
                  (check = (length stack) 2)
                  (let ((actual-name (first stack))
                        (actual-info (second stack)))
                    (check-equal? name actual-name)
                    (check-equal? info actual-info)))))]
          (with-check-info*
           (list name info)
           (lambda ()
             (fail-check))))))
     (test-case
      "with-check-info captures information"
      (with-handlers
          [(exn:test:check?
            (lambda (exn)
              (let ((stack (exn:test:check-stack exn)))
                (check = (length stack) 2)
                (let ((name (first stack))
                      (info (second stack)))
                  (check-eq? (check-info-name name) 'name)
                  (check string=? (check-info-value name) "name")
                  (check-eq? (check-info-name info) 'info)
                  (check string=? (check-info-value info) "info")))))]
        (with-check-info
         (('name "name") ('info "info"))
         (fail-check))))
     (test-case
      "check information stack unwinds"
      (with-handlers
          [(exn:test:check?
            (lambda (exn)
              (let ((stack (exn:test:check-stack exn)))
                (check = (length stack) 2)
                (let ((name (first stack))
                      (info (second stack)))
                  (check-eq? (check-info-name name) 'name)
                  (check string=? (check-info-value name) "name")
                  (check-eq? (check-info-name info) 'info)
                  (check string=? (check-info-value info) "info")))))]
        (with-check-info
         (('name "name") ('info "info"))
         (with-check-info
          (('name "name") ('info "info"))
          #t)
         (fail-check))))

     ;; If check-exn isn't working correctly many tests above will
     ;; silently fail.  Here we test check-exn is working.
     (test-case
      "check-exn traps exception"
      (with-handlers
          ((exn?
            (lambda (exn) (fail "Received exception"))))
        (check-exn exn:fail:contract:arity?
                    (lambda () (= 1)))))
     (test-case
      "check-exn fails if no exception raised"
      (with-handlers
          ((exn:test:check?
            (lambda (exn) #t))
           (exn:fail:contract:arity?
            (lambda (exn) (fail "check-exn didn't fail"))))
        (check-exn exn? (lambda () (= 1 1)))
        (= 1)))

     (test-case
      "check-not-exn captures exception information if one raised"
      (let* ([case (test-case "check-not-exn"
                              (check-not-exn
                               (lambda () (error "Oh dear!"))))]
             [result (test-failure-result (car (run-test case)))]
             [names (map check-info-name
                         (exn:test:check-stack result))])
        (check-true
         (fold (lambda (name found?)
                 (if (eq? name 'exception)
                     #t
                     found?))
               #f names))
        (check-true
         (fold (lambda (name found?)
                 (if (eq? name 'exception-message)
                     #t
                     found?))
               #f names))))

     ;; Regression test
     ;; Uses of check (and derived forms) used to be un-compilable!
     ;; We check that (write (compile --code-using-check--)) works.
     ;; That involves some namespace hacking.
     (test-case
      "Checks are compilable"
      (let ((destns (make-namespace))
            (cns (current-namespace)))
        (parameterize ((current-namespace destns))
          (namespace-require-check)
          ;; First check that the right check macro got
          ;; used: ie that it didn't just compile the thing
          ;; as an application.
          (let ((ecode
                 (syntax-object->datum (expand '(check = 1 2)))))
            (check-false (and (pair? ecode)
                               (eq? (car ecode) '#%app)
                               (pair? (cdr ecode))
                               (equal? (cadr ecode)
                                       '(#%top . check)))))
          ;; Then check to make sure that the compiled code
          ;; is writable
          (let ((stx-string "(check = 1 2)"))
            (write (compile (read-syntax
                             (string->path "file")
                             (open-input-string stx-string)))
                   (open-output-string))))))
     ))
  )