; 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
  xpr:val
  ppp
  xpr:val*
  ppp*
  ; old interface
  define-test
  (compound-test group-on-cdrs)
  *locations*
  *failures*
  ; new interface
  ==
  define-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 sym ..)
                  (and? xpr ...)
                  (writeln xpr ....)
                  (pe macro-code)
                  (xpr:val xpr ...)
                  (ppp xpr ...)
                  (xpr:val* {xpr val} ...)
                  (ppp* {xpr val} ...)

                  (define-test (name . parameters) form . forms)
                  (check form . forms)
                  (compound-test (name) test . tests)

                  (==)
                  (== x)
                  (== type? type-equal?)
                  (define-checks (name? verbose? {arg val} ...) {xpr expected} ....)
                  (check-all name check-xpr ....)))
    )
    (case-lambda
      (() (map car signatures))
      ((sym) (assq sym 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 val)
     (begin (print "Testing " 'xpr " ...")
            (print* "computed: ") (pp xpr)
            (print* "expected: ") (pp val)
            ))
    ((_ xpr val . pairs)
     (begin (help-ppp* xpr val)
            (help-ppp* . pairs)))
    ))
;
;;;; (ppp* {xpr val} ...)
;;; --------------------
;;; print each xpr quoted in a headline and pretty-print xpr's computed
;;; and expected value.
(define-syntax ppp*
  (syntax-rules ()
    ((_ . pairs)
     (cond-expand
       ((not compiling)
        (help-ppp* . pairs))
       (else)))))

;;; (xpr:val* {xpr val} ...)
;;; ------------------------
;;; print each xpr quoted in a headline and pretty-print xpr's computed
;;; and expected value.
;;; Alias to ppp*
(define-syntax xpr:val*
  (syntax-rules ()
    ((_ . pairs)
     (ppp* . 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 . 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))))))))

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

;;; (define-checks (name? verbose? {arg val} ...) {xpr expect} ....)
;;; ----------------------------------------------------------------
;;; returns a unary predicate, name?, comparing xpr with expect ....
;;; and using arg val ... within this checks
(define-syntax define-checks
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((name (caadr form))
            (verbose? (cadadr form))
            (args* (cddadr form))
            (pairs* (cddr form))
            (%tests (rename 'tests))
            (%writeln (rename 'writeln))
            (%set! (rename 'set!))
            (%print (rename 'print))
            (%print* (rename 'print*))
            (%begin (rename 'begin))
            (%let (rename 'let))
            (%equal? (rename 'equal?)) ;;;
            (%== (rename '==))
            (%cons (rename 'cons))
            (%and (rename 'and))
            (%reverse (rename 'reverse))
            (%if (rename 'if))
            (%null? (rename 'null?))
            (%fails (rename 'fails))
            (%map (rename 'map))
            (%cdr (rename 'cdr))
            (%car (rename 'car))
            (%apply (rename 'apply))
            (%append (rename 'append))
            (%define (rename 'define))
            (%make-string (rename 'make-string))
            (%string-length (rename 'string-length))
            (%symbol->string (rename 'symbol->string))
            (%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))))))))
            )
`(,%define (,name ,verbose?)
   (,%let ,(chop args* 2)
     (,%when ,verbose?
       (,%print "In " ',name ":")
       (,%print* "---"
                 (,%make-string (,%string-length
                                  (,%symbol->string ',name)) #\-)
                 "-")
       )
     (,%let ((,%tests '()))
       ,@(map (lambda (p)
                `(,%begin
                   (,%when ,verbose?
                     (,%print "\ntesting " ',(car p) " ...")
                     ;;(,%writeln 'computed ,(car p))
                     (,%print* "computed: ") (,%writeln ,(car p))
                     ;;(,%writeln 'expected ,(cadr p))
                     (,%print* "expected: ") (,%writeln ,(cadr p))
                     )
                   (,%set! ,%tests
                           ;(,%cons (,%cons ,(cons %equal? p) ',(car p)) ; ok
                           (,%cons (,%cons ((,%== ,(car p)) ,(cadr p)) ',(car p))
                                   ,%tests))
                   ))
              (chop pairs* 2))
       (,%let ((,%fails (,select-failures (,%reverse ,%tests))))
         (,%when ,verbose?
           (,%print "\nList of failed test expressions: "
                    (,%map ,%cdr ,%fails) "\n")
                    ;(,%apply ,%append (,%map ,%cdr ,%fails)))
                    )
         (,%if (,%null? ,%fails) #t #f)))))
 ))))

(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 "In " name ":")
       (print "==="
              (make-string (string-length (symbol->string name)) #\=)
              "=")
       (print* "List of failed tests: "
              (map car (reverse failures)))
       (if (null? failures)
         (exit 0)
         (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)