(in-package :ll-user) ;;; Initiation (defmacro def-test-ok (suite name &body body) `(test-add ,suite (make-instance 'test-ok :name ,name :fun (lambda () ,@body)))) (defmacro def-test-type (suite name type &body body) `(test-add ,suite (make-instance 'test-type :type ,type :name ,name :fun (lambda () ,@body)))) (defun make-test-suite (name) (make-instance 'test-suite :name name)) (defun approx= (a b &optional (c 1e-12)) ; FUNKER IKKE (cond ((and (matrix-p a) (matrix-p b)) (.every (lambda (a b) (approx= a b c)) a b)) ((matrix-p a) (.every (lambda (a) (approx= a b c)) a)) ((matrix-p b) (.every (lambda (b) (approx= a b c)) b)) (t (<= (.sqrt (.+ (.^ (.re (.- a b)) 2) (.^ (.im (.- a b)) 2))) c)))) ;; Generic functions (defgeneric test-run (test) (:documentation "Runs test.")) (defgeneric test-reset (test) (:documentation "Resets test.")) (defgeneric test-report (test &key) (:documentation "Reports test results.")) (defgeneric test-add (test-suite test) (:documentation "Adds a test to the test suite.")) (defclass test-base () ((name :accessor test-name :initarg :name) (fun :initarg :fun) (has-run :initarg :has-run :initform nil) (ok :initarg :ok) (msg :initarg :msg :initform "")) (:documentation "The basic test class for a individual test.")) (defmethod test-report ((test test-base) &key (stream *standard-output*)) (with-slots (name has-run ok msg) test (if (not has-run) (format stream "~&Not run [~a]" name) (if ok (format stream "~&OK [~a]" name) (format stream "~&FAILED [~a] [~a]" name msg))) ok)) (defmethod test-reset ((test test-base)) (with-slots (has-run ok msg) test (setf has-run nil ok nil msg ""))) ;; Test for non-nil (defclass test-ok (test-base) () (:documentation "The test is ok if output is non-nil")) (defmethod test-run ((test test-ok)) (with-slots (fun has-run ok msg) test (multiple-value-bind (val err) (ignore-errors (funcall fun)) (setf has-run t) (if val (setf ok t) (progn (setf ok nil) (setf msg err)) )) ok)) ;; Test of type (defclass test-type (test-base) ((type :initarg :type)) (:documentation "Test if the output of running fun has the require type.")) (defmethod test-run ((test test-type)) (with-slots (fun has-run ok msg type) test (multiple-value-bind (val err) (ignore-errors (eql type (type-of (funcall fun)))) (setf has-run t) (if (and (not val) err) (progn (setf ok nil) (setf msg err)) (setf ok t))) ok)) ;; The test suite (defclass test-suite (test-base) ((tests :initform nil) (verbose-p :initform t)) (:documentation "The test suite class. It is also a test.")) (defmethod test-reset (test-suite) (call-next-method ) (with-slots (tests) test-suite (dolist (test tests) (test-reset test)))) (defmethod test-run ((suite test-suite)) (with-slots (tests msg ok has-run) suite (setf ok t msg "FAILED: ") (dolist (test tests) (unless (test-run test) (setf ok nil) (setf msg (format nil "~a ~a" msg (test-name test))))) (setf has-run t) ok)) (defmethod test-report ((suite test-suite) &key (stream *standard-output*)) (with-slots (name tests has-run ok msg) suite (format stream "~&==== START [~a]" name) (if (not has-run) (format stream "~&Not run [~a]" name) (progn (dolist (test tests) (test-report test :stream stream)) (format stream "~&==== END [~a]: " name) (if ok (format stream "OK") (format stream "FAILED [~a]" msg)))) ok)) (defmethod test-add ((suite test-suite) (test test-base)) (with-slots (tests has-run) suite (setf tests (append tests (list test)) has-run nil))) #| (defclass test-suite-no-error (test-suite) ()) (defmethod reset-test-suite ((test-suite test-suite-no-error)) (with-slots (tests run-p failed-tests) test-suite (setf tests (make-hash-table) run-p nil failed-tests (make-hash-table)))) (defun put-test-no-error (name test) (setf (gethash name *test-no-error* ) test)) (defmacro def-test-no-error (name &body body) `(put-test-no-error ',name (lambda () ,@body))) (defun run-test-no-error (&key (stream *standard-output*)) (maphash #'(lambda (name test) (multiple-value-bind (val err) (ignore-errors (funcall test)) (if val (format stream "~&OK [~a]" name) (progn (push name *test-no-error-failed*) (format stream "~&FAILED [~a]. [~a]" name err))))) *test-no-error*)) |#