;;; rt.lisp --- regression testing

 ;; Regression Testing framework. inspired by PCL, the original CMUCL

 ;; code, and the SBCL port.

 ;;; Commentary:

 ;; - :rt https://www.merl.com/publications/docs/TR91-04.pdf Chapter 1

 ;; - :com.gigamonkeys.test https://github.com/gigamonkey/monkeylib-test-framework

 ;; - :sb-rt https://github.com/sbcl/sbcl/blob/master/contrib/sb-rt/rt.lisp

 ;; This package is intended to provide a modernized Lisp testing

 ;; library with features found in some of the test frameworks listed

 ;; below.

 ;; - :it.bese.fiveam https://github.com/lispci/fiveam

 ;; - :try https://github.com/melisgl/try

 ;; - :rove https://github.com/fukamachi/rove

 ;;; TODO:

 #|

 - [ ] benchmark support: do-bench, test-count, 

 - [ ] fixtures api

 - [ ] profiling 

 |#

 ;;; Code:

 (in-package :std-user)

 (require 'sb-cover)

 (defpackage :rt

   (:use 

    :cl :std :sxp :log

    :sb-aprof)

   (:export

    :test-error

    :*test-opts*

    :*compile-tests*

    :*catch-test-errors*

    :*test-suffix*

    :*default-test-suite-name*

    :*test-suite*

    :*test-suite-list*

    ;;  TODO 2023-09-04: :*test-profiler-list* not yet

    :*testing*

    :random-elt

    :random-ref

    :random-char

    :random-chars

    :random-bytes

    :test-suite-designator

    :check-suite-designator

    :make-test

    :make-suite

    :test-name=

    :do-test

    :do-tests

    :reset-tests

    :continue-testing

    :with-test-env

    :%test-bail

    :%test-result

    :make-test-result

    :ensure-suite

    :test-fixture

    :fixture-prototype

    :make-fixture-prototype

    :make-fixture

    :with-fixture

    :test-result

    :test-fn

    :test-pass-p

    :test-fail-p

    :test-skip-p

    :test-failed

    :fail!

    :is

    :signals

    :deftest

    :defsuite

    :in-suite

    :eval-test

    :compile-test

    :locked-tests

    :push-test

    :pop-test

    :delete-test

    :find-test

    :find-suite

    :do-suite

    :test-object

    :test

    :test-fixture

    :test-suite

    :test-name

    :tests

    :test-form

    :test-results))

 (defpackage :rt/bench

   (:nicknames :bench)

   (:use :cl :std :log :rt)

   (:export

    :*bench-count*

    :defbench

    :do-bench))

 (uiop:define-package :rt/cover

   (:nicknames :cover)

   (:use :cl :std :log :rt)

   (:export

    :with-coverage :start-coverage :stop-coverage

    :*coverage-directory*

    :coverage-report))

 (defpackage :rt/tracing

   (:nicknames :tracing)

   (:use :cl :std :log :rt)

   (:export

    :start-tracing

    :stop-tracing

    :with-tracing

    :save-report

    ;; Extra utility

    :package-symbols-except))

 (defpackage :rt/flamegraph

   (:nicknames :flamegraph)

   (:use :cl :std :log :rt :sb-sprof)

   (:export :save-flamegraph))

 (in-package :rt)

 (in-readtable :std)

 ;;; Vars

 (defvar *test-opts* '(optimize sb-c::instrument-consing))

 (defvar *compile-tests* nil

   "When nil do not compile tests. With a value of t, tests are compiled

 with default optimizations else the value is used to configure

 compiler optimizations.")

 (defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.")

 (defvar *test-suffix* "-TEST" "A suffix to append to every `test' defined with `deftest'.")

 (defvar *test-suite-list* nil "List of available `test-suite' objects.")

 (defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.")

 (eval-when (:compile-toplevel :load-toplevel :execute)

   (defvar *default-test-suite-name* "default"))

 (declaim (type (or stream boolean string) *test-input*))

 (defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.")

 (defvar *testing* nil "Testing state var.")

 ;;; Utils

 ;; random

 (defvar *simple-charset* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")

 (defun random-elt (seq)

   (elt seq (random (length seq))))

 (defun random-ref (vec)

   (aref vec (random (length vec))))

 (defun random-char ()

   (random-ref *simple-charset*))

 (defun random-chars (dim)

   (let ((r (make-array dim :element-type 'character)))

     (dotimes (i (array-total-size r) r)

       (setf (row-major-aref r i) (random-char)))))

 (defun random-byte () (random 255))

 (defun random-bytes (dim)

   (let ((r (make-array dim :element-type 'octet)))

     (dotimes (i (array-total-size r) r)

       (setf (row-major-aref r i) (random-byte)))))

 (eval-when (:compile-toplevel :load-toplevel :execute)

   (defun make-test (&rest slots)

     (apply #'make-instance 'test slots))

   (defun make-suite (&rest slots)

     (apply #'make-instance 'test-suite slots)))

 ;; TODO 2023-09-04: optimize

 ;;(declaim (inline do-tests))

 (defun do-tests (&optional (suite *test-suite*) force (output *standard-output*))

   (if (pathnamep output)

       (with-open-file (stream output :direction :output)

 	(do-suite (ensure-suite suite) :stream stream :force force))

       (do-suite (ensure-suite suite) :stream output :force force)))

 (defvar *test-output-mutex* (sb-thread:make-mutex :name "tests-output"))

 ;; TODO

 (defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*))

   (declare (ignore suite force))

   (sb-thread:with-mutex (*test-output-mutex*)

     (let ((stream (make-synonym-stream output)))

       (let ((*standard-output* stream)

             (*error-output* stream))

         (nyi!)))))

 (defun reset-tests ()

   (setq *testing* nil

         *test-suite* nil

         *test-suite-list* nil

         *test-input* nil))

 ;; this assumes that *test-suite* is re-initialized correctly to the

 ;; correct test-suite object.

 (defun continue-testing ()

   (if-let ((test *testing*))

     (throw '%in-test test)

     (do-suite *test-suite*)))

 ;; NOTE 2023-09-01: `pushnew' does not return an indication of whether

 ;; place is changed - it returns place. This is functionally sound but

 ;; means that if we want to do something else in the event that place

 ;; is unchanged, we run into some friction,

 ;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure

 (defun spush (item lst &key (test #'equal))

   "Substituting `push'"

   (declare (type function test))

   (cond

     ((null lst) (push item lst))

     ((list lst)

      (if-let ((found (member item lst

 			     :test test)))

        (progn

 	 (rplaca found item)

 	 lst)

        (push item lst)))

     #|(or nil '(t (cons item lst)))|#))

 ;; FIX 2023-08-31: spush, replace with `add-test' method.

 ;; (declaim (inline normalize-test-name))

 (defun normalize-test-name (a)

   "Return the normalized `test-suite-designator' of A."

   (etypecase a

     (string (string-upcase a))

     (symbol (symbol-name a))

     (test-object (normalize-test-name (test-name a)))

     (t (format nil "~A" a))))

 (defun test-name= (a b)

   "Return t if A and B are similar `test-suite-designator's."

   (let ((a (normalize-test-name a))

 	(b (normalize-test-name b)))

     (string= a b)))

 ;; (declaim (inline assert-suite ensure-suite))

 (defun ensure-suite (name)

   (if-let ((ok (member name *test-suite-list* :test #'test-name=)))

     (car ok)

     (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*))))

 (defun check-suite-designator (suite) (check-type suite test-suite-designator))

 (defun assert-suite (name)

   (check-suite-designator name)

   (assert (ensure-suite name)))

 (declaim (inline test-opt-key-p test-opt-valid-p))

 (defun test-opt-key-p (k)

   "Test if K is a `test-opt-key'."

   (member k '(:profile :save :stream)))

 (defun test-opt-valid-p (f)

   "Test if F is a valid `test-opt' form. If so, return F else nil."

   (when (test-opt-key-p (car f))

     f))

 ;;; Conditions

 (define-condition test-failed (error)

   ((reason :accessor fail-reason :initarg :reason :initform "unknown")

    (name :accessor fail-name :initarg :name)

    (form :accessor fail-form :initarg :form))

   (:documentation "Signaled when a test fails.")

   (:report (lambda (c s)

 	     (format s "The following expression failed: ~S~%~A."

 		     (fail-form c)

 		     (fail-reason c)))))

 ;;; Protocol

 (defgeneric eval-test (self)

   (:documentation "Eval a `test'."))

 (defgeneric compile-test (self &key &allow-other-keys)

   (:documentation "Compile a `test'."))

 (defgeneric locked-tests (self)

   (:documentation "Return a list of locked tests in `test-suite' object SELF."))

 (defgeneric push-test (self place)

   (:documentation

    "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE."))

 (defgeneric pop-test (self)

   (:documentation

    "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF."))

 (defgeneric push-result (self place)

   (:documentation

    "Push object SELF to the value of slot ':results' in object PLACE."))

 (defgeneric pop-result (self)

   (:documentation

    "Pop the first `test-result' from the slot-value of ':tests' from object SELF."))

 (defgeneric push-fixture (self place)

   (:documentation

    "Push object SELF to the value of slot ':results' in object PLACE."))

 (defgeneric delete-test (self &key &allow-other-keys)

   (:documentation "Delete `test' object specified by `test-object' SELF and optional keys."))

 (defgeneric find-test (self name &key &allow-other-keys)

   (:documentation "Find `test' object specified by name and optional keys."))

 (defgeneric do-test (self &optional context)

   (:documentation "Run test SELF, printing results to *standard-output*. The second

 argument is an optional fixture.

 SELF can also be a `test-suite', in which case the TESTS slot is

 queried for the value of TEST. If TEST is not provided, pops the car

 from TESTS."))

 (defgeneric do-suite (self &key &allow-other-keys)

   (:documentation

    "Perform actions on `test-suite' object SELF with optional keys."))

 ;;;; Results

 (deftype result-tag ()

   '(or (member :pass :fail :skip) null))

 (declaim (inline %make-test-result))

 (defstruct (test-result (:constructor %make-test-result)

 			(:conc-name  tr-))

   (tag nil :type result-tag :read-only t)

   (form nil :type form))

 (defmethod print-object ((self test-result) stream)

   (print-unreadable-object (self stream :identity t)

     (format stream "~A ~A" (tr-tag self) (tr-form self))))

 (defun make-test-result (tag &optional form)

   (%make-test-result :tag tag :form form))

 (defmethod test-pass-p ((res test-result))

   (when (eq :pass (tr-tag res)) t))

 (defmethod test-fail-p ((res test-result))

   (when (eq :fail (tr-tag res)) t))

 (defmethod test-skip-p ((res test-result))

   (when (eq :skip (tr-tag res)) t))

 (defmethod print-object ((self test-result) stream)

   (print-unreadable-object (self stream)

     (format stream "~A ~A"

 	    (tr-tag self)

 	    (tr-form self))))

 ;;; Objects

 (defclass test-object ()

   ((name :initarg :name :initform (required-argument) :type string :accessor test-name)

    #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean))

   (:documentation "Super class for all test-related objects."))

 (defmethod print-object ((self test-object) stream)

   "test"

   (print-unreadable-object (self stream :type t :identity t)

     (format stream "~A"

 	    (test-name self))))

 ;;;; Tests

 ;; HACK 2023-08-31: inherit sxp?

 (defclass test (test-object)

   ((fn :type symbol :accessor test-fn)

    (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench)

    (profile :type list :accessor test-profile :initform nil :initarg :profile)

    (args :type list :accessor test-args :initform nil :initarg :args)

    (declare :type list :accessor test-declare :initform nil :initarg :declare)

    (form :initarg :form :initform nil :accessor test-form)

    (doc :initarg :doc :type string :accessor test-doc)

    (lock :initarg :lock :type boolean :accessor test-lock-p)

    (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p)

    (results :initarg :results :type (array test-result) :accessor test-results))

   (:documentation "Test class typically made with `deftest'."))

 (defmethod initialize-instance ((self test) &key name)

   ;; (debug! "building test" name)

   (setf (test-fn self)