;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               simple-test.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Defines a simple test tool.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2015-03-08 <PJB> Added with-debugger-on-failure.
;;;;    2015-01-25 <PJB> Added format-control/arguments to
;;;;                     progress-failure and macros callint it.
;;;;    2010-12-14 <PJB> Created.
;;;;BUGS
;;;;
;;;;    - we should use source-form to parse lambda-list for define-test.
;;;;
;;;;LEGAL
;;;;    AGPL3
;;;;
;;;;    Copyright Pascal J. Bourguignon 2010 - 2016
;;;;
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;    GNU Affero General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
;;;;**************************************************************************
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf *readtable* (copy-readtable nil)))
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
  (:use "COMMON-LISP"
        "COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM"
        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.TIME")
  #+mocl (:shadowing-import-from "COM.INFORMATIMAGO.MOCL.KLUDGES.MISSING"
                          "*TRACE-OUTPUT*"
                          "*LOAD-VERBOSE*"
                          "*LOAD-PRINT*"
                          "ARRAY-DISPLACEMENT"
                          "CHANGE-CLASS"
                          "COMPILE"
                          "COMPLEX"
                          "ENSURE-DIRECTORIES-EXIST"
                          "FILE-WRITE-DATE"
                          "INVOKE-DEBUGGER" "*DEBUGGER-HOOK*"
                          "LOAD"
                          "LOGICAL-PATHNAME-TRANSLATIONS"
                          "MACHINE-INSTANCE"
                          "MACHINE-VERSION"
                          "NSET-DIFFERENCE"
                          "RENAME-FILE"
                          "SUBSTITUTE-IF"
                          "TRANSLATE-LOGICAL-PATHNAME")
  (:export "*DEBUG-ON-ERROR*" "WITH-DEBUGGER-ON-ERROR"
           "*DEBUG-ON-FAILURE*" "WITH-DEBUGGER-ON-FAILURE"
           "DEFINE-TEST" "CHECK" "ASSERT-TRUE" "ASSERT-FALSE" "EXPECT-CONDITION"
           "TEST-MESSAGE" "*TEST-OUTPUT*" "*VERBOSE-TALLY*"  "*VERBOSE-PROGRESS*"
           "TESTING" "SLOW-TEST"
           "PROGRESS-START"
           "PROGRESS-SUCCESS" "PROGRESS-FAILURE-MESSAGE" "PROGRESS-FAILURE"
           "PROGRESS-TALLY"
           ;; deprecated:
           "TEST")
  (:documentation "
This package defines a simple test tool.

   (define-test <test-name> (<test-arguments>)
     (check = (fact 3) 6)
     (assert-true   <expr> (<place>…) \"message ~A\" <arguments>…)
     (assert-false  <expr> (<place>…) \"message ~A\" <arguments>…)
     (if <test>
        (progress-success)
        (progress-failure-message '<expr> \"message ~A\" <arguments>…)))


Tests can be run in the scope of a WITH-DEBUGGER-ON-ERROR or a
WITH-DEBUGGER-ON-FAILURE macro, to enter the debugger when an error is
signaled during the test, or if a test fails.  This may be useful to
debug the test or the failure.

    (with-debugger-on-failure
       (test/all))

    ;; single shot testing:
    (testing
       (check = (fact 3) 6))

License:

    AGPL3

    Copyright Pascal J. Bourguignon 2010 - 2015

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU Affero General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU Affero General Public License for more details.

    You should have received a copy of the GNU Affero General Public License
    along with this program.
    If not, see <http://www.gnu.org/licenses/>
"))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST")


(defvar *debug-on-error*          nil
  "Whether an error in a test should go to the debugger.")
(defvar *debug-on-failure*        nil
  "Whether a failure in a test should go to the debugger.")
(defvar *success-count*           0
  "The total number of successful tests.")
(defvar *failure-count*           0
  "The total number of failed tests.")

(defvar *verbose-tally* t
  "Whether to print the number of successful, failed and performed tests.")
(defvar *verbose-progress* nil
  "Whether to display dots or exclamation points while testing.")

(defvar *test-output* (make-synonym-stream '*standard-output*))

;; Private:
(defvar *last-success-p*          nil)
(defvar *current-test-name*       nil)
(defvar *current-test-parameters* nil)
(defvar *current-test-printed-p*  nil)
(defvar *report-string*           "")
(defparameter *cr*                #\return)


(defun progress-start ()
  "Resets the progress counters (success/failure counts)."
  (setf *success-count*  0
        *failure-count*  0
        *last-success-p* nil
        *report-string*  (make-array 8
                                     :element-type 'character
                                     :adjustable t
                                     :fill-pointer 0))
  (values))


(defun verbose (default)
  "Returns whether the test must be verbose.
We conjoin the DEFAULT parameter with *LOAD-VERBOSE*, ASDF-VERBOSE*
and QUICKLOAD-VERBOSE* when available."
  (and default
       (or (not *load-pathname*)
           *load-verbose*
           (and (find-package "ASDF")
                (find-symbol "*ASDF-VERBOSE*" "ASDF")
                (symbol-value (find-symbol "*ASDF-VERBOSE*" "ASDF")))
           (and (find-package "QUICKLISP")
                (find-symbol "*QUICKLOAD-VERBOSE*" "QUICKLISP-CLIENT")
                (symbol-value (find-symbol "*QUICKLOAD-VERBOSE*" "QUICKLISP-CLIENT"))))))

(defun test-message (format-control &rest format-arguments)
  "Formats the parameters on the *TEST-OUTPUT* when running the test verbosely
cf. VERBOSE, *VERBOSE-PROGRESS*"
  (when (verbose t)
    (format *test-output* "~&~?~%" format-control format-arguments)
    (force-output *test-output*)))

(defun progress-report (new-last-succcess-p)
  "Prints on *TEST-OUTPUT* the current progress report."
  (setf *last-success-p* new-last-succcess-p)
  (when (verbose *verbose-progress*)
    (if *last-success-p*
        (format *test-output* "~A" (aref *report-string* (1- (length *report-string*))))
        (format *test-output* "~&~A" *report-string*))
    (force-output *test-output*))
  (values))


(defun progress-success ()
  "Indicate one more successful test."
  (incf *success-count*)
  (vector-push-extend #\. *report-string*)
  (progress-report t))


(defun current-test-identification (&optional max-length)
  "Returns the identification of the current test (over a maximum length of MAX-LENGTH)"
  (let ((*print-circle* nil))
    (if (or (null max-length) (null *current-test-parameters*))
        (format nil "(~{~S~^ ~})" (cons *current-test-name* *current-test-parameters*))
        (let* ((items (mapcar (lambda (parameter)
                                (let ((label (let ((*package* (if (and (symbolp parameter)
                                                                       (symbol-package parameter))
                                                                  (symbol-package parameter)
                                                                  *package*)))
                                               (format nil "~S" parameter))))
                                  (list (length label) label)))
                              (cons *current-test-name* *current-test-parameters*)))
               (idlength (+ 1 (length items) (reduce (function +) items :key (function first))))
               (candidates (sort (butlast (loop
                                            :for cell :on items
                                            :collect cell))
                                 (function >)
                                 :key (function caadr))))
          (loop
            :while (and candidates (< max-length idlength))
            :do (progn
                  (decf idlength (1- (caadar candidates)))
                  (setf (car (cdadar candidates)) "…")
                  (pop candidates))
            :finally (return (format nil "(~{~A~^ ~})" (mapcar (function second) items))))))))


(defun test/current-test-identification ()
  (assert (equal (let ((*current-test-name* 'hello-world)
                       (*current-test-parameters* '()))
                   (current-test-identification  nil))
                 "(hello-world)"))

  (assert (equal (let ((*current-test-name* 'hello-world)
                       (*current-test-parameters* '((1 2 3 4) "howdy doo dabadaboo" #(a b c d e f))))
                   (current-test-identification  nil))
                 "(hello-world (1 2 3 4) \"howdy doo dabadaboo\" #(a b c d e f))"))

  (assert (equal (let ((*current-test-name* 'hello-world)
                       (*current-test-parameters* '((1 2 3 4) "howdy doo dabadaboo" #(a b c d e f))))
                   (current-test-identification  1))
                 "(hello-world … … …)"))

  (assert (equal (let ((*current-test-name*  'test/non-empty-vector-with-too-little-data)
                       (*current-test-parameters* '()))
                   (current-test-identification  20))
                 "(test/non-empty-vector-with-too-little-data)"))
  :success)



(define-condition test-failure ()
  ((expression :initarg :expression
               :reader test-failure-expression)
   (message    :initarg :message
               :initform ""
               :reader test-failure-message)
   (arguments  :initarg :arguments
               :initform '()
               :reader test-failure-arguments))
  (:report (lambda (condition stream)
             (format stream "Failure on expression: ~S~%~?"
                     (test-failure-expression condition)
                     (test-failure-message condition)
                     (test-failure-arguments condition)))))




(defun progress-failure-message (expression message &rest arguments)
  "Indicates one more failed test, with a formatted MESSAGE and ARGUMENTS."
  (incf *failure-count*)
  (vector-push-extend #\! *report-string*)
  (unless *current-test-printed-p*
    (setf  *current-test-printed-p* t)
    (format *test-output* "~&~A" (current-test-identification)))
  (format *test-output* "~&Failure:     expression: ~S~@
                         ~&~?~%"
          expression message arguments)
  (force-output *test-output*)
  (progress-report nil)
  (when *debug-on-failure*
    (invoke-debugger (make-condition 'test-failure
                                     :expression expression
                                     :message message
                                     :arguments arguments))))


(defun progress-failure (compare expression expected-result result
                         &optional places format-control &rest format-arguments)
  "Indicates one more failed test, reporting the expression, the
expected and actual results, and the relevant places, in addition to a
formatted message."
  (progress-failure-message expression "~&           evaluates to: ~S~@
                                        ~&           which is not  ~A~@
                                        ~& to the expected result: ~S~@
                                        ~{~&~23A: ~S~}~@[~@
                                        ~&~?~]~&"
                            result compare expected-result places
                            format-control format-arguments))



(defun progress-tally (success-count failure-count)
  "When testing verbosely, prints the test tally, SUCCESS-COUNT and
FAILURE-COUNT."
  (when (verbose *verbose-tally*)
    (let ((name-max-length 40))
      (flet ((write-tally (name)
               (format *test-output* "~&~VA~@[~%~0@*~V<~>~3@*~]~
                       ~9D test~:*~P,~:*~[~; ~;~]~
                       ~8D success~:*~[es~;~:;es~]~
                       ~:[,~2:*~[~;  ~;~]~*~8D failure~:*~P~;~].~%"
                       name-max-length name (< name-max-length (length name))
                       (+ success-count failure-count)
                       success-count
                       (zerop failure-count)
                       failure-count)))
        (write-tally (current-test-identification name-max-length))
        (force-output *test-output*)
        ;; (let* ((test-name (current-test-identification name-max-length))
        ;;        (data (genline ""))
        ;;        (nlen (length test-name)))
        ;;   (format *test-output* "~&~A~%"
        ;;           (if (and (< nlen (+ name-max-length 4)) (char= #\space (aref data nlen)))
        ;;               (progn
        ;;                 (replace data test-name)
        ;;                 data)
        ;;               (genline (concatenate 'string (subseq test-name 0 43) "…"))))
        ;;   (force-output *test-output*))
        )))
  (values))

(defmacro assert-true (expression &optional places format-control &rest format-arguments)
  "Evaluates a test EXPRESSION and check it returns true.
EXAMPLE:  (assert-true (= 2 (+ 1 1))))
"
  (let ((vresult   (gensym "RESULT-")))
    `(let ((,vresult   (if *debug-on-error*
                           (handler-bind
                               ((error (function invoke-debugger)))
                             ,expression)
                           (handler-case
                               ,expression
                             (error (err) (list 'error (princ-to-string err)))))))
       (if ,vresult
           (progress-success)
           (progress-failure 'equivalent ',expression 't ,vresult
                             (list ,@(mapcan (lambda (place) `(',place ,place)) places))
                             ,format-control ,@format-arguments)))))


(defmacro assert-false (expression &optional places format-control &rest format-arguments)
  "Evaluates a test EXPRESSION and check it returns NIL
EXAMPLE:  (assert-false (/= 2 (+ 1 1))))
"
  `(assert-true (not ,expression) ,places ,format-control ,@format-arguments))


(defmacro expect-condition (condition-class expression)
  "Evaluates a test EXPRESSION and check that it signals a condition of the specified CONDITION-CLASS.
CONDITION-CLASS: evaluated to a class name.
EXAMPLE:        (expect-condition 'division-by-zero (/ 1 0))
"
  (let ((body (gensym))
        (vcondition-class (gensym)))
    `(let ((,vcondition-class ,condition-class))
       (flet ((,body ()
                ,expression
                (progress-failure-message ',expression
                                          "Didn't signal the expected ~S condition."
                                          ,vcondition-class)))
         (if *debug-on-error*
             (block expect
               (handler-bind
                   ((error (lambda (condition)
                             (if (typep condition ,vcondition-class)
                                 (progn
                                   (progress-success)
                                   (return-from expect))
                                 (invoke-debugger condition)))))
                 (,body)))
             (handler-case
                 (,body)
               (error (condition)
                 (if (typep condition ,vcondition-class)
                     (progress-success)
                     (progress-failure-message
                      ',expression
                      "Signaled an unexpected ~S condition instead of ~S."
                      condition
                      ,vcondition-class)))))))))


(defmacro test (compare expression expected &optional places format-control &rest format-arguments)
  "Deprecated, use CHECK instead."
  (warn "~S is deprecated, use CHECK instead." 'test)
  `(check ,compare ,expression ,expected ,places ,format-control ,@format-arguments))

(defmacro check (compare expression expected &optional places format-control &rest format-arguments)
  "Evaluates a test EXPRESSION and compare the result with EXPECTED (evaluated) using the COMPARE operator.
EXAMPLE:  (test equal (list 1 2 3) '(1 2 3))
"
  (let ((vresult   (gensym "RESULT-"))
        (vexpected (gensym "EXPECTED-")))
    `(let ((,vresult   (if *debug-on-error*
                           (handler-bind
                               ((error (function invoke-debugger)))
                             ,expression)
                           (handler-case
                               ,expression
                             (error (err) (list 'error (princ-to-string err))))))
           (,vexpected ,expected))
       (if (,compare ,vresult ,vexpected)
           (progress-success)
           (progress-failure ',compare ',expression ,vexpected ,vresult
                             (list ,@(mapcan (lambda (place) `(',place ,place)) places))
                             ,format-control
                             ,@format-arguments)))))



(defmacro testing (&body body)
  "Evaluates the body while tallying test successes and failures.

The functions PROGRESS-SUCCESS, PROGRESS-FAILURE and
PROGRESS-FAILURE-MESSAGE (eg. thru the macros ASSERT-TRUE,
ASSERT-FALSE, EXPECT-CONDITION and TEST), should only be called in the
dynamic context established by this TESTING macro.

cf. DEFINE-TEST.
"
  `(multiple-value-bind (successes failures)
       (let ((*success-count* 0)
             (*failure-count* 0)
             (*current-test-printed-p*  nil))
         (progress-start)
         (progn ,@body)
         (progress-tally *success-count* *failure-count*)
         (values *success-count* *failure-count*))
     (incf *success-count* successes)
     (incf *failure-count* failures)
     (if (zerop failures)
         :success
         :failure)))


(defmacro define-test (name parameters &body body)
  "Like DEFUN, but wraps the body in test reporting boilerplate.
cf. TESTING."
  (let ((mandatory (loop
                     :for param :in parameters
                     :until (member param lambda-list-keywords)
                     :collect param)))
    (multiple-value-bind (docstrings declarations forms) (parse-body :lambda body)
      `(defun ,name ,parameters
         ,@docstrings
         ,@declarations
         (let ((*current-test-name*        ',name)
               (*current-test-parameters* (list ,@mandatory)))
           (testing ,@forms))))))

(defmacro with-debugger-on-error (&body body)
  "When running tests in the dynamic context established by this macro,
errors will invoke the debugger instead of failing the test immediately."
  `(let ((*debug-on-error* t))
     ,@body))

(defmacro with-debugger-on-failure (&body body)
    "When running tests in the dynamic context established by this macro,
failures will invoke the debugger instead of failing the test immediately."
  `(let ((*debug-on-failure* t))
     ,@body))

(defun slow-test* (expected-time thunk)
  (let ((result))
    (test-message "Next test should take about ~A." (format-time expected-time))
    (let ((time (chrono-real-time (setf result (funcall thunk)))))
      (test-message "Test took ~A" (format-time time)))
    result))

(defmacro slow-test (expected-time &body body)
  `(slow-test* ,expected-time (lambda () ,@body)))





#|

<!-- -*- mode:xml; coding:utf-8 -*- -->

<?xml version="1.0" encoding="UTF-8"?>
<!-- a description of the JUnit XML format and how Jenkins parses it. See also junit.xsd -->

<!-- if only a single testsuite element is present, the testsuites
     element can be omitted. All attributes are optional.
     Not supported by maven surefire.
 -->
<testsuites disabled="" <!-- total number of disabled tests from all testsuites. -->
            errors=""   <!-- total number of tests with error result from all testsuites. -->
            failures="" <!-- total number of failed tests from all testsuites. -->
            name=""
            tests=""    <!-- total number of tests from all testsuites. Some software may expect to only see the number of successful tests from all testsuites though. -->
            time=""     <!-- time in seconds to execute all test suites. -->
	    >

  <!-- testsuite can appear multiple times, if contained in a testsuites element.
       It can also be the root element. -->
  <testsuite name=""      <!-- Full (class) name of the test for non-aggregated testsuite documents.
                               Class name without the package for aggregated testsuites documents. Required -->
	     tests=""     <!-- The total number of tests in the suite, required. -->
	     disabled=""  <!-- the total number of disabled tests in the suite. optional. not supported by maven surefire. -->
             errors=""    <!-- The total number of tests in the suite that errored. An errored test is one that had an unanticipated problem,
                               for example an unchecked throwable; or a problem with the implementation of the test. optional -->
             failures=""  <!-- The total number of tests in the suite that failed. A failure is a test which the code has explicitly failed
                               by using the mechanisms for that purpose. e.g., via an assertEquals. optional -->
             hostname=""  <!-- Host on which the tests were executed. 'localhost' should be used if the hostname cannot be determined. optional. not supported by maven surefire. -->
	     id=""        <!-- Starts at 0 for the first testsuite and is incremented by 1 for each following testsuite. optional. not supported by maven surefire. -->
	     package=""   <!-- Derived from testsuite/@name in the non-aggregated documents. optional. not supported by maven surefire. -->
	     skipped=""   <!-- The total number of skipped tests. optional -->
	     time=""      <!-- Time taken (in seconds) to execute the tests in the suite. optional -->
	     timestamp="" <!-- when the test was executed in ISO 8601 format (2014-01-21T16:17:18). Timezone may not be specified. optional. not supported by maven surefire. -->
	     >

    <!-- Properties (e.g., environment settings) set during test execution.
         The properties element can appear 0 or once. -->
    <properties>
      <!-- property can appear multiple times. The name and value attributres are required. -->
      <property name="" value=""/>
    </properties>

    <!-- testcase can appear multiple times, see /testsuites/testsuite@tests -->
    <testcase name=""       <!-- Name of the test method, required. -->
	      assertions="" <!-- number of assertions in the test case. optional. not supported by maven surefire. -->
	      classname=""  <!-- Full class name for the class the test method is in. required -->
	      status=""     <!-- optional. not supported by maven surefire. -->
	      time=""       <!-- Time taken (in seconds) to execute the test. optional -->
	      >

      <!-- If the test was not executed or failed, you can specify one of the skipped, error or failure elements. -->

      <!-- skipped can appear 0 or once. optional -->
      <skipped message=""   <!-- message/description string why the test case was skipped. optional -->
	  />

      <!-- error indicates that the test errored.
           An errored test had an unanticipated problem.
           For example an unchecked throwable (exception), crash or a problem with the implementation of the test.
           Contains as a text node relevant data for the error, for example a stack trace. optional -->
      <error message="" <!-- The error message. e.g., if a java exception is thrown, the return value of getMessage() -->
	     type=""    <!-- The type of error that occured. e.g., if a java execption is thrown the full class name of the exception. -->
	     >error description</error>

      <!-- failure indicates that the test failed.
           A failure is a condition which the code has explicitly failed by using the mechanisms for that purpose.
           For example via an assertEquals.
           Contains as a text node relevant data for the failure, e.g., a stack trace. optional -->
      <failure message="" <!-- The message specified in the assert. -->
	       type=""    <!-- The type of the assert. -->
	       >failure description</failure>

      <!-- Data that was written to standard out while the test was executed. optional -->
      <system-out>STDOUT text</system-out>

      <!-- Data that was written to standard error while the test was executed. optional -->
      <system-err>STDERR text</system-err>
    </testcase>

    <!-- Data that was written to standard out while the test suite was executed. optional -->
    <system-out>STDOUT text</system-out>
    <!-- Data that was written to standard error while the test suite was executed. optional -->
    <system-err>STDERR text</system-err>
  </testsuite>
</testsuites>



<testsuites id="id.of.scan" name="label of scan" tests="total-number-of-tests" failures="total-number-of-failures" time="duration">
<testsuite id="id.of.provider" name="name of provider" tests="number-of-tests" failures="number-of-failures" time="duration">
<testcase id="id.of.test" name="name of test" time="duration">
<failure message="title" type="severity"> severity = INFO WARNING ERROR
- text of the rule and severity
- analysis provider and the analysis category
- source code File:line number
</failure>
</testcase>
</testsuite>
</testsuites>



<?xml version="1.0" encoding="UTF-8" ?>
   <testsuites id="20140612_170519" name="New_configuration (14/06/12 17:05:19)" tests="225" failures="1262" time="0.001">
      <testsuite id="codereview.cobol.analysisProvider" name="COBOL Code Review" tests="45" failures="17" time="0.001">
         <testcase id="codereview.cobol.rules.ProgramIdRule" name="Use a program name that matches the source file name" time="0.001">
            <failure message="PROGRAM.cbl:2 Use a program name that matches the source file name" type="WARNING">
WARNING: Use a program name that matches the source file name
Category: COBOL Code Review – Naming Conventions
File: /project/PROGRAM.cbl
Line: 2
      </failure>
    </testcase>
  </testsuite>
</testsuites>
|#

;;;; THE END ;;;;
ViewGit