; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Last update: Aug 18, 2018 (port to chicken-5)
;
; Copyright (c) 2011-2018, 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 (
   simple-tests 
   define-test
   (compound-test group-on-cdrs)
   xpr:val
   ppp
   and?
   pe
   *locations*
   *failures*
   )

(import scheme (chicken base) (chicken syntax) (chicken pretty-print))

;;; (simple-tests [sym])
;;; ---------------------
;;; documentation procedure
(define simple-tests
  (let (
    (signatures '((define-test (name . parameters) form . forms)
                  (check form . forms)
                  (compound-test (name) test . tests)
                  (xpr:val xpr . xprs)
                  (ppp 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 (print "=== " 'xpr " ===")
               (pp xpr)
               (newline))
        ...
        )
       (else)))))

;;; (ppp xpr ...)
;;; -------------
;;; pretty-print with headline
(define-syntax ppp
  (syntax-rules ()
    ((_ xpr ...)
     (xpr:val xpr ...))))

;;; (and? . xprs)
;;; -------------
;;; non-short-circuited and which executes all side-effects
(define (and? . xprs)
  (let ((result #t))
    (for-each (lambda (x) (if (not x) (set! result #f)))
              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)))
         (display "... passed in")
         (for-each (disp) loc)
         (newline)
         #t)
       (begin
         (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) form . forms)
     (define (name . parameters)
       (fluid-let (
         (*locations*
           (cons (show-args (name . parameters)) *locations*))
         )
         ((check form . forms) *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))))))))

;;; (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

;(import simple-tests (chicken pretty-print))
;(pp (expand '(define-test (foo x) (= 5 3) (null? '()))))