#lang scheme
(require (planet cce/scheme:4:1/planet))
(require (only-in srfi/13 string-contains)
         (this-package-in private/command-line))
 
(provide test-inspector test-inexact-epsilon
         test test/pred test/regexp test/exn
         plai-error exn:plai?)

(define thunk (-> any))

(define test-inspector (make-parameter (current-inspector)))
(define test-inexact-epsilon (make-parameter 0.01))

; We only catch exceptions of this type.  plai-error throws such exceptions.
(define-struct (exn:plai exn:fail) () #:transparent)

(define (plai-error . args)
  (with-handlers
      [(exn:fail? (λ (exn) 
                    (raise
                     (make-exn:plai (exn-message exn)
                                    (exn-continuation-marks exn)))))]
    (apply error args)))

(define-struct (exn:test exn:fail) ())

(define (install-test-inspector)
  (test-inspector (current-inspector))
  (current-inspector (make-inspector))
  (print-struct #t))

(define (maybe-command-line arg)
  (and (member arg (vector->list (current-command-line-arguments))) true))

(define halt-on-errors? (maybe-command-line "--plai-halt-on-errors"))
(define print-only-errors? (maybe-command-line "--plai-print-only-errors"))

(provide/contract (halt-on-errors (() (boolean?) . ->* . void?)))
(define (halt-on-errors [halt? true])
  (set! halt-on-errors? halt?))

(provide/contract (print-only-errors (() (boolean?) . ->* . void?)))
(define (print-only-errors [print? true])
  (set! print-only-errors? print?))

; list of all test results
(provide plai-all-test-results)
(define plai-all-test-results empty)

; set to true if
(provide plai-ignore-exn-strings)
(define plai-ignore-exn-strings (make-parameter false))

(define (may-print-result result)
  (parameterize ([current-inspector (test-inspector)]
                 [print-struct #f])
    (set! plai-all-test-results (cons result plai-all-test-results))
    (when (or (not print-only-errors?) (eq? (first result) 'bad) (eq? (first result) 'exception))
      (write result)(newline))
    (when (and halt-on-errors? (or (eq? (first result) 'bad) (eq? (first result) 'exception)))
      (raise (make-exn:test (string->immutable-string (format "test failed: ~s" result))
                            (current-continuation-marks))))))


;;; If the expression raises an exception, it is returned as a value, only if
;;; the exception subclasses struct:exn.
(define-syntax (return-exception stx)
  (syntax-case stx ()
    [(_ expr)
     #'(with-handlers
           ([exn? (λ (exn) exn)])
         expr)]))

(define (equal~? x y)
  (if (and (number? x) (number? y)
           (or (inexact? x) (inexact? y)))
      ; If one of them is inexact, we do the math.
      (< (abs (- x y)) (test-inexact-epsilon))
      (parameterize ([current-inspector (test-inspector)])
        (equal? x y))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Syntax forms for the test procedures make it unnecessary to enclose the
;;; expression in a thunk.  More importantly, they automatically specify the
;;; line number of the test as the comment.

(provide generic-test)
(define (generic-test test-thunk pred test-sexp expected-sexp loc)
  (unless (disable-tests)
    (may-print-result
     (with-handlers
         ; Applying the predicate shouldn't raise an exception.
         ([exn? (λ (exn) 
                  `(exception 
                    ,(if (abridged-test-output) 
                         "exception evaluating RHS of test"
                          test-sexp)
                    ,(exn-message exn) 
                    ,@(if (abridged-test-output) empty (list loc))))])
       (let ([test-result (return-exception (test-thunk))])
         (if (or (exn:plai? test-result) (not (exn? test-result)))
             (let* ([test-value (pred test-result)])
               (if (abridged-test-output)
                   `(,(if test-value 'good 'bad)
                     ,test-result ,expected-sexp)
               `(,(cond
                    [(exn:plai? test-value) 'exception]
                    [test-value 'good]
                    [else 'bad]) 
                 ,test-sexp
                 ,expected-sexp
                 ,loc)))
             (if (abridged-test-output)
                 `(exception ,(exn-message test-result))
                 `(exception ,test-sexp ,(exn-message test-result) ,loc))))))))

(define-syntax (test stx)
  (syntax-case stx ()
    [(_ result-expr expected-expr)
     #`(generic-test (λ () result-expr) 
                     (λ (result-value)
                       (cond
                         [(exn:plai? result-value) result-value]
                         [(equal~? result-value expected-expr) true]
                         [else false]))
                    (quote #,(syntax->datum #'result-expr))
                    (quote #,(syntax->datum #'expected-expr))
                    (format "at line ~a" #,(syntax-line stx)))]))

(define-syntax (test/pred stx)
  (syntax-case stx ()
    [(_ test-expr pred)
     #`(generic-test (λ () test-expr)
                     (λ (val)
                       (cond
                         [(exn:plai? val) val]
                         [else (pred val)]))
                     (quote #,(syntax->datum #'test-expr))
                     (quote #,(syntax->datum #'pred))
                     (format "at line ~a" #,(syntax-line stx)))]))

(define-syntax (test/exn stx)
  (syntax-case stx ()
    [(_ test-expr exception-substring)
     #`(generic-test
        (λ () test-expr)
        (λ (val)
          (and (exn:plai? val)
               (or (plai-ignore-exn-strings)
                   (string-contains (exn-message val) exception-substring))))
        (quote #,(syntax->datum #'test-expr))
        (quote #,(syntax->datum #'exception-substring))
        (format "at line ~a" #,(syntax-line stx)))]))

(define-syntax (test/regexp stx)
  (syntax-case stx ()
    [(_ test-expr regexp)
     #`(generic-test
        (λ () test-expr)
        (λ (val)
          (and (exn:plai? val)
               (or (plai-ignore-exn-strings)
                   (regexp-match regexp (exn-message val)))))
        (quote #,(syntax->datum #'test-expr))
        (quote #,(syntax->datum #'exception-substring))
        (format "at line ~a" #,(syntax-line stx)))]))


(install-test-inspector)