; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Last update: Nov 14, 2013
;
; Copyright (c) 2011-2013, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; 

#|[
This is a Chicken port of Peter Seibel's Unit Test Framework together
with a legacy macro. The low-level versions of the high-level macros
are added as comments
]|#


(module simple-tests
(export define-test check combine-results report-result
        simple-test compound-test xpr:val pe simple-tests-names)
(import scheme
        (only chicken fluid-let unless eval-when expand print print*)
        (only extras pp))

#|[
The following macro, xpr:val, pretty-prints the literal representation
of each of its arguments as well as their respective values.  The call
to eval-when guarantees, that the whole expression does nothing in
compiled code.
]|#

;;; (xpr:val xpr0 xpr1 ...)
;;; -----------------------
(define-syntax xpr:val
  (syntax-rules ()
    ((_ xpr0 xpr1 ...)
     (eval-when (eval)
       (begin (pp 'xpr0) (display "evaluates to:\n") (pp xpr0) (newline))
       (begin (pp 'xpr1) (display "evaluates to:\n") (pp xpr1) (newline))
       ...
       ))))

;;; (define-test (name . parameters) . forms)
;;; -----------------------------------------
;;; creates a test function
(define-syntax define-test
  (syntax-rules ()
    ((_ (name . parameters) form . forms)
     (define (name . parameters)
       (fluid-let ((simple-tests-names (append simple-tests-names (list 'name))))
         (print "Testing " simple-tests-names " ...")
         (print "-------")
         form . forms)))))
;(define-macro (define-test (name . parameters) . forms)
;  `(define (,name ,@parameters)
;     (fluid-let ((simple-tests-names (append simple-tests-names (list ',name))))
;       (print "Testing " simple-tests-names " ...")
;       (print "-------")
;       ,@forms)))

;;; (check . forms)
;;; ---------------
(define-syntax check
  (syntax-rules ()
    ((_ form form1 ...)
     (let ((result (combine-results (report-result form 'form)
                                    (report-result form1 'form1)
                                    ...)))
       (if result
         (print "------\n"
                simple-tests-names
                ": All tests passed\n======")
         (print "------\n"
                simple-tests-names
                ": SOME TESTS FAILED!!!\n======"))
       result))))
;(define-macro (check . forms)
;   `(let ((result
;            (combine-results ,@(map (lambda (f) `(report-result ,f ',f)) forms))))
;      (if result
;        (print "------\n" simple-tests-names ": All tests passed\n")
;        (print "------\n" simple-tests-names ": SOME TESTS FAILED!!!\n"))
;      result))

;;; (combine-results form . forms)
;;; ------------------------------
(define-syntax combine-results
  (syntax-rules ()
    ((_ form form1 ...)
     (let ((result #t))
       (unless form (set! result #f))
       (unless form1 (set! result #f))
       ...
       result))))
;(define-macro (combine-results . forms)
;  `(let ((result #t))
;     ,@(map (lambda (f) `(unless ,f (set! result #f))) forms)
;     result))


;;; (compound-test (name) simple-test-xpr ...)
;;; ------------------------------------------
(define-syntax compound-test
  (syntax-rules ()
    ((_ (name) test . tests)
     (let ((result (combine-results test . tests)))
       (print*  'name ": ")
       (if result
         (begin
           (print "All tests passed")
           (exit 0))
         (begin
           (print "SOME TESTS FAILED!!!")
           (exit 1)))))))

#|[
The following is a legacy macro, consider it deprecated. Use tests
defined by define-test instead.
]|#

;;; (simple-test (name) . forms)
;;; ----------------------------
(define-syntax simple-test
  (syntax-rules ()
    ((_ (name) form . forms)
     (fluid-let ((simple-tests-names (cons name simple-tests-names)))
       (print "Testing " simple-tests-names " ...")
       (print "-------")
       (check form . forms)))))
;(define-macro (simple-test (doc) . forms)
;  `(fluid-let ((simple-tests-names (cons ,doc simple-tests-names)))
;     (print "Testing " simple-tests-names " ...")
;     (print "-------")
;     (check ,@forms)))

;;; The following command composes pretty-print and expand

;;; (pe macro-code)
;;; ---------------
(define (pe macro-code)
  (pp (expand macro-code)))

;;; (report-result result form)
;;; ---------------------------
(define (report-result result form)
  (if result
    (print "passed ... " form)
    (print "FAILED !!! " form))
  result)

;;; simple-tests-names
;;; -----------
;;; dynamic variable
(define simple-tests-names '())

;;; (simple-tests)
;;; --------------
;;; exported symbols
(define (simple-tests)
  '(define-test check combine-results simple-test compound-test
     xpr:val report-result pe))

) ; module simple-tests