; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Last update: Nov 05, 2017
;
; Copyright (c) 2011-2017, 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 simple Unit Test Framework inspired by Peter Seibel's
"Practical Common Lisp" together with some routines which might be
useful for debugging
]|#


(module simple-tests
(export simple-tests 
        define-test check simple-test
        (compound-test group-on-cdrs)
        xpr:val and?  pe
        *locations* *failures*)
(import scheme
        (only chicken case-lambda fluid-let
              unless receive expand print)
        (only extras pp))

;;; (simple-tests [sym])
;;; ---------------------
;;; documentation procedure
(define simple-tests
  (let (
    (signatures '((define-test (name . parameters) form . forms)
                  (check form . forms)
                  (simple-test (name) form . forms)
                  (compound-test (name) test . tests)
                  (xpr:val xpr . xprs)
                  (and? . xprs)
                  (pe macro-code)))
    )
    (case-lambda
      (() (map car signatures))
      ((sym) (assq sym signatures)))))

#|[
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 xpr ...)
;;; -----------------------
(define-syntax xpr:val
  (syntax-rules ()
    ((_ xpr ...)
     (cond-expand
       ((not compiling)
        (begin (pp 'xpr)
               (display "evaluates to:\n")
               (pp xpr)
               (newline))
        ...
        )
       (else)))))

;;; (and? . xprs)
;;; -------------
;;; non-short-circuited and which executes all side-effects
(define-syntax and?
  (syntax-rules ()
    ((_ . xprs)
     (let ((result #t))
       (for-each (lambda (x) (if (not x) (set! result #f)))
                 (list . xprs))
       result))))

;; helper macro because I don't want to export it
(define-syntax disp
  (syntax-rules ()
    ((_)
     (lambda (x) (display " ") (display x)))))

;;; (report-result loc form)
;;; ------------------------
;;; reports succuss or failure of form and updates failures if necessary
(define-syntax report-result
  (syntax-rules ()
    ((_ loc form)
     (if form
       (begin
         (cond-expand
           (compiling (print 'form))
           (else (pp 'form)))
         ;(pp 'form)
         ;(print 'form)
         (display "... passed in")
         (for-each (disp) loc)
         (newline)
         #t)
       (begin
         ;(pp 'form)
         ;(print 'form)
         (cond-expand
           (compiling (print 'form))
           (else (pp 'form)))
         (display "!!! FAILED IN")
         (for-each (disp) loc)
         (newline)
         (set! *failures* (cons (cons 'form loc) *failures*))
         #f)))))

;;; (check . forms)
;;; --------------------
;;; report result of all forms
(define-syntax check
  (syntax-rules ()
    ((_ form ...)
     (lambda (loc)
       (and? (report-result loc form)
             ...)))))

;; internal helper
(define-syntax show-args
 (syntax-rules ()
   ((_ (name arg ...))
    `(name (arg ,arg) ...))
   ((_ arg) arg)))

;;; (define-test (name . parameters) form . forms)
;;; ----------------------------------------------
;;; creates a test function
(define-syntax define-test
  (syntax-rules ()
    ((_ (name . parameters) check-form)
     (define (name . parameters)
       (fluid-let (
         (*locations*
           (cons (show-args (name . parameters)) *locations*))
         )
         (check-form *locations*))))))

;;; (compound-test (name) test . tests)
;;; -----------------------------------
;;; invokes all tests and reports a summary
(define-syntax compound-test
  (syntax-rules ()
    ((_ (name) test0 test1 ...)
     (begin
       (print "\nTesting " 'name " ...")
       (print "----------------------------")
       (let ((result (and? test0 test1 ...)))
         (print "\nResults of " 'name)
         (print "----------------------------")
         (if result
           (begin
             (print "All tests passed")
             (exit 0))
           (let ((groups (group-on-cdrs (reverse *failures*))))
             (print "SOME TESTS FAILED IN ...")
             (for-each (lambda (x)
                         (display "...")
                         (for-each (disp) (cdar x))
                         (newline)
                         (cond-expand
                           (compiling
                             (for-each print (map car x)))
                           (else
                             (for-each pp (map car x))))
                         ;(for-each print (map car x))
                         ;(for-each pp (map car x))
                         )
                       groups)
             (exit 1))))))))

#|[
The following is a legacy macro, consider it deprecated.
Use compound-test instead
]|#

;;; (simple-test (name) form . forms)
;;; ---------------------------------
;;; tests all the form arguments
(define-syntax simple-test
  (syntax-rules ()
    ((_ (name) form . forms)
     (fluid-let ((*locations* (cons 'name *locations*)))
       (print "Testing " *locations* " ...")
       (print "----------------------------")
       (if ((check form . forms) *locations*)
         (begin
           (print "\nAll tests passed")
           (exit 0))
         (begin
           (print "\nSOME TESTS FAILED!!!")
           (exit 1)))))))

;;; (pe macro-code)
;;; ---------------
;;; composes pretty-print and expand
(define (pe macro-code)
  (pp (expand macro-code)))

;;; internal helper from bindings
(define (filter ok? lst)
  (let loop ((lst lst) (yes '()) (no '()))
    (if (null? lst)
      (values (reverse yes) (reverse no))
      (let ((first (car lst)) (rest (cdr lst)))
        (if (ok? first)
          (loop rest (cons first yes) no)
          (loop rest yes (cons first no)))))))

;;; (group-on-cdrs alist)
;;; ---------------------
;;; group into sublists with equal cdrs.
(define (group-on-cdrs alst)
  (let loop ((alst alst) (result '()))
    (if (null? alst)
      (reverse result)
      (receive (yes no)
        (filter (lambda (x) (equal? (cdr x) (cdar alst))) alst)
        (loop no (cons yes result))))))

;;; *locations*
;;; -----------
;;; dynamic variable
(define *locations* '())

;;; *failures*
;;; ----------
;;; global variable collecting failure information
(define *failures* '())

) ; module simple-tests