Merge commit '728a186263688293c214297cf8ea34dde8b20edb' as 'third_party/lisp/fiveam' r/396

1 files changed, 311 insertions, 0 deletions

diff --git a/third_party/lisp/fiveam/src/check.lisp b/third_party/lisp/fiveam/src/check.lisp
new file mode 100644
index 000000000000..b3808c5cf04c
--- /dev/null
+++ b/third_party/lisp/fiveam/src/check.lisp
@@ -0,0 +1,311 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Checks
+
+;;;; At the lowest level testing the system requires that certain
+;;;; forms be evaluated and that certain post conditions are met: the
+;;;; value returned must satisfy a certain predicate, the form must
+;;;; (or must not) signal a certain condition, etc. In FiveAM these
+;;;; low level operations are called 'checks' and are defined using
+;;;; the various checking macros.
+
+;;;; Checks are the basic operators for collecting results. Tests and
+;;;; test suites on the other hand allow grouping multiple checks into
+;;;; logic collections.
+
+(defvar *test-dribble* t)
+
+(defmacro with-*test-dribble* (stream &body body)
+  `(let ((*test-dribble* ,stream))
+     (declare (special *test-dribble*))
+     ,@body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-special-environment run-state ()
+    result-list
+    current-test))
+
+;;;; ** Types of test results
+
+;;;; Every check produces a result object.
+
+(defclass test-result ()
+  ((reason :accessor reason :initarg :reason :initform "no reason given")
+   (test-case :accessor test-case :initarg :test-case)
+   (test-expr :accessor test-expr :initarg :test-expr))
+  (:documentation "All checking macros will generate an object of
+ type TEST-RESULT."))
+
+(defclass test-passed (test-result)
+  ()
+  (:documentation "Class for successful checks."))
+
+(defgeneric test-passed-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-passed)) t))
+
+(define-condition check-failure (error)
+  ((reason :accessor reason :initarg :reason :initform "no reason given")
+   (test-case :accessor test-case :initarg :test-case)
+   (test-expr :accessor test-expr :initarg :test-expr))
+  (:documentation "Signaled when a check fails.")
+  (:report  (lambda (c stream)
+              (format stream "The following check failed: ~S~%~A."
+                      (test-expr c)
+                      (reason c)))))
+
+(defun process-failure (test-expr &optional reason-format &rest format-args)
+  (let ((reason (and reason-format
+                     (apply #'format nil reason-format format-args))))
+    (with-simple-restart (ignore-failure "Continue the test run.")
+      (error 'check-failure :test-expr test-expr
+                            :reason reason))
+    (add-result 'test-failure :test-expr test-expr
+                              :reason reason)))
+
+(defclass test-failure (test-result)
+  ()
+  (:documentation "Class for unsuccessful checks."))
+
+(defgeneric test-failure-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-failure)) t))
+
+(defclass unexpected-test-failure (test-failure)
+  ((actual-condition :accessor actual-condition :initarg :condition))
+  (:documentation "Represents the result of a test which neither
+passed nor failed, but signaled an error we couldn't deal
+with.
+
+Note: This is very different than a SIGNALS check which instead
+creates a TEST-PASSED or TEST-FAILURE object."))
+
+(defclass test-skipped (test-result)
+  ()
+  (:documentation "A test which was not run. Usually this is due to
+unsatisfied dependencies, but users can decide to skip the test when
+appropriate."))
+
+(defgeneric test-skipped-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-skipped)) t))
+
+(defun add-result (result-type &rest make-instance-args)
+  "Create a TEST-RESULT object of type RESULT-TYPE passing it the
+  initialize args MAKE-INSTANCE-ARGS and add the resulting
+  object to the list of test results."
+  (with-run-state (result-list current-test)
+    (let ((result (apply #'make-instance result-type
+                         (append make-instance-args (list :test-case current-test)))))
+      (etypecase result
+        (test-passed  (format *test-dribble* "."))
+        (unexpected-test-failure (format *test-dribble* "X"))
+        (test-failure (format *test-dribble* "f"))
+        (test-skipped (format *test-dribble* "s")))
+      (push result result-list))))
+
+;;;; ** The check operators
+
+;;;; *** The IS check
+
+(defmacro is (test &rest reason-args)
+  "The DWIM checking operator.
+
+If TEST returns a true value a test-passed result is generated,
+otherwise a test-failure result is generated. The reason, unless
+REASON-ARGS is provided, is generated based on the form of TEST:
+
+ (predicate expected actual) - Means that we want to check
+ whether, according to PREDICATE, the ACTUAL value is
+ in fact what we EXPECTED.
+
+ (predicate value) - Means that we want to ensure that VALUE
+ satisfies PREDICATE.
+
+ Wrapping the TEST form in a NOT simply produces a negated reason
+ string."
+  (assert (listp test)
+          (test)
+          "Argument to IS must be a list, not ~S" test)
+  (let (bindings effective-test default-reason-args)
+    (with-gensyms (e a v)
+      (flet ((process-entry (predicate expected actual &optional negatedp)
+               ;; make sure EXPECTED is holding the entry that starts with 'values
+               (when (and (consp actual)
+                          (eq (car actual) 'values))
+                 (assert (not (and (consp expected)
+                                   (eq (car expected) 'values))) ()
+                                   "Both the expected and actual part is a values expression.")
+                 (rotatef expected actual))
+               (let ((setf-forms))
+                 (if (and (consp expected)
+                          (eq (car expected) 'values))
+                     (progn
+                       (setf expected (copy-list expected))
+                       (setf setf-forms (loop for cell = (rest expected) then (cdr cell)
+                                              for i from 0
+                                              while cell
+                                              when (eq (car cell) '*)
+                                              collect `(setf (elt ,a ,i) nil)
+                                              and do (setf (car cell) nil)))
+                       (setf bindings (list (list e `(list ,@(rest expected)))
+                                            (list a `(multiple-value-list ,actual)))))
+                     (setf bindings (list (list e expected)
+                                          (list a actual))))
+                 (setf effective-test `(progn
+                                         ,@setf-forms
+                                         ,(if negatedp
+                                              `(not (,predicate ,e ,a))
+                                              `(,predicate ,e ,a)))))))
+        (list-match-case test
+          ((not (?predicate ?expected ?actual))
+           (process-entry ?predicate ?expected ?actual t)
+           (setf default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
+                       `',?actual a `',?predicate e)))
+          ((not (?satisfies ?value))
+           (setf bindings (list (list v ?value))
+                 effective-test `(not (,?satisfies ,v))
+                 default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)"
+                       `',?value v `',?satisfies)))
+          ((?predicate ?expected ?actual)
+           (process-entry ?predicate ?expected ?actual)
+           (setf default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%."
+                       `',?actual a `',?predicate e)))
+          ((?satisfies ?value)
+           (setf bindings (list (list v ?value))
+                 effective-test `(,?satisfies ,v)
+                 default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
+                       `',?value v `',?satisfies)))
+          (?_
+           (setf bindings '()
+                 effective-test test
+                 default-reason-args (list "~2&~S~2% was NIL." `',test)))))
+      `(let ,bindings
+         (if ,effective-test
+             (add-result 'test-passed :test-expr ',test)
+             (process-failure ',test
+                              ,@(or reason-args default-reason-args)))))))
+
+;;;; *** Other checks
+
+(defmacro skip (&rest reason)
+  "Generates a TEST-SKIPPED result."
+  `(progn
+     (format *test-dribble* "s")
+     (add-result 'test-skipped :reason (format nil ,@reason))))
+
+(defmacro is-every (predicate &body clauses)
+  "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
+   for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list."
+  `(progn
+     ,@(if (every #'consp clauses)
+           (loop for (expected actual . reason) in clauses
+                 collect `(is (,predicate ,expected ,actual) ,@reason))
+           (progn
+             (assert (evenp (list-length clauses)))
+             (loop for (expr value) on clauses by #'cddr
+                   collect `(is (,predicate ,expr ,value)))))))
+
+(defmacro is-true (condition &rest reason-args)
+  "Like IS this check generates a pass if CONDITION returns true
+  and a failure if CONDITION returns false. Unlike IS this check
+  does not inspect CONDITION to determine how to report the
+  failure."
+  `(if ,condition
+       (add-result 'test-passed :test-expr ',condition)
+       (process-failure ',condition
+                        ,@(or reason-args
+                              `("~S did not return a true value" ',condition)))))
+
+(defmacro is-false (condition &rest reason-args)
+  "Generates a pass if CONDITION returns false, generates a
+  failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
+  not inspect CONDITION to determine what reason to give it case
+  of test failure"
+  (with-gensyms (value)
+    `(let ((,value ,condition))
+       (if ,value
+           (process-failure ',condition
+                            ,@(or reason-args
+                                  `("~S returned the value ~S, which is true" ',condition ,value)))
+           (add-result 'test-passed :test-expr ',condition)))))
+
+(defmacro signals (condition-spec
+                   &body body)
+  "Generates a pass if BODY signals a condition of type
+CONDITION. BODY is evaluated in a block named NIL, CONDITION is
+not evaluated."
+  (let ((block-name (gensym)))
+    (destructuring-bind (condition &optional reason-control reason-args)
+        (ensure-list condition-spec)
+      `(block ,block-name
+         (handler-bind ((,condition (lambda (c)
+                                      (declare (ignore c))
+                                      ;; ok, body threw condition
+                                      (add-result 'test-passed
+                                                  :test-expr ',condition)
+                                      (return-from ,block-name t))))
+           (block nil
+             ,@body))
+         (process-failure
+           ',condition
+           ,@(if reason-control
+                 `(,reason-control ,@reason-args)
+                 `("Failed to signal a ~S" ',condition)))
+         (return-from ,block-name nil)))))
+
+(defmacro finishes (&body body)
+  "Generates a pass if BODY executes to normal completion. In
+other words if body does signal, return-from or throw this test
+fails."
+  `(unwind-protect-case () (progn ,@body)
+     (:normal (add-result 'test-passed :test-expr ',body))
+     (:abort (process-failure ',body "Test didn't finish"))))
+
+(defmacro pass (&rest message-args)
+  "Simply generate a PASS."
+  `(add-result 'test-passed
+               :test-expr ',message-args
+               ,@(when message-args
+                   `(:reason (format nil ,@message-args)))))
+
+(defmacro fail (&rest message-args)
+  "Simply generate a FAIL."
+  `(process-failure ',message-args
+                    ,@message-args))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "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 COPYRIGHT
+;; OWNER 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