; Copyright (c) 2013-2021 , Juergen Lorenz, ju (at) jugilo (dot) de
; 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.  It underwent several changes in the maintenance
process, most of them are now marked deprecated but are still there in
favor of backwards compatibility.

For the future, it's sufficient to use only the following six routines,
the parameter verbose? and the macros pe, ppp, check, make-tester and
test-all.

pe, ppp and check are mostly used in the development phase, make-tester
and test-all are the actual test routines to go into tests/run.scm.

A tester is a nullary predicate which produces a lot of information as
side-effects provided the parameter verbose? is true. These testers are
invoked in test-all.

pe is a combination of pretty-print and expand enhanced with additional
text; ppp pretty-prints a list of expressions and its values, while
check does the same but accompanies these computed values with expected
ones, allowing for local variables in the checks.
]|#

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

(import scheme
        (only (chicken base)
              print case-lambda cut chop exit receive make-parameter)
        (only (chicken syntax) expand)
        (only (chicken module) import-for-syntax)
        (only (chicken pretty-print) pp)
        )

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

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

#|[
(verbose? ..)
--- parameter ---
gets or sets the value of the parameter verbose?
]|#
(define verbose?
  (make-parameter #t
                  (lambda (x)
                    (if (not x)
                      x
                      #t))))

#|[
(writeln xpr ...)
--- procedure ---
write analog of print, expressions separated by whitespace
]|#
(define (writeln . args)
  (for-each (lambda (a)
              (write a)
              (display " "))
            args)
  (newline))

#|[
(and? . xprs)
--- procedure ---
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)
--- macro ---
composes pretty-print and expand,
does nothing in compiled code.
]|#
(define (pe macro-code)
  (cond-expand
    ((not compiling)
     (newline)
     (print "Macro expansion:")
     (print "----------------")
     (pp macro-code)
     (print "->")
     (pp (expand macro-code))
     (print "----------------")
     (newline))
    (else)))

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

(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} ...)
--- macro ---
Deprecated!
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} ...)
--- macro ---
Deprecated!
Print each xpr quoted in a headline and pretty-print xpr's computed
and expected value, ypr.
Alias to ppp*
]|#
(define-syntax xpr:val* ; deprecated
  (syntax-rules ()
    ((_ . pairs)
     (ppp* . pairs))))

#|[
(ppp** ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
--- macro ---
Deprecated!
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 ;;;;;;;;;

(define-syntax disp ; internal
  (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 ; internal
  (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)
;;; ------------------
;;; report result of all forms
(define-syntax check-em ; internal
  (syntax-rules ()
    ((_ form ...)
     (lambda (loc)
       (and? (report-result loc form)
             ...)))))

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

#|[
(define-test (name . parameters) form . forms)
--- macro *locations* *failures* ---
Deprecated!
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)
--- macro group-on-cdrs *failures* ---
Deprecated!
Invokes all tests and reports a summary
]|#
(define-syntax compound-test
  (syntax-rules ()
    ((_ (name) test0 test1 ...)
     (begin
  (writeln "XXX" 'test0 test0 test1 ...) ;;;;;
  (writeln "YYY" (and? test0 test1 ...)) ;;;;;
       (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
(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))))))

;;;*failures*
;;; ----------
;;; Deprecated!
;;; global variable
(define *failures* '())

;;; *locations*
;;; -----------
;;; Deprecated!
;;; global variable
(define *locations* '())

;;;;;;; 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?)
--- procedure ---
Deprecated!
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* ; internal
  (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?)
   (letrec ,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 ((cut equal? <> x) ,(cadr p))
                                            ',(car p))
                                      tests)))
                                ;(cons (cons ((== x) ,(cadr p)) ',(car p))
                                ;            tests)))
                          ))
                   (chop xpr-yprs 2))
            (let ((fails (,select-failures (reverse tests))))
              (when verbose?
                (print "Failed test expressions:")
                (print "------------------------")
                (if (null? fails)
                  (print "none")
                  (for-each print (map cdr fails))))
              (if (null? fails) #t #f)))))
 ))))
;(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)))))
; ))))
#|[
(check ((var val) ...) xpr ypr . xpr-yprs)
--- macro ---
Compare xpr and ypr .... in sequence with equal?
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)
--- macro ---
Deprecated!
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") ;"-\n")
            )
            ((check* ,(chop var-vals 2)
               ,@xpr-yprs) ,verbose?)))))))))

#|[
(do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
--- macro ---
Deprecated!
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-tester (name? . var-vals) xpr ypr . xpr-yprs)
--- macro ---
Returns a thunk predicate, name?, comparing xpr with ypr ....
and using var val ... within this tests.
The parameter verbose? controls the reported summary, i. e.
the side effects.
]|#
(define-syntax define-tester
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((header (cadr form))
            (xpr-yprs (cddr form)))
        (let ((name (car header))
              (var-vals (cdr header)))
    `(define (,name)
       (when (verbose?)
         (print "\nIn " ',name ":")
         (print* "==="
                 (make-string (string-length
                                (symbol->string ',name)) #\=)
                 "=\n")
         )
         ((check* ,(chop var-vals 2) ,@xpr-yprs) (verbose?))))))))

(define (test-all-proc name . test-name-pairs)
  ; used internally in test-all, must be exported within test-all
  (let loop ((pairs (chop test-name-pairs 2)) (failures '()))
    (cond
      ((null? pairs)
       (newline)
       (print "Failed tests in " name ":")
       (print "================"
              (make-string (string-length (symbol->string name)) #\=)
              "=")
       (if (null? failures)
         (print "none")
         (for-each print (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))))))

#|[
(test-all Name tester ....)
--- macro test-all-proc ---
invokes all testers defined with define-tester
producing a list of failures and exiting with 0 or 1
]|#
(define-syntax test-all
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((name (cadr form))
            (tests (cddr form))
            (%test-all-proc (rename 'test-all-proc))
            (%list (rename 'list))
            )
        `(,%test-all-proc ',name
                          ,@(apply append
                                   (map (lambda (t) `((,t) '(,t)))
                                        tests)))))))

#|[
(check-all Name check-xpr ....)
--- macro test-all-proc ---
Deprecated!
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))
            (%test-all-proc (rename 'test-all-proc))
            )
        `(,%test-all-proc ',name
                          ,@(apply append
                                   (map (lambda (t) `(,t ',t))
                                        checks)))))))

#|[
(simple-tests)
(simple-tests sym)
--- procedure ---
documentation procedure
]|#
(define simple-tests
  (let (
    (alist '(
      (verbose?
        parameter:
        (verbose? ..)
        "gets or sets the value of the parameter verbose?"
        )
      (writeln
        procedure:
        (writeln xpr ...)
        "write analog of print, expressions separated by whitespace"
        )
      (and?
        procedure:
        (and? . xprs)
        "non-short-circuited and which executes all side-effects"
        )
      (pe
        macro:
        (pe macro-code)
        "composes pretty-print and expand,"
        "does nothing in compiled code."
        )
      (xpr:val
        macro:
        (xpr:val xpr ...)
        "Deprecated!"
        "Print each xpr quoted in a headline and pretty-print xpr's computed"
        "value."
        )
      (ppp
        macro:
        (ppp xpr ...)
        "print each xpr quoted in a headline and pretty-print xpr's computed"
        "value. Alias to xpr:val."
        )
      (ppp*
        macro:
        (ppp* {xpr ypr} ...)
        "Deprecated!"
        "Print each xpr quoted in a headline and pretty-print xpr's computed"
        "and expected value, ypr."
        )
      (xpr:val*
        macro:
        (xpr:val* {xpr ypr} ...)
        "Deprecated!"
        "Print each xpr quoted in a headline and pretty-print xpr's computed"
        "and expected value, ypr."
        "Alias to ppp*"
        )
      (ppp**
        macro:
        (ppp** ((var val) ...) xpr ypr . other-xpr-ypr-pairs)
        "Deprecated!"
        "ppp* wrapped into a let"
        )
      (define-test
        macro:
        (define-test (name . parameters) form . forms)
        "Deprecated!"
        "Creates a test function"
        )
      (compound-test
        macro:
        (compound-test (name) test . tests)
        "Deprecated!"
        "Invokes all tests and reports a summary"
        )
      (==
        procedure:
        (==)
        (== x)
        (== type? type-equal?)
        "Deprecated!"
        "Generic type equality as curried procedure"
        )
      (check
        macro:
        (check ((var val) ...) xpr ypr . xpr-yprs)
        "Compare xpr and ypr .... in sequence with equal?"
        "in the environment defined by var val ..."
        )
      (define-checks
        macro:
        (define-checks (name? verbose? . var-vals) xpr ypr . xpr-yprs)
        "Deprecated!"
        "Returns a unary predicate, name?, comparing xpr with ypr ...."
        "and using var val ... within this checks,"
        "verbose? controls the reported summary."
        )
      (do-checks
        macro:
        (do-checks (name? verbose? . var-val-pairs) xpr ypr . xpr-yprs)
        "Deprecated!"
        "Returns a unary predicate, name?, comparing xpr with ypr ...."
        "and using var val ... within this checks,"
        "alias to define-checks"
        )
      (define-tester
        macro:
        (define-tester (name? . var-vals) xpr ypr . xpr-yprs)
        "Returns a thunk predicate, name?, comparing xpr with ypr ...."
        "and using var val ... within this tests."
        "The parameter verbose? controls the reported summary, i. e."
        "the side effects."
        )
      (test-all
        macro:
        (test-all Name tester ....)
        "invokes all testers defined with define-tester"
        "producing a list of failures and exiting with 0 or 1"
        )
      (check-all
        macro:
        (check-all Name check-xpr ....)
        "Deprecated!"
        "checks all check-expressions defined with define-checks"
        "producing a list of failures and exiting with 0 or 1"
        )
      (simple-tests
        procedure:
        (simple-tests)
        (simple-tests sym)
        "with sym: documentation of exported symbol"
        "without sym: list of exported symbols"
        )
        ))
      )
      (case-lambda
        (() (map car alist))
        ((sym)
         (let ((pair (assq sym alist)))
           (if pair
             (for-each print (cdr pair))
             (print "Choose one of " (map car alist))))))))
)