#lang s-exp "../base.rkt"

(require (for-syntax racket/base))

(provide check-expect 
         ;check-within
         ;check-error
         run-tests)

(define *tests* '())


(define-for-syntax (syntax-location-values stx)
  (list (syntax-source stx) ;; can be path or symbol
        (syntax-position stx)
        (syntax-line stx)
        (syntax-column stx)
        (syntax-span stx)))


(define-for-syntax (check-at-toplevel! who stx)
  (unless (eq? (syntax-local-context) 'module)
    (raise-syntax-error #f 
                        (format "~a: found a test that is not at the top level."
                                who)
                        stx)))


(define-syntax (check-expect stx)
  (syntax-case stx ()
    [(_ test expected)
     (begin
       (check-at-toplevel! 'check-expect stx)
       (with-syntax ([stx stx]
                     [(id offset line column span)
                      (syntax-location-values stx)])
         #'(accumulate-test!
            (lambda ()
              (check-expect* 'stx
                             (srcloc 'id line column offset span)
                             (lambda () test)
                             (lambda () expected))))))]))
    
;; (define-syntax (check-within stx)
;;   (syntax-case stx ()
;;     [(_ test expected delta)
;;      (begin
;;        (check-at-toplevel! 'check-within stx)
;;        (with-syntax ([stx stx]
;;                      [(id offset line column span)
;;                       (syntax-location-values stx)])
;;          #'(accumulate-test!
;;             (lambda ()
;;               (check-within* 'stx
;;                              (make-location 'id offset line column span)
;;                              (lambda () test)
;;                              (lambda () expected)
;;                              (lambda () delta))))))]))

;; (define-syntax (check-error stx)
;;   (syntax-case stx ()
;;     [(_ test expected-msg)
;;      (begin
;;        (check-at-toplevel! 'check-error stx)
;;        (with-syntax ([stx stx]
;;                      [(id offset line column span)
;;                       (syntax-location-values stx)])
;;          #'(accumulate-test!
;;             (lambda ()
;;               (check-error* 'stx
;;                             (make-location 'id offset line column span)
;;                             (lambda () test)
;;                             (lambda () expected-msg))))))]))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (check-expect* test-datum a-loc test-thunk expected-thunk)
;  (with-handlers ([void
;                   (lambda (exn)
;                     (printf "check-expect: ~s"
;                             (exn-message exn))
;                     (newline)
;                     (display-location test-datum a-loc)
;                     #f)])
    (let ([expected-value (expected-thunk)]
          [test-value (test-thunk)])
      (cond
        [(equal? test-value expected-value)
         #t]
        [else
         (printf "check-expect: actual value ~s differs from ~s, the expected value\n" test-value expected-value)
         (display-location a-loc)
         #f])))


(define (display-location a-loc)
  (printf "  at: ~s, line ~s, column ~s\n"
          (srcloc-source a-loc)
          (srcloc-line a-loc)
          (srcloc-column a-loc)))
  

;; (define (check-within* test-datum a-loc test-thunk expected-thunk delta-thunk)
;;   ;(with-handlers ([void
;;   ;                   (lambda (exn)
;;   ;                     (printf "check-within: ~s"
;;   ;                             (exn-message exn))
;;   ;                     (newline)
;;   ;                     (display-location test-datum a-loc)
;;   ;                     #f)])
;;       (let ([expected-value (expected-thunk)]
;;             [test-value (test-thunk)]
;;             [delta-value (delta-thunk)])
;;         (cond
;;           [(not (real? delta-value))
;;            (printf "check-within requires an inexact number for the range.  ~s is not inexact.\n" delta-value)
;;            ;;(display-location test-datum a-loc)
;;            #f]
;;           [(equal~? test-value expected-value delta-value)
;;            #t]
;;           [else
;;            (printf "check-within: actual value ~s differs from ~s, the expected value.\n" test-value expected-value)
;;            ;;(display-location test-datum a-loc)
;;            #f])))



;; (define (check-error* test-datum a-loc test-thunk expected-message-thunk)
;;   (with-handlers ([void
;;                    (lambda (exn)
;;                      (printf "check-error: ~s"
;;                              (exn-message exn))
;;                      (newline)
;;                      (display-location test-datum a-loc)
;;                      #f)])
;;     (let ([expected-message (expected-message-thunk)])
;;       (with-handlers
;;           ([unexpected-no-error?
;;             (lambda (une)
;;               (printf "check-error expected the error ~s, but got ~s instead.\n"
;;                       expected-message
;;                       (unexpected-no-error-result une))
;;               (display-location test-datum a-loc)
;;               #f)]
;;            [exn:fail?
;;             (lambda (exn)
;;               (cond [(string=? (exn-message exn) expected-message)
;;                      #t]
;;                     [else
;;                      (printf "check-error: expected the error ~s, but got ~s instead.\n"
;;                              expected-message
;;                              (exn-message exn))
;;                      (display-location test-datum a-loc)
;;                      #f]))])
;;         (let ([result (test-thunk)])
;;           (raise (make-unexpected-no-error result)))))))
  






;; a test is a thunk of type: (-> boolean)
;; where it returns true if the test was successful,
;; false otherwise.

;; accumulate-test!
(define (accumulate-test! a-test)
  (set! *tests* (cons a-test *tests*)))

    
;; test-suffixed: number -> string
(define (test-suffixed n)
  (case n 
    [(0) "zero tests"]
    [(1) "one test"]
    [else (format "~a tests" n)]))
  

;; capitalize: string -> string
(define (capitalize s)
  (cond [(> (string-length s) 0)
         (string-append (string (char-upcase (string-ref s 0)))
                        (substring s 1))]
        [else
         s]))


;; run-tests: -> void
(define (run-tests)
  (when (> (length *tests*) 0)
    ;; Run through the tests
    (printf "Running tests...\n")
    (let loop ([tests-passed 0]
               [tests-failed 0]
               [tests (reverse *tests*)])
      (cond
        [(empty? tests)
         ;; Report test results
         (cond [(= tests-passed (length *tests*))
                (display (case (length *tests*)
                           [(1) "The test passed!"]
                           [(2) "Both tests passed!"]
                           [else
                            (format "All ~a tests passed!"
                                    (length *tests*))]))
                (newline)]
               [else
                (printf "Ran ~a.\n" 
                        (test-suffixed (length *tests*)))
                (printf "~a passed.\n" 
                        (capitalize (test-suffixed tests-passed)))
                (printf "~a failed.\n" 
                        (capitalize (test-suffixed tests-failed)))])
         (set! *tests* '())]
        [else
         (let* ([test-thunk (first tests)]
                [test-result (test-thunk)])
           (cond
             [test-result
              (loop (add1 tests-passed)
                    tests-failed
                    (rest tests))]
             [else
              (loop tests-passed
                    (add1 tests-failed)
                    (rest tests))]))]))))
  


(define-struct unexpected-no-error (result))