; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 2011-2020, 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.
A second test interface is added with version 2.0
]|#


(module simple-tests (
  ; common
  simple-tests 
  and?
  writeln
  pe
  ppp
  ppp*
  ppp**
  xpr:val
  xpr:val*
  ==
  ; old interface
  define-test
  (compound-test group-on-cdrs)
  *locations*
  *failures*
  ; new interface
  check
  define-checks
  do-checks
  (check-all check-all-proc)
  )

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

(import-for-syntax (only (chicken base) chop))

;;;;;; Common interface ;;;;;;

;;; (simple-tests [sym])
;;; ---------------------
;;; documentation procedure
(define simple-tests
  (let (
    (signatures '((simple-tests
                    procedure:
                    (simple-tests sym ..)
                    "documentation procedure")
                  (and?
                    procedure:
                    (and? xpr ...)
                    "Pascal like and procedure")
                  (writeln
                    procedure:
                    (writeln xpr ....)
                    "write analog of print")
                  (pe
                    procedure:
                    (pe macro-code)
                    " composes pretty-print and expand")
                  (ppp
                    macro:
                    (ppp xpr ...)
                    " print each xpr quoted in a headline"
                    "and pretty-print xpr's computed value")
                  (ppp*
                    macro:
                    (ppp* xpr ypr . xpr-yprs)
                    "print each xpr quoted in a headline"
                    "and pretty-print xpr's computed and"
                    "expected value, ypr")
                  (ppp**
                    macro:
                    (ppp** ((var val) ...) xpr ypr . xpr-yprs)
                    "wraps ppp* into a let")
                  (xpr:val
                    macro:
                    (xpr:val xpr ...)
                    "alias to ppp")
                  (xpr:val*
                    macro:
                    (xpr:val* xpr ypr . xpr-yprs)
                    "alias to ppp*")
                  (==
                    procedure:
                    (==)
                    (== x)
                    (== type? type-equal?)
                    "generic type equality as curried procedure:"
                    "the first resets the local database,"
                    "the second is the curried equality check"
                    "and the third adds a new equality procedure"
                    "to the local database")

                  (define-test
                    macro:
                    (define-test (name . parameters) form . forms)
                    "creates a test function")
                  (compound-test
                    macro:
                    (compound-test (name) test . tests)
                    "checks all tests created with define-test"
                    "and reports a summary of results")

                  (check
                    macro:
                    (check ((var val) ...) xpr ypr . xpr-yprs)
                    "compares xpr and ypr .... with == in the"
                    "environment defined by (var val) ...")
                  (define-checks
                    macro:
                    (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
                    "returns a unary predicate, name?,"
                    "comparing xpr with ypr ...."
                    "and using var val ... within this checks."
                    "verbose? controls the reported results")
                  (do-checks
                    macro:
                    (do-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
                    "alias to define-checks")
                  (check-all
                    macro:
                    (check-all name check-xpr ....)
                    "checks all check-expressions created by do-check"
                    "and reports the results")))
    )
    (case-lambda
      (() (map car signatures))
      ((sym)
       (let ((pair (assq sym signatures)))
         (if pair
           (for-each print (cdr pair))
           (print "Choose one of " (map car signatures))))))))

(define (writeln . args)
  (for-each (lambda (a)
              (write a)
              (display " "))
            args)
  (newline))

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

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

#|[
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 ...)
;;; -----------------
;;; print each xpr quoted in a headline and pretty-print xpr's computed
;;; value.
(define-syntax xpr:val
  (syntax-rules ()
    ((_ xpr ...)
     (cond-expand
       ((not compiling)
        (begin (print "Computing " 'xpr " ...")
               (pp xpr)
               )
        ...
        )
       (else)))))

;;; (ppp xpr ...)
;;; -------------
;;; print each xpr quoted in a headline and pretty-print xpr's computed
;;; value. Alias to xpr:val.
(define-syntax ppp
  (syntax-rules ()
    ((_ xpr ...)
     (xpr:val xpr ...))))

(define-syntax help-ppp* ; internal
  (syntax-rules ()
    ((_)
     (print))
    ((_ xpr ypr)
     (begin (print "Testing " 'xpr " ...")
            (print* "computed: ") (pp xpr)
            (print* "expected: ") (pp ypr)
            ))
    ((_ xpr ypr . pairs)
     (begin (help-ppp* xpr ypr)
            (help-ppp* . pairs)))
    ))
;
;;;; (ppp* {xpr ypr} ...)
;;; --------------------
;;; print each xpr quoted in a headline and pretty-print xpr's computed
;;; and expected value, ypr.
(define-syntax ppp*
  (syntax-rules ()
    ((_ . pairs)
     (cond-expand
       ((not compiling)
        (help-ppp* . pairs))
       (else)))))

;;; (xpr:val* {xpr ypr} ...)
;;; ------------------------
;;; print each xpr quoted in a headline and pretty-print xpr's computed
;;; and expected value, ypr.
;;; Alias to ppp*
(define-syntax xpr:val*
  (syntax-rules ()
    ((_ . pairs)
     (ppp* . pairs))))

;;; (ppp** ((var val) ...) xpr ypr . other xpr-ypr-pairs)
;;; -----------------------------------------------------
;;; ppp* wrapped into a let
(define-syntax ppp**
  (syntax-rules ()
    ((_ ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
     (let ((var val) ...)
       (ppp* xpr ypr . other-xpr-ypr-pairs)))))

;;;;;;;; old interface ;;;;;;;;;

;; 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-em . forms) ;; internal
;;; ------------------
;;; report result of all forms
(define-syntax check-em
  (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-em 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))))))))

;;; 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* '())

;;;;;;; new interface ;;;;;;;;;;;

(define (curry proc) ; internal
  (lambda (x) (lambda (y) (proc x y))))

;(define (symbol=? x y)
;  (string=? (symbol->string x) (symbol->string y)))

;;; (==)
;;; (== x)
;;; (== type? type-equal?)
;;; ----------------------
;;; generic type equality as curried procedure
(define ==
  (let* ((pairs (list (cons pair? (curry equal?))
                  (cons null? (curry eq?))
                  (cons symbol? (curry eq?))
                  (cons vector? (curry equal?))
                  (cons string? (curry string=?))
                  (cons boolean? (curry eq?))
                  (cons char? (curry char=?))
                  (cons number? (curry =))
                  (cons procedure? (curry eqv?))
                  (cons (lambda (x) #t) (curry equal?))))
         (db pairs))
    (case-lambda
      (()
       (set! db pairs); reset
       (pp db))
      ((x) ; return generic curried equality operator
       (let loop ((db db))
         (if ((caar db) x)
           ;; check if second arg has rigth type as well
           ;; without check ((cdar db) x) would work
           ;; but produce an error for wrong type of second arg
           (lambda (y) (and ((caar db) y) (((cdar db) x) y)))
           ;; try next pair
           (loop (cdr db)))))
      ((type? type=?) ; add new eqaulity operator to db
       (set! db (cons (cons type? (curry type=?)) db))
       (pp db))
      )))

;;; (check* ((var val) ...) xpr ypr . xpr-yprs) ;; internal
;;; --------------------------------------------------------------
;(define-syntax check*
;  (er-macro-transformer
;    (lambda (form rename compare?)
;      (let ((var-vals (cadr form))
;            (xpr-yprs (cddr form))
;            (%verbose? (rename 'verbose?))
;            (%lambda (rename 'lambda))
;            (%x (rename 'x))
;            (%tests (rename 'tests))
;            (%writeln (rename 'writeln))
;            (%set! (rename 'set!))
;            (%print (rename 'print))
;            (%print* (rename 'print*))
;            (%begin (rename 'begin))
;            (%let (rename 'let))
;            (%== (rename '==))
;            (%cons (rename 'cons))
;            (%reverse (rename 'reverse))
;            (%if (rename 'if))
;            (%null? (rename 'null?))
;            (%fails (rename 'fails))
;            (%map (rename 'map))
;            (%cdr (rename 'cdr))
;            (%when (rename 'when))
;            (select-failures
;              (lambda (pairs)
;                (let loop ((pairs pairs))
;                  (cond
;                    ((null? pairs) '())
;                    ((caar pairs) (loop (cdr pairs)))
;                    (else
;                     (cons (car pairs) (loop (cdr pairs))))))))
;            )
;`(,%lambda (,%verbose?)
;   (,%let ,var-vals
;          (,%let ((,%tests '()))
;            ,@(map (lambda (p)
;                     `(,%begin
;                        (,%let ((,%x ,(car p)))
;                           ; protect against functions changing state
;                          (,%when ,%verbose?
;                            (,%print "testing " ',(car p) " ...")
;                            (,%print* "computed: ") (,%writeln ,%x)
;                            (,%print* "expected: ") (,%writeln ,(cadr p))
;                            )
;                          (,%set! ,%tests
;                                  (,%cons (,%cons ((,%== ,%x) ,(cadr p)) ',(car p))
;                                          ,%tests)))
;                          ))
;                   (chop xpr-yprs 2))
;            (,%let ((,%fails (,select-failures (,%reverse ,%tests))))
;              (,%when ,%verbose?
;                (,%print "List of failed test expressions: "
;                         (,%map ,%cdr ,%fails))
;                         )
;              (,%if (,%null? ,%fails) #t #f)))))
; ))))
(define-syntax check*
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((var-vals (cadr form))
            (xpr-yprs (cddr form))
            (select-failures
              (lambda (pairs)
                (let loop ((pairs pairs))
                  (cond
                    ((null? pairs) '())
                    ((caar pairs) (loop (cdr pairs)))
                    (else
                     (cons (car pairs) (loop (cdr pairs))))))))
            )
`(lambda (verbose?)
   (let ,var-vals
          (let ((tests '()))
            ,@(map (lambda (p)
                     `(begin
                        (let ((x ,(car p)))
                           ; protect against functions changing state
                          (when verbose?
                            (print "testing " ',(car p) " ...")
                            (print* "computed: ") (writeln x)
                            (print* "expected: ") (writeln ,(cadr p))
                            )
                          (set! tests
                                  (cons (cons ((== x) ,(cadr p)) ',(car p))
                                          tests)))
                          ))
                   (chop xpr-yprs 2))
            (let ((fails (,select-failures (reverse tests))))
              (when verbose?
                (print "List of failed test expressions: "
                         (map cdr fails))
                         )
              (if (null? fails) #t #f)))))
 ))))
;;; (check ((var val) ...) xpr ypr . xpr-yprs)
;;; ------------------------------------------
;;; compare xpr and ypr .... in sequence with ==
;;; in the environment defined by var val ...
(define-syntax check
  (syntax-rules ()
    ((_ ((var val) ...) xpr ypr . xpr-yprs)
     ((check* ((var val) ...) xpr ypr . xpr-yprs) #t))))

;;; (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
;;; --------------------------------------------------------------
;;; returns a unary predicate, name?, comparing xpr with ypr ....
;;; and using var val ... within this checks,
;;; verbose? controls the reported summary.
(define-syntax define-checks
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((header (cadr form))
            (xpr-yprs (cddr form)))
        (let ((name (car header))
              (verbose? (cadr header))
              (var-vals (cddr header)))
    `(define ,name
       (case-lambda
         (()
          (,name #t))
         ((,verbose?)
          (when ,verbose?
            (print "\nIn " ',name ":")
            (print* "---"
                    (make-string (string-length
                                   (symbol->string ',name)) #\-)
                    "-\n")
            )
            ((check* ,(chop var-vals 2)
               ,@xpr-yprs) ,verbose?)))))))))

;;; (do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
;;; ---------------------------------------------------------------
;;; returns a unary predicate, name?, comparing xpr with ypr ....
;;; and using var val ... within this checks,
;;; alias to define-checks
(define-syntax do-checks
  (syntax-rules ()
    ((_(name? verbose? . var-val-pairs) xpr ypr . xpr-ypr-pairs)
     (define-checks (name? verbose? . var-val-pairs)
       xpr ypr .  xpr-ypr-pairs))))

(define (check-all-proc name . test-name-pairs) ; internal to check-all
  ; used internally in check-all, must be exported within check-all
  (let loop ((pairs (chop test-name-pairs 2)) (failures '()))
    (cond
      ((null? pairs)
       (print "\nIn " name ":")
       (print "==="
              (make-string (string-length (symbol->string name)) #\=)
              "=")
       (print* "List of failed tests: "
              (map car (reverse failures)))
       (if (null? failures)
         (begin (newline) (exit 0))
         (begin (newline) (exit 1))))
      ((caar pairs)
       (loop (cdr pairs) failures))
      (else
        (loop (cdr pairs) (cons (cadar pairs) failures))))))

;;; (check-all Name check-xpr ....)
;;; -------------------------------
;;; checks all check-expressions defined with define-checks
;;; producing a list of failures and exiting with 0 or 1
(define-syntax check-all
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((name (cadr form))
            (checks (cddr form))
            (%check-all-proc (rename 'check-all-proc))
            )
        `(,%check-all-proc ',name
                          ,@(apply append
                                   (map (lambda (t) `(,t ',t))
                                        checks)))))))
 ) ; simple-tests

;(import simple-tests)
;
;(pe '(check ((lst '(0 1 2)))
;        (car lst)
;        0
;        (cdr lst)
;        '(1 2)))
;
;(check ((lst '(0 1 2)))
;        (car lst)
;        0
;        (cdr lst)
;        '(0 1 2))
;
;(pe '(define-checks (foo verbose? lst '(0 1 2))
;        (car lst)
;        0
;        (cdr lst)
;        '(1 2)))
;(define-checks (foo verbose? lst '(0 1 2))
;        (car lst)
;        0
;        (cdr lst)
;        '(1 2 3))
;(foo #t)
;(ppp (foo #f))