;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: MSL.TEST -*-

;;; $Revision: 1.4 $
;;; Copyright © 2003 Paul Foley (mycroft@actrix.gen.nz)
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this Software to deal in the Software without restriction,
;;; including without limitation the rights to use, copy, modify, merge,
;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;; and to permit persons to whom the Software is furnished to do so,
;;; provided that the above copyright notice and this permission notice
;;; are included in all copies or substantial portions of the Software.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
#+CMU (ext:file-comment "$Header: /cvsroot/homepage/test.lisp,v 1.4 2003/11/05 10:43:56 anoncvs Exp $")

(defpackage "MSL.TEST"
  (:use "COMMON-LISP" #+CMU "EXTENSIONS")
  #+CMU (:import-from "KERNEL" "TOPOLOGICAL-SORT")
  #+CMU (:import-from "SYSTEM" "PARSE-BODY")
  (:export "DEFINE-TEST-GROUP" "DEFTEST" "ENSURE" "ALL-TESTS" "RUN-TESTS"
	   "*BREAK-ON-FAIL*"))

(in-package "MSL.TEST")

(defvar *break-on-fail* nil)

#-CMU
(defun required-argument ()
  (error "A required argument was not supplied."))

#-CMU
(defun parse-body (body env &optional doc-p)
  (declare (ignore env))
  (let ((decls '())
	(doc nil))
    (loop
      (cond ((and (consp (first body)) (eq (first (first body)) 'declare))
	     (push (pop body) decls))
	    ((and doc-p (null doc) (stringp (first body)))
	     (setq doc (pop body)))
	    (t
	     (return (values body (nreverse decls) doc)))))))

#-CMU
(defun topological-sort (elements constraints tie-breaker)
  (let ((result '()))
    (loop
      (let* ((rhs (mapcar #'cdr constraints))
	     (elts (remove-if (lambda (x) (member x rhs)) elements)))
	(when (null elts)
	  (if elements
	      (error "Inconsistent constraints in ~S" 'topological-sort)
	      (unless elements (return (nreverse result)))))
	(let ((elt
	       (if (cdr elts) (funcall tie-breaker elts result) (car elts))))
	  (push elt result)
	  (setq elements (delete elt elements))
	  (setq constraints (delete-if (lambda (x)
					 (or (eq (car x) elt)
					     (eq (cdr x) elt)))
				       constraints)))))))

(defstruct (test-group
	     (:constructor make-test-group (name &key pre post docstring))
	     (:print-function %print-test-group))
  (name (required-argument) :type symbol :read-only t)
  (docstring nil :type (or null simple-base-string) :read-only t)
  (tests (make-hash-table) :type hash-table :read-only t)
  (pre nil :type (or null function))
  (post nil :type (or null function)))

(defstruct (test
	     (:constructor make-test (name fn &key after after-pass after-fail
						   when unless priority
						   docstring))
	     (:print-function %print-test))
  (name (required-argument) :type symbol :read-only t)
  (docstring nil :type (or null simple-base-string) :read-only t)
  (fn (required-argument) :type function :read-only t)
  (priority 0 :type fixnum)
  (after '() :type list)
  (after-pass '() :type list)
  (after-fail '() :type list)
  (when nil :type (or null function))
  (unless nil :type (or null function)))

(defun %print-test-group (group stream depth)
  (declare (ignore depth))
  (print-unreadable-object (group stream :type t :identity t)
    (format stream "~S, ~D tests" (test-group-name group)
	    (hash-table-count (test-group-tests group)))))

(defun %print-test (test stream depth)
  (declare (ignore depth))
  (print-unreadable-object (test stream :type t :identity t)
    (princ (test-name test) stream)))

(defun find-test-group (name &optional create)
  (if (test-group-p name)
      name
      (let ((group (get name 'tests)))
	(cond (group group)
	      (create (setf (get name 'tests) (make-test-group name)))))))

(defmacro define-test-group (name &optional opts docstring)
  (let ((tmp (gensym "GROUP"))
	(pre (gensym))
	(post (gensym)))
    `(let ((,tmp (find-test-group ',name))
	   (,pre ,(getf opts :before))
	   (,post ,(getf opts :after)))
       (if (null ,tmp)
	   (setf (get ',name 'tests) (make-test-group ',name
						      :pre ,pre
						      :post ,post
						      :docstring ',docstring))
	   (progn
	     (when ,pre (setf (test-group-pre ,tmp) ,pre))
	     (when ,post (setf (test-group-post ,tmp) ,post))
	     ,tmp)))))

(defmacro test-block (name &body body)
  `(macrolet ((ensure (form test result)
		`(handler-case
		     ,(if (string-equal test "SIGNALS")
			  `(let ((actual (multiple-value-list ,form)))
			     (format t "~&Test ~A failed~
                                        ~&Form: ~S~
                                        ~&Expected to signal condition ~S.~
                                        ~&Returned: ~
                                           ~{~S~^~&~10T~}.~%"
				     ',',name ',form ',result actual))
			  `(let ((actual (multiple-value-list ,form))
			         (expect (multiple-value-list ,result)))
			     (if (and (= (length actual) (length expect))
				      (every #'equal actual expect))
			         t
			         (format t "~&Test ~A failed~
                                            ~&Form: ~S~
                                            ~&Expected value~P: ~
                                               ~{~S~^~&~17T~}~
                                            ~&Actual value~P: ~
                                               ~{~S~^~&~15T~}.~%"
				         ',',name ',form
				         (length expect) expect
				         (length actual) actual))))
		   ,@(when (string-equal test "SIGNALS") `((,result () t)))
		   (simple-error (condition)
		     (format t "~&Test ~A failed~
                                ~&Form: ~S~
                                ~&Error: ~A~%"
			     ',',name ',form
			     (apply #'format nil
				    (simple-condition-format-control condition)
				    (simple-condition-format-arguments
				     condition))))
		   (error (condition)
		     (format t "~&Test ~A failed~
                                ~&Form: ~S~
                                ~&~A~%"
			     ',',name ',form condition)))))
    (block ,name ,@body)))

(defmacro deftest (name (group &key after after-pass after-fail when unless
				    priority)
			&body body)
  (multiple-value-bind (body decls doc) (parse-body body nil t)
    (let* ((fn (intern (concatenate 'string #.(string '#:test-)
				    (string name) "/" (string group))))
	   (hash (gensym "HASH"))
	   (keys (append (cond ((consp after) `(:after ',after))
			       (after `(:after '(,after))))
			 (cond ((consp after-pass) `(:after-pass ',after-pass))
			       (after-pass `(:after-pass '(,after-pass))))
			 (cond ((consp after-fail) `(:after-fail ',after-fail))
			       (after-fail `(:after-fail '(,after-fail))))
			 (when when `(:when (lambda () ,when)))
			 (when unless `(:unless (lambda () ,unless)))
			 (when doc `(:docstring ,doc))
			 (if priority
			     `(:priority ,priority)
			     `(:priority (if (gethash ',name ,hash)
					     (test-priority
					      (gethash ',name ,hash))
					     (hash-table-count ,hash)))))))
      `(progn
	 (defun ,fn ()
	   ,doc
	   ,@decls
	   (test-block ,name
	     ,@body))
	 (let ((,hash (test-group-tests (find-test-group ',group t))))
	   (when (gethash ',name ,hash) (warn "Redefining test ~A." ',name))
	   (setf (gethash ',name ,hash) (make-test ',name #',fn ,@keys)))
	 ',name))))

(defun all-tests (group)
  (let* ((group (find-test-group group))
	 (tests (loop for x being the hash-values of (test-group-tests group)
		     collecting x))
	 (constraints '()))
    (dolist (test tests)
      (dolist (val (test-after test))
	(push (cons val (test-name test)) constraints))
      (dolist (val (test-after-pass test))
	(push (cons val (test-name test)) constraints))
      (dolist (val (test-after-fail test))
	(push (cons val (test-name test)) constraints)))
    (topological-sort (map-into tests #'test-name tests) constraints
      (lambda (x y)
	(declare (ignore y))
	(first (stable-sort (copy-seq x) #'<
		  :key (lambda (name)
			 (test-priority
			  (gethash name (test-group-tests group))))))))))

(defun do-test (test)
  (let ((time (get-internal-run-time)))
    (values (ignore-errors (funcall (test-fn test)))
	    (/ (float (- (get-internal-run-time) time) 1f0)
	       (float internal-time-units-per-second 1f0)))))

(defun run-tests (group &key (skip nil) (break-on-fail *break-on-fail*))
  (let ((group (find-test-group group))
	(passed '())
	(failed '()))
    (when (test-group-pre group)
      (funcall (test-group-pre group)))
    (unwind-protect
	 (dolist (name (all-tests group))
	   (tagbody
	    try-again
	      (let ((test (gethash name (test-group-tests group))))
		(unless (or (member name skip)
			    (and (test-when test)
				 (not (funcall (test-when test))))
			    (and (test-unless test)
				 (funcall (test-unless test)))
			    (set-difference (test-after-pass test) passed)
			    (set-difference (test-after-fail test) failed))
		  (multiple-value-bind (pass-p time) (do-test test)
		    (when (and (not pass-p) break-on-fail)
		      (restart-case
			  (break "Test ~A failed with BREAK-ON-FAIL set."
				 name)
			(try-again ()
			  :report "Try the test again."
			  (go try-again))))
		    (if pass-p
			(progn (push name passed)
			       (format t "~&** PASS: ~A" name))
			(progn (push name failed)
			       (format t "~&** FAIL: ~A" name)))
		    (multiple-value-bind (hours time) (floor time 3600)
		      (multiple-value-bind (minutes seconds) (floor time 60)
			(format t "~35T[~2,'0D:~2,'0D:~5,2,,,'0F]~%"
				hours minutes seconds))))))))
      (when (test-group-post group)
	(funcall (test-group-post group))))
    (let ((pass (length passed))
	  (fail (length failed))
	  (total (hash-table-count (test-group-tests group))))
      (format t "~2&Ran ~D of ~D test~:P in group ~S~%" (+ pass fail) total
	      (test-group-name group))
      (when failed
	(format t "~&The following tests failed:~%  ~S~%" failed))
      (format t "~2&Totals -- Passed: ~D~25T~3D%~&~10TFailed: ~D~25T~3D%~%"
	      pass (round (* 100 pass) total)
	      fail (round (* 100 fail) total)))
    (null failed)))