;;;; File: tests.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Oct 24, 2010
;;;;       Nov 28, 2010
;;;;       Dec 06, 2010
;;;;       Jan 04, 2011
;;;;       Jan 07, 2011
;;;;       Jan 12, 2011
;;;;       Jan 20, 2011
;;;;       Jan 31, 2011
;;;;       Feb 16, 2011

;In this module we implement three macros to be used for testing.
;The first, dispatcher, implements a primitive version
;of object-oriented programming with simple inheritance. It's included
;in this module, because it's often used in conjunction with
;compare-with, the second macro, which does most of the work: Its first
;argument is used to compare the second with the third, the fourth with
;the fifth, and so on. Then there is xpr:val which prints its argument
;expressions with their values.

(require 'contracts)

(module tests (dispatcher compare-with xpr+doc xpr:val tests)

(import scheme
        (only extras pp)
        (only data-structures sort)
        (only srfi-13 string<)
        (only contracts define-syntax-with-contract doclist doclist->dispatcher))

;;; (dispatcher delegate (sym0 . xprs0) (sym1 . xprs1) ...)
;;; -------------------------------------------------------
;;; returns a function of zero or one parameter, a symbol, which is
;;; matched against sym0 sym1 ... and the corresponding expressions are
;;; evaluated. If no symbol matches, another dispatcher, delegate, is
;;; called with this argument. Called with no argument, the resulting
;;; procedure returns the available symbols along the delegation chain
;;; sorted.
(define-syntax dispatcher
  (syntax-rules ()
    ((_ delegate (sym0 . xprs0) ...)
     (letrec (
       (sym< (lambda (x y)
               (string< (symbol->string x) (symbol->string y))))
       (cons<
         (lambda (sym syms)
           (if (null? syms)
             (list sym)
             (let ((syms (sort syms sym<)))
               (cond
                 ((eq? sym (car syms))
                  syms)
                 ((sym< sym (car syms))
                  (cons sym syms))
                 (else 
                   (cons (car syms) (cons< sym (cdr syms)))))))))
       (union< (lambda (lst1 lst2)
                 (let loop ((lst lst1) (result (sort lst2 sym<)))
                   (if (null? lst)
                     result 
                     (loop (cdr lst) (cons< (car lst) result))))))
       )
       (let (
         (old-syms (if delegate (delegate) '()))
         (syms '(sym0 ...))
         )
         (case-lambda 
           (()
            (newline)
            (print "Choose one of:")
            (print "--------------")
            (for-each print (union< syms old-syms)))
           ((sym)
            (case sym
              ((sym0) (begin . xprs0))
              ...
              (else 
                (if delegate
                  (delegate sym)
                  (begin
                    (newline)
                    (print "Not found: " sym)
                    (print "Choose one of:")
                    (print "--------------")))
                (for-each print (union< syms old-syms)))))))))))

;Now to the two testing macros proper, compare-with and xpr:val.
;We start with compare-with, which does most of the useful work, namely
;it regroups its arguments, by chopping its xpr-val pairs and prefixing
;it with its first argument, a comparison operator, equ?, which checks,
;if xpr evaluates to the expected value, val. The list of (equ? xpr val)
;triples is then split into two sublists, which succeed or fail,
;respectively. It's implemented as low-level macro, because the list of
;tests is processed procedurally - syntax-rules would have required a
;helper macro.  A trivial (failing!) example is
;
;  (let ((x 1) (y 2)) (compare-with = x 1 y 1))

;;; (compare-with equ? var val var1 val1 ...)
;;; -----------------------------------------
;;; splits the list of expressions
;;; (equ? var val) (equ? var1 val1) ...
;;; into succeeding and failing ones
;;; using values.
(define-syntax compare-with
  (lambda (form rename compare?)
    (let (
      (equ? (cadr form))
      (xprs+vals (cddr form))
      (%if (rename 'if))
      (%pp (rename 'pp))
      (%else (rename 'else))
      (%cond (rename 'cond))
      (%null? (rename 'null?))
      (%print (rename 'print))
      (%begin (rename 'begin))
      (%newline (rename 'newline))
      (%for-each (rename 'for-each))
      )
      (let (
        (tests (map (lambda (pair) `(,equ? ,@pair))
                    (chop xprs+vals 2)))
        )
        (let loop (
          (xprs tests)
          (success '())
          (failure '())
          )
          (if (null? xprs)
            (cond
              ((null? failure)
               `(,%begin
                  (,%print "\nAll tests passed:")
                  (,%print "-----------------")
                  (,%for-each ,%pp ',(reverse success))
                  (,%newline)))
              ((null? success)
               `(,%begin
                  (,%print "\nAll tests failed:")
                  (,%print "#################")
                  (,%for-each ,%pp ',(reverse failure))
                  (,%newline)))
              (else
                `(,%begin
                   (,%print "\nPassed tests:")
                   (,%print "-------------")
                   (,%for-each ,%pp ',(reverse success))
                   (,%print "Failed tests:")
                   (,%print "#############")
                   (,%for-each ,%pp ',(reverse failure))
                   (,%newline))))
            `(,%if ,(car xprs)
              ,(loop (cdr xprs) (cons (car xprs) success) failure)
              ,(loop (cdr xprs) success (cons (car xprs)
                                              failure)))))))))

;The following macro, xpr:val, prints the literal representation of each
;of its arguments as well as their respective values, all with some
;decoration around, so that it stands out in the print. All that is done with
;printf, a Chicken expansion. Then everything is wrapped into eval-when,
;another Chicken expansion, so that it is not evaluated in compiled
;code.

;;; (xpr:val xpr xpr1 ...)
;;; ----------------------
(define-syntax xpr:val
  (syntax-rules ()
    ((_ xpr xpr1 ...)
     (eval-when (eval)
       (printf "*** ~A:~%    ~S ***~%" 'xpr xpr)
       (printf "*** ~A:~%    ~S ***~%" 'xpr1 xpr1)
       ...
       ))))

;;; (xpr+doc xpr)
;;; -------------
(define-syntax xpr+doc
  (syntax-rules ()
    ((_ xpr)
     (values xpr 'xpr))))

(define tests
  (doclist->dispatcher
    '((compare-with
        "splits the list (equ? xpr val) ..."
        "where xprs+vals is xpr val xpr1 val1 ..."
        "into succeeding and failing ones using values"
        "and packages it as  a thunk"
        (compare-with equ? xpr val exp1 val1 ...))
      (xpr:val
        "prints the literal represenataion of expressions"
        "as well as its values with some decoration."
        "Does not remain in compiled code"
        (xpr:val xpr xpr1 ...))
      (xpr+doc
        "returns two values, the value of xpr and its literal representation"
        (xpr+doc xpr))
      (dispatcher
        "transforms its arguments into a dispatcher routine"
        (dispatcher delegate (sym0 xpr0) (sym1 xpr1) ...)
        "where delegate is either #f or another dispatcher."
        "The returnd procedure compares its symbol argument"
        "whith sym0 sym1 ... in sequence and returns the"
        "corresponding xpr. Called with no argument it returns"
        "the available symbols along the delegation chain sorted"))))

) ; module tests