#lang scheme/base

(require scheme/match scheme/list scheme/string
         (for-syntax scheme/base scheme/match))

(define-syntax (safe stx)
  (syntax-case stx ()
    [(_ expr)
     (with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e)))])
       (let-values ([(_ x) (syntax-local-expand-expression
                            #'(with-handlers ([exn? (lambda (e)
                                                      (list 'error
                                                            (exn-message e)))])
                                (cons 'values
                                      (call-with-values (lambda () expr)
                                          list))))])
         x))]))

(define (show value)
  (match value
    [(list 'error msg) (format "error: ~a" msg)]
    [(list 'values x)  (format "~e" x)]
    [(list 'values xs ...) (format "~e" value)]))

(define test-context
  (make-parameter
   (lambda (num exns)
     (if (null? exns)
       (printf "~a tests passed\n" num)
       (error 'test "~a/~a test failures:~a" (length exns) num
              (string-append*
               (append-map (lambda (e) (list "\n" (exn-message e)))
                           (reverse exns))))))))

(define-for-syntax (loc stx)
  (string->symbol
   (format "~a:~a" (syntax-source stx)
           (let ([l (syntax-line stx)] [c (syntax-column stx)])
             (cond [(and l c) (format "~a:~a" l c)]
                   [l l]
                   [(syntax-position stx) => (lambda (p) (format "#~a" p))]
                   [else "?"])))))

(provide test)
(define-syntax (test stx)
  (define (blame e fmt . args)
    (with-syntax ([e e] [fmt fmt] [(arg ...) args] [loc (loc e)])
      #'(error 'loc "test failure in ~e\n  ~a" 'e (format fmt arg ...))))
  (define (t1 x)
    #`(let ([x (safe #,x)])
        (unless (and (eq? 'values (car x)) (= 2 (length x)) (cadr x))
          #,(blame x "expected non-#f single value; got: ~a" #'(show x)))))
  (define (t2 x y)
    #`(let ([x (safe #,x)] [y (safe #,y)])
        (cond [(and (eq? 'error (car y)) (eq? 'values (car x)))
               #,(blame x "expected an error; got ~a" #'(show x))]
              [(and (eq? 'error (car x)) (eq? 'error (car y)))
               (unless (regexp-match (regexp-quote (cadr y)) (cadr x))
                 #,(blame x "bad error message, expected ~s; got ~s"
                          #'(cadr y) #'(cadr x)))]
              [(not (equal? x y))
               #,(blame x "expected ~a; got: ~a" #'(show y) #'(show x))])))
  (define (te x y) (t2 x #`(error #,y)))
  (define (try t . args)
    #`(with-handlers ([exn? (lambda (e) (set! exns (cons e exns)))])
        (set! num (add1 num))
        #,(apply t args)))
  (define (tb x)
    #`(parameterize ([test-context (lambda (n es)
                                     (set! num (+ n num))
                                     (set! exns (append es exns)))])
        #,x))
  (let loop ([xs (map (lambda (x)
                        (if (memq (syntax-e x) '(do => <= =error> <error=))
                          (syntax-e x) x))
                      (cdr (syntax->list stx)))]
             [r '()])
    (let ([t (match xs
               [(list* 'do x r)        (cons (tb x) r)]
               [(list* x '=> y r)      (cons (try t2 x y) r)]
               [(list* y '<= x r)      (cons (try t2 x y) r)]
               [(list* x '=error> y r) (cons (try te x y) r)]
               [(list* y '<error= x r) (cons (try te x y) r)]
               [(list* x r)            (cons (try t1 x) r)]
               [(list) '()])])
      (if (pair? t)
        (loop (cdr t) (cons (car t) r))
        #`(let ([num 0] [exns '()])
            #,@(reverse r)
            ((test-context) num exns))))))

#; ;; test the `test' macro

(test
 ;; test usage
 1 => 1
 #t
 (< 1 2)
 (+ 1 2) => 3
 (+ 1 2) <= 3
 ;; multiple values
 (values 1) => 1
 (values 1) <= 1
 (quotient/remainder 10 3) => (values 3 1)
 ;; runtime errors
 (car '()) =error> "expects argument of type"
 (car '()) => (error "expects argument of type")
 ;; syntax errors
 (if 1) =error> "if: bad syntax"

 ;; test `test' errors
 (test (/ 0)) =error> "expected non-#f single value"
 (test 1 => 2) =error> "expected 2"
 (test 1 =error> "") =error> "expected an error"
 (test (/ 0) =error> "zzz") =error> "bad error message"
 )

;; SchemeUnit stuff
;; (examples that should fail modified to ones that shouldn't)
#|

;; Quick Start example
(define (file-tests)
  ;; Tests for file.scm
  ;; (=> source location is sufficient, no need for test names in the code)
  (test
   (+ 1 1) => 2
   (* 1 2) => 2
   ;; List has length 4 and all elements even
   do (let ([lst (list 2 4 6 8)])
        (test (length lst) => 4
              do (for ([x lst]) (test (even? x)))))))
(file-tests)

;; API listing
(test
 ;; (check < 2 3)
 (< 2 3)
 ;; (check-eq? 1 1 "allocated data not eq?")
 (eq? 1 1)
 ;; (check-not-eq? (list 1) (list 1) "integers are eq?")
 (not (eq? (list 1) (list 1)))
 ;; (check-eqv? 1.0 1.0 "not eqv?")
 (eqv? 1.0 1.0)
 ;; (check-equal? 1.0 1.0 "not equal?")
 (equal? 1.0 1.0)
 1.0 => 1.0 ; alternative
 ;; (check-not-equal? 1 1.0 "equal?")
 (not (equal? 1 1.0))
 ;; (check-pred string? "I work")
 (string? "I work")
 ;; (check-= 1.0 1.001 0.01 "I work")
 (< (abs (- 1.0 1.001)) 0.01)
 ;; (check-true (< 1 2))
 (eq? #t (< 1 2))
 ;; (check-false (< 2 1))
 (not (< 2 1))
 ;; (check-not-false (< 1 2))
 (< 1 2)
 ;; (check-exn exn?
 ;;            (lambda ()
 ;;              (raise (make-exn "Hi there"
 ;;                               (current-continuation-marks)))))
 (raise (make-exn "Hi there" (current-continuation-marks)))
 =error> ""
 ;; (check-not-exn (lambda () 1))
 (void 1)
 ;; (fail)
 ;; (error "foo") -> no real equivalent, since `fail' doesn't throw an error
 ;; (check-regexp-match "a+bba" "aaaaaabba")
 (regexp-match "a+bba" "aaaaaabba")
 )
|#