; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Last update: Feb 04, 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 two macros and two commands to be used for
;testing and debugging.

(require-library dbc expand-full)

(module simple-tests (simple-tests xpr:val run-tests pe pe*)

(import scheme
  (only chicken print eval-when expand unless)
  expand-full
  dbc
  (only extras pp printf))
(import-for-syntax (only chicken unless))

(init-dbc)

;The following macro, xpr:val, prints the literal representation of each
;of its arguments as well as their respective values, all with some
;decoration around, so that it stands out in the print. All that is done with
;printf, a Chicken expansion. 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)
       (printf "*** ~A:~%    ~S ***~%" 'xpr0 xpr0)
       (printf "*** ~A:~%    ~S ***~%" 'xpr1 xpr1)
       ...
       ))))
(push-contract!
  '(xpr:val
     (macro ()
       ((_ xpr . xprs)
        #t
        "prints each xpr and its value in interpreted code"))))

;;; (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
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let (
        (run (lambda (lst)
               (let loop ((lst lst) (n 0))
                 (if (null? lst)
                   n
                   (if (eval (car lst))
                     (begin
                       (print "passed ... " (car lst))
                       (loop (cdr lst) n))
                     (begin
                       (print "FAILED !!! " (car lst))
                       (loop (cdr lst) (+ n 1))))))))
        )
        `(begin
           (print "\nTesting ...")
           (print "-----------")
           (let ((n (,run ',(cdr form))))
             (print "-----------")
             (if (zero?  n)
               (print "All tests passed\n")
               (print n " test(s) failed!!!\n"))))))))
(push-contract!
  '(run-tests
     (macro ()
       ((_ xpr . xprs)
        #t
        "runs each test expression, xpr, and prints success or failure"))))

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

;;; (pe macro-code)
;;; ---------------
(define-with-contract pe
  (command-contract ((old new (lambda (x) #t)))
    ((_ macro-code)
     #t
     "pretty-prints expanded macro-code"))
  (lambda (macro-code) (pp (expand macro-code))))

;;; (pe* macro-code)
;;; ----------------
(define-with-contract pe*
  (command-contract ((old new (lambda (x) #t)))
    ((_ macro-code)
     #t
     "pretty-prints fully expanded macro-code"))
  pretty-print-expand*)

;;; save documentation in dispatcher
(exit-dbc-with simple-tests)

) ; module simple-tests