; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Last update: Jun 26, 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.
; 

;In this module we implement four macros and two commands to be used for
;testing and debugging.

(require-library expand-full)

(module simple-tests
  (export simple-tests
          xpr:val
          (compound-test simple-tests-run)
          (run-tests simple-tests-run)
          (simple-test simple-tests-run)
          pe
          pe*)
  (import scheme
    (only chicken eval-when expand)
    expand-full
    (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))
       ...
       ))))

;;; (run-tests xpr0 xpr1 ...)
;;; -------------------------
;;; evaluates each expression xpr0 xpr1 ... and reports it as failed, if
;;; it evaluates to #f, and as passed otherwise
(define-syntax run-tests
  (syntax-rules ()
    ((_  xpr ...)
     (begin
         (display "\nTesting ...\n")
         (display "-----------\n")
         (let ((n (simple-tests-run (list 'xpr ...))))
           (display "-----------\n")
           (if (zero?  n)
             (display "All tests passed\n\n")
             (begin
               (display n)
               (display " test(s) failed!!!\n\n"))))))))

;;; (simple-test (name) xpr ...)
;;; ----------------------------
(define-syntax simple-test
  (syntax-rules ()
    ((_ (what) xpr ...)
     (let ((name what))
       (display "\nTesting ")
       (display name)
       (display " ....\n")
       (display "-------\n")
       (let ((n (simple-tests-run (list 'xpr ...))))
         (display "------\n")
         (display name)
         (display ": ")
         (cond
           ((zero? n)
            (display "All tests passed\n\n"))
           (else
             (display n)
             (display " test(s) failed!!\n\n")))
         (cons n name))))))

;;; (compound-test (name) simple-test-xpr ...)
;;; ------------------------------------------
(define-syntax compound-test
  (syntax-rules ()
    ((_ (what) simple-test-xpr ...)
     (let ((name what))
       (let loop ((pairs (list simple-test-xpr ...))
                  (n 0)
                  (errors-in '()))
         (cond
           ((null? pairs)
            (display "------\n")
            (display "Compound test ")
            (display name)
            (display ": ")
            (cond
              ((zero? n)
               (display "All tests passed\n\n"))
              (else
                (display "\nTotal number of failed tests ")
                (display n)
                (display "\nFailed tests in ")
                (display (reverse errors-in))
                (display "\n\n"))))
           (else
             (loop (cdr pairs)
                   (+ n (caar pairs))
                   (if (zero? (caar pairs))
                     errors-in
                     (cons (cdar pairs) errors-in))))))))))

;;; The following commands compose pretty-print and expand or expand*

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

;;; (pe* macro-code)
;;; ----------------
(define pe* pretty-print-expand*)

;; only conditionally exported
(define (simple-tests-run lst)
  (let loop ((lst lst) (n 0))
    (if (null? lst)
      n
      (if (eval (car lst))
        (begin
          (display "passed ... ")
          (write (car lst))
          (newline)
          (loop (cdr lst) n))
        (begin
          (display "FAILED !!! ")
          (write (car lst))
          (newline)
          (loop (cdr lst) (+ n 1)))))))

(define (simple-tests)
  '(run-tests simple-test compound-test xpr:val pe pe*))

) ; module simple-tests