+++ /dev/null
-# Boring file regexps:
-\#
-~$
-(^|/)_darcs($|/)
-\.dfsl$
-\.ppcf$
-\.fasl$
-\.x86f$
-\.fas$
-\.lib$
-^docs/html($|/)
-^docs/pdf($|/)
-^\{arch\}$
-(^|/).arch-ids($|/)
--- /dev/null
+*.fasl
+*.dx64fsl
+*~
\ No newline at end of file
-Copyright (c) 2003-2006, Edward Marco Baringer
+Copyright (c) 2012 Stelian Ionescu
+Copyright (c) 2003-2012, Edward Marco Baringer
+
All rights reserved.
Redistribution and use in source and binary forms, with or without
package :it.bese.fiveam (nicknamed 5AM).
The mailing list for FiveAM is fiveam-devel@common-lisp.net
-
-All the code is Copyright (C) 2002-2006 Edward Marco Baringer.
--- /dev/null
+(in-package :smake-user)
+
+(defvar *asciidoc-root* #P"/usr/local/etc/asciidoc/")
+
+(program "asciidoc")
+
+(defun static-file (name &optional source destination)
+
+ (cond
+ ((null source)
+ (setf source (source-pathname name)))
+ ((stringp source)
+ (setf source (source-pathname source))))
+
+ (cond
+ ((null destination)
+ (setf destination (build-pathname name)))
+ ((stringp destination)
+ (setf destination (build-pathname destination))))
+
+ (target* `(static-file ,name) ()
+ (when (file-newer-p source destination)
+ (path:cp source destination :overwrite t))))
+
+(static-file "asciidoc.css" (path:catfile *asciidoc-root* "stylesheets/" "asciidoc.css"))
+
+(static-file "asciidoc.js" (path:catfile *asciidoc-root* "javascripts/" "asciidoc.js"))
+
+(static-file "fiveam.css")
+
+(target (static-directory "asciidoc/images") ()
+ (ensure-directories-exist (build-pathname "images/icons/callouts/"))
+ (dolist (src (directory (path:catfile *asciidoc-root* "images/" "icons/" "callouts/" "*.png")))
+ (let ((dst (build-pathname (path:catfile "images/icons/callouts/" (path:basename src)))))
+ (when (file-newer-p src dst)
+ (path:cp src dst)))))
+
+(defun asciidoc.html (source &optional requires)
+ (target* `(asciidoc ,source) (:requires (append requires
+ '((program "asciidoc")
+ (static-file "asciidoc.js")
+ (static-file "asciidoc.css")
+ (static-file "fiveam.css")
+ (static-directory "asciidoc/images"))))
+ (when (file-newer-p (source-pathname source) (build-pathname source :type "html"))
+ (unless (path:-e (build-pathname source))
+ (sys `(ln -s ,(source-pathname source) ,(build-pathname source))))
+ (sys `(asciidoc -o ,(build-pathname source :type "html") ,(build-pathname source))))))
+
+(target "docstrings" ()
+ (unless (path:-d (build-pathname "docstrings/"))
+ (sys `(ccl64 --load ../extract-docstrings.lisp))
+ (sys `(rm -f ,(build-pathname "manual.html") ,(build-pathname "tutorial.html")))))
+
+(asciidoc.html "manual.txt" '("docstrings"))
+(asciidoc.html "tutorial.txt" '((asciidoc "manual.txt")))
+
+(target "documentation" (:requires '((asciidoc "manual.txt")
+ (asciidoc "tutorial.txt"))))
+
+(target "all" (:requires '("documentation")))
+
--- /dev/null
+(quicklisp:quickload :iterate)
+(quicklisp:quickload :alexandria)
+
+(defpackage :it.bese.fiveam.documentation
+ (:use :common-lisp :iterate :alexandria))
+
+(in-package :it.bese.fiveam.documentation)
+
+(quicklisp:quickload :cl-fad)
+(quicklisp:quickload :cl-ppcre)
+(quicklisp:quickload :closer-mop)
+
+(quicklisp:quickload :fiveam)
+
+(defvar *slime-root* #P"/Users/mb/m/.emacs/slime/")
+
+(load (path:catfile *slime-root* "swank.asd"))
+(asdf:load-system :swank)
+
+(ensure-directories-exist "./docstrings/")
+
+(defun symbol-name-to-pathname (symbol type)
+ (let ((name (if (symbolp symbol)
+ (symbol-name symbol)
+ (string symbol))))
+ (setf name (cl-ppcre:regex-replace-all "\\*" name "-STAR-")
+ name (cl-ppcre:regex-replace-all "\\+" name "-PLUS-")
+ name (cl-ppcre:regex-replace-all "\\~" name "-TILDE-")
+ name (cl-ppcre:regex-replace-all "\\!" name "-EPOINT-")
+ name (cl-ppcre:regex-replace-all "\\!" name "-QMARK-"))
+ (concatenate 'string
+ (ecase type (function "OP") (type "TYPE") (arglist "ARGLIST") (variable "VAR"))
+ "_"
+ name)))
+
+(defun output-docstring (name type)
+ (let ((docstring (documentation name type)))
+ (when docstring
+ (with-output-to-file (d (path:catfile "./docstrings/" (format nil "~A.txt" (symbol-name-to-pathname name type))) :if-exists :supersede)
+ (write-string docstring d)))))
+
+(iter
+ (with *package* = (find-package :fiveam))
+ (for i in-package (find-package :fiveam) external-only t)
+
+ (output-docstring i 'function)
+ (when (documentation i 'function)
+ (with-output-to-file (d (path:catfile "./docstrings/" (format nil "~A.txt" (symbol-name-to-pathname i 'arglist))))
+ (write-string (string-downcase (format nil "~A~{ __~A__~}~%~%" i (swank-backend:arglist i)))
+ d)))
+ (output-docstring i 'variable))
+
+(output-docstring '5am::test-suite 'type)
+(output-docstring '5am::testable-object 'type)
+(output-docstring '5am::test-case 'type)
--- /dev/null
+body {
+ width: 42em;
+ margin-left: auto;
+ margin-right: auto;
+ margin-top: 20px;
+}
+
+h1, h2 { width: 30em; }
\ No newline at end of file
--- /dev/null
+= FiveAM Manual =
+Marco Baringer <mb@bese.it>
+Fall/Winter 2012
+:Author Initials: MB
+:toc:
+:icons:
+:numbered:
+:website: http://common-lisp.net/project/fiveam
+:stylesheet: fiveam.css
+:linkcss:
+
+== Introduction ==
+
+=== The Super Brief Introduction ===
+
+|================================
+| (xref:OP_DEF-TEST[`def-test`] `NAME` () &body `BODY`) | define tests
+| (xref:OP_IS[`is`] (`PREDICATE` `EXPECTED` `ACTUAL`)) | check that, according to `PREDICATE` our `ACTUAL` is the same as our `EXPECTED`
+| (xref:OP_IS[`is-true`] VALUE) | check that a value is non-NIL
+| (xref:OP_RUN![`run!`] TEST-NAME) | run one (or more) tests and print the results
+|================================
+
+See the xref:API_REFERENCE[api] for details.
+
+=== An Ever So Slightly Longer Introduction ===
+
+You use define some xref:TESTS[tests] (using
+xref:OP_DEF-TEST[`def-test`]), each of which consists of some
+xref:CHECKS[checks] (with xref:OP_IS[`is`] and friends) which can pass
+or fail:
+
+--------------------------------
+(def-test a-test ()
+ (is (= 4 (+ 2 2)))
+ (is-false (= 5 (+ 2 2))))
+--------------------------------
+
+you xref:RUNNING_TESTS[run] some tests (using xref:OP_RUN[run] and
+friends) and you look at the results (using using
+xref:OP_EXPLAIN[explain]); or you do both at once (using
+xref:OP_RUN-EPOINT-[run!]):
+
+--------------------------------
+CL-USER> (run! 'a-test)
+..
+Did 2 checks.
+ Pass: 2 (100%)
+ Skip: 0 ( 0%)
+ Fail: 0 ( 0%)
+--------------------------------
+
+Lather, rinse, repeat:
+
+--------------------------------
+CL-USER> (run!)
+..
+Did 2 checks.
+ Pass: 2 (100%)
+ Skip: 0 ( 0%)
+ Fail: 0 ( 0%)
+--------------------------------
+
+=== The Real Introduction ===
+
+FiveAM is a testing framework, this is a rather vague concept, so
+before talking about how to use FiveAM it's worth knowing what task(s)
+FiveAM was built to do and, in particular, which styles of testing
+FiveAM was designed to facilitate:
+
+`test driven development`:: sometimes you know what you're trying to
+ do (lucky you) and you can figure out what your code should do
+ before you've written the code itself. The idea here is that you
+ write a bunch of tests and when all these test pass your code is
+ done.
+
+`interactive testing`:: sometimes as you're writing code you'll see
+ certain constraints that your code has to meet. For example you'll
+ realize there's a specific border case your code, which you're
+ probably not even done writing, has to deal with. In this work flow
+ you'll write code and tests more or less simultaneously and by the
+ time you're satisfied that your code does what it should you'll have
+ a set of tests which prove that it does what you think it does.
+
+`regression testing`:: sometimes you're pretty confident, just by
+ looking at the code, that your program does what it should, but you
+ want an automatic way to make sure that it continues to do what it
+ does even if (when) you change other parts of the code.
+
+[NOTE]
+There's also `beaviour driven development`. this works under
+the assumption that you can write tests in a natural-ish lanugage and
+they'll be easier to maintain than tests writen in code (have we
+learned nothing from cobol?). FiveAM does not, in its current
+implementation, support link:http://cukes.info/[cucumber] like
+behaviour driven development. patches welcome (they'll get laughed at
+at first, but they'll get applied, and then they'll get used, and then
+they'll be an essential part of fiveam itself...)
+
+==== Words ====
+
+Since there are far many more testing frameworks than there are words
+for talking about testing frameworks, the same words end up meaning
+different things in different frameworks. Just to be clear, here are
+the words fiveam uses:
+
+`check`:: a single expression which has an expected value.
+
+`test`:: a set of checks which we want to always run together.
+
+`suite`:: a group of tests we often want to run all at once.
+
+[[TESTS]]
+== Tests ==
+
+Tests are created with the xref:OP_DEF-TEST[`def-test`] macro and
+consist of:
+
+A name::
+
+Because everything deserves a name. Names in FiveAM are symbols (or
+anything that can be sensibly put in an `eql` hash table) and they are
+used both to select which test to run (as arguments to `run!` and
+family) and when reporting test failures.
+
+A body::
+
+Every test has a function which is the actual code that gets executed
+when the test is run. This code, whatever it is, will, bugs aside,
+xref:CHECKS[create a set of test result objects] (failures, successes
+and skips) and store these in a few dynamic variables (you don't need
+to worry about those).
++
+The body is actually the only real part of the test, everything else
+is administrativia. Sometimes usefel administrativia, but none the
+less overhead.
+
+A suite::
+
+Generally speaking you'll have so many tests that you'll not want to
+run them all every single time you need to run one of them (automated
+regression testing is another use case). Tests can be grouped into
+suites, and suites can also be grouped into suites, and suites have
+names, so by specfying the name of a suite we only run those tests
+that are a part of that suite.
++
+Unless otherwise specified tests add themselves to the xref:THE_CURRENT_SUITE[current suite].
+
+There are two other properties, also set via parameters to
+xref:OP_DEF-TEST[`def-test`], which influence how the tests are
+run:
+
+When to compile the test::
+
+Often enough, when working with lisp macros especially, it's useful to
+delay compilation of the test's body until the test is run. A useful
+side effect of this delay is that the code will be recompiled every
+time its run, so if the macro definition has changed that will be
+picked up at the next run of the test. While this is the default mode
+of operation for FiveAM it can be turned off and tests will be
+compiled at the 'normal' time (when the enclosing def-test form is
+compiled).
+
+Whether to run the test at all::
+
+Sometimes, but far less often than the designer of FiveAM expected,
+it's useful to run a test only when some other test passes. The
+assumption being that if the lower level tests have failed there's no
+point in cluttering up the output by running the higher level tests as
+well.
++
+YMMV. (i got really bad mileage out of this feature)
+
+[[CHECKS]]
+== Checks ==
+
+At the heart of every test is something which compares the result of
+some code to some expected value, in FiveAM these are called
+checks. All checks in FiveAM do something, exactly what depends on the
+check, and then either:
+
+. generate a "this check passed" result
+
+. generate a "this check failed" result and a corresponding failure
+ description message.
+
+. generate a "for some reason this check was skipped" result.
+
+All checks take, as an optional argument, so called "reason format
+control arguments." Should the check fail (or be skipped) these
+arguments will be passed to format, via something like `(curry
+#'format nil)`, and the result will be used as the
+explanation/description of the failure.
+
+When it comes to the actual check functions themeselves, there are
+three basic kinds:
+
+. xref:CHECKING_RETURN_VALUES[those that take a value and compare it
+to another value]
+
+. xref:CHECKING_CONTROL_FLOW[those that make sure the program's
+execution takes, or does not take, a certain path]
+
+. xref:ARBITRARY_CHECK_RESULTS[those that just force a success or
+failure to be recorded].
+
+[[CHECKING_RETURN_VALUES]]
+=== Checking return values ===
+
+xref:OP_IS[`IS`], xref:OP_IS-TRUE[`IS-TRUE`],
+xref:OP_IS[`IS-FALSE`] will take one form and compare its return
+value to some known value (the so called expected vaule) and report an
+error if these two are not equal.
+
+--------------------------------
+;; Pass if (+ 2 2) is = to 5
+(is (= 5 (+ 2 2)))
+;; Pass if (zerop 0) is not-NIL
+(is-true (zerop 0))
+;; Pass if (zerop 1) is NIL
+(is-false (zerop 1))
+--------------------------------
+
+Often enough we want to test a set of expected values against a set of
+test values using the same operator. If, for example, we were
+implementing a string formatting functions, then `IS-EVERY` provides a
+concise way to line up N different inputs along with their expected
+outputs. For example, let's say we were testing `cl:+`, we could setup
+a list of tests like this:
+
+--------------------------------
+(is-every #'= (5 (+ 2 2))
+ (0 (+ -1 1))
+ (-1 (+ -1 0))
+ (1 (+ 0 1))
+ (1 (+ 1 0)))
+--------------------------------
+
+We'd do this instead of writing out 5 seperate `IS` or `IS-TRUE`
+checks.
+
+[[CHECKING_CONTROL_FLOW]]
+=== Checking control flow ===
+
+xref:OP_SIGNALS[`SIGNALS`] and xref:OP_FINISHES[`FINISHES`] create
+pass/fail results depending on whether their body code did or did not
+terminat normally.
+
+Both of these checks assume that there is a single block of code and
+it either runs to completion or it doesn't. Sometimes though the logic
+is more complex and you can't easily represent it as a single progn
+with a flag at the end. See xref:ARBITRARY_CHECK_RESULTS[below].
+
+[[ARBITRARY_CHECK_RESULTS]]
+=== Recording arbitrary test results ===
+
+Very simply these three checks, xref:OP_PASS[`PASS`],
+xref:OP_FAIL[`FAIL`] and xref:OP_SKIP[`SKIP`] generate the specified
+result. They're intended to be used when what we're trying to test
+doesn't quite fit into any of the two preceding ways of working.
+
+== Suites ==
+
+Suites serve to group tests into managable (and runnable) chunks, they
+make it easy to have many tests defined, but only run those that
+pertain to what we're currently working on. Suites, like tests, have a
+name which can be used to retrieve the suite, and running a suite
+simply causes all of the suite's tests to be run, if the suite
+contains other suites, then those are run as well (and so on and so
+on).
+
+There is one suite that's a little special (in so far as it always
+exists), the `T` suite. If you ignore suites completely, which is a
+good idea at first or for small(ish) code bases, you're actually
+putting all your tests into the `T` suite.
+
+=== Creating Suites ===
+
+Suites, very much like tests, have a name (which is globally unique)
+which can be used to retrieve the suite (so that you can run it), and,
+most of the time, suites are part of a suite (the exception being the
+special suite `T`, which is never a part of any suite).
+
+For example these two forms will first define a suite called
+`:my-project`, then define a second suite called `:my-db-layer`, which
+is a sub suite of `:my-project` and set the current suite to
+`:my-db-layer`:
+
+--------------------------------
+(def-suite :my-project)
+
+(def-suite :my-db-layer :in :my-project)
+
+(in-suite :my-db-layer)
+--------------------------------
+
+[[THE_CURRENT_SUITE]]
+=== The Current Suite ===
+
+FiveAM also has the concept of a current suite and everytime a test is
+created it adds itself to the current suite's set of tests. The
+`IN-SUITE` macro, in a similar fashion to `IN-PACKAGE`, changes the
+current suite. Unless changed via `IN-SUITE` the current suite is the
+`T` suite.
+
+Having a default current suite allows developers to ignore suites
+completly and still have FiveAM's suite mechanism in place if they
+want to add suites in later.
+
+[[RUNNING_SUITES]]
+=== Running Suites ===
+
+When a suite is run we do nothing more than run all the tests (and any
+other suites) in the named suite. And, on one level, that's it, suites
+allow you run a whole set of tests at once just by passing in the name
+of the suite.
+
+[[SUITE_FIXTURES]]
+=== Per-suite Fixtures ===
+
+xref:FIXTURES[Fixtures] can also be associated with suite. Often
+enough when testing an external component, a database or a network
+server or something, we'll have multiple tests which all use a mock
+version of this component. It is often easier to associate the fixture
+with the suite directly than have to do this for every individual
+test. Associating a fixture to a suite doesn't change the suite at
+all, only when a test is then defined in that suite, then the fixture
+will be applied to the test's body (unless the test's own `def-test`
+form explicitly uses another fixture).
+
+[[RUNNING_TESTS]]
+== Running Tests ==
+
+The general interface is `run`, this takes a set of tests (or symbol
+that name tests or suites) and returns a list of test results (one
+element for each check that was executed). The output of `run` is,
+generally, passed to the `explain` function which, given an explainer
+object, produces some human readable text describing the test
+failures. The 99% of the time a human will be using 5am (as opposed to
+a continuous integration bot) they'll want to run the tests and
+immediately see the results with detailed failure info, this can be
+done in one step via: `run!` (see the first example).
+
+If you want to run a specific test:
+
+--------------------------------
+(run! TEST-NAME)
+--------------------------------
+
+Where `TEST-NAME` is either a test object (as returned by `get-test`)
+or a symbol naming a single test or a test suite.
+
+=== Running Tests at Test Definition Time ===
+
+Often enough, especially when fixing regression bugs, we'll always
+want to run a test right after having changed it. To facilitate this
+set the variable `*run-test-when-defined*` to T and after compiling a
+def-test form we'll call `run!` on the name of the test. For obvious
+reasons you have to set this variable manually after having loaded
+your test suite.
+
+=== Debugging failures and errors ===
+
+`*debug-on-error*`::
+
+Normally fiveam will simply capture unexpected errors, record them as
+failures, and move on to the next test (any following checks in the
+test body will not be run). However sometimes, well, all the time
+unless you're running an automated regression test, it's better to not
+capture the error but open up a debugger, set `*debug-on-error*` to
+`T` to get this effect.
+
+`*debug-on-failure*`::
+
+Normally FiveAM will simply record a check failure and move on to the
+next check, however it can be helpful to stop the check and use the
+debugger to see what the state of execution is at the time of the
+test's failure. Setting `*debug-on-failure*` to T will cause FiveAM to
+enter the debugger whenever a test check fails. Exactly what
+information is available is, obviously, implementation dependent.
+
+[[VIEWING_TEST_RESULTS]]
+== Viewing test results ==
+
+FiveAM provides two "explainers", these are classes which, given a set
+of results, produce some human readable/understandable
+output. Explainers are just normal CLOS classes (and can be easily
+subclassed) with one important method: `explain`.
+
+The `run!` and `explain!` functions use the detailed-text-explainer,
+if you want another explainer you'll have to call `run` and `explain`
+yourself:
+
+--------------------------------
+(explain (make-instance MY-EXPLAINER)
+ (run THE-TEST)
+ THE-STREAM)
+--------------------------------
+
+== Random Testing (QuickCheck) ==
+
+Sometimes it's hard to come up with edge cases for tests, or sometimes
+there are so many that it's hard to list them all one by one. Random
+testing is a way to tell the test suite how to generate input and how
+to test that certain conditions always hold. One issue when writing
+random tests is that you can't, usually, test for specific results,
+you have to test that certain relationships hold.
+
+For example, if we had a function which reverses a list, we could
+define a relationship like this:
+
+--------------------------------
+(equalp the-list (reverse (reverse the-list)))
+--------------------------------
+
+or
+
+--------------------------------
+(equalp (length the-list) (length (reverse the-list)))
+--------------------------------
+
+Random tests are defined via `def-test`, but the random part is then
+wrapped in a xref:OP_FOR-ALL[`for-all`] macro which runs its body
+`*num-trials*` times with different inputs:
+
+--------------------------------
+(for-all ((the-list (gen-list :length (gen-integer :min 0 :max 37)
+ :elements (gen-integer :min -10 :max 10))))
+ (is (equalp a (reverse (reverse the-list))))
+ (is (= (length the-list) (length (reverse the-list)))))
+--------------------------------
+
+== Fixtures ==
+
+Fixtures are, much like macros, ways to hide common code so that the
+essential functionality we're trying to test is easier to see. Unlike
+normal macros fixtures are not allowed to inspect the source code of
+their arguments, all they can really do is wrap one form (or multiple
+forms in a progn) in something else.
+
+[NOTE]
+Fixtures exist for the common case where we want to bind some
+variables to some mock (or test) values and run our test in this
+state. If anything more complicated than this is neccessary just use a
+normal macro.
+
+Fixtures are defined via the `def-fixture` macro and used either with
+`with-fixture` directory or, more commonly, using the `:fixture`
+argument to `def-test` or `def-suite`. A common example of a fixture
+would be this:
+
+--------------------------------
+(def-fixture mock-db ()
+ (let ((*database* (make-instance 'mock-db))
+ (*connection* (make-instance 'mock-connection)))
+ (unwind-protect
+ (&body) <1>
+ (mock-close-connection *connection*))))
+
+(with-fixture mock-db ()
+ (is-true (database-p *database*)))
+
+<1> This is a local macro named 5AM:&BODY (the user of def-fixture can
+not change this name)
+
+--------------------------------
+
+The body of the `def-fixture` has one local function (actually a local
+macro) called `&body` which will expand into whatever the body passed
+to `with-fixture` is. `def-fixture` also has an argument list, but
+there are two things to note: 1) in practice it's rarely used; 2)
+these are arguments will be bound to values (like defun) and not
+source code (like defmacro).
+
+[[API_REFERENCE]]
+== API Reference ==
+
+[[OP_DEF-TEST]]
+=== DEF-TEST ===
+
+================================
+--------------------------------
+(def-test NAME (&key DEPENDS-ON SUITE FIXTURE COMPILE-AT PROFILE) &body BODY)
+--------------------------------
+
+include::docstrings/OP_DEF-TEST.txt[]
+================================
+
+[[OP_DEF-SUITE]]
+=== DEF-SUITE ===
+
+================================
+----
+(def-suite NAME &key DESCRIPTION IN FIXTURE)
+----
+
+include::docstrings/OP_DEF-SUITE.txt[]
+================================
+
+[[OP_IN-SUITE]]
+[[OP_IN-SUITE-STAR-]]
+=== IN-SUITE ===
+
+================================
+----
+(in-suite NAME)
+----
+
+include::docstrings/OP_IN-SUITE.txt[]
+================================
+
+[[OP_IS]]
+=== IS ===
+
+================================
+----
+(is (PREDICATE EXPECTED ACTUAL) &rest REASON-ARGS)
+
+(is (PREDICATE ACTUAL) &rest REASON-ARGS)
+----
+
+include::docstrings/OP_IS.txt[]
+================================
+
+[[OP_IS-TRUE]]
+[[OP_IS-FALSE]]
+=== IS-TRUE / IS-FALSE / IS-EVERY ===
+
+================================
+----
+(is-true CONDITION &rest reason)
+----
+
+include::docstrings/OP_IS-TRUE.txt[]
+================================
+
+================================
+----
+(is-false CONDITION &rest reason)
+----
+
+include::docstrings/OP_IS-FALSE.txt[]
+================================
+
+////////////////////////////////
+//// the actual doc string of talks about functionality i don't want
+//// to publises (since it's just weird). se we use our own here
+////////////////////////////////
+================================
+----
+(is-every predicate &rest (EXPECTED ACTUAL &rest REASON))
+----
+
+Designed for those cases where you have a large set of expected/actual
+pairs that must be compared using the same predicate function.
+
+Expands into:
+
+----
+(progn
+ (is (,PREDICATE ,EXPECTED ,ACTUAL) ,@REASON)
+ ...
+----
+
+for each argument.
+================================
+
+[[OP_SIGNALS]]
+[[OP_FINISHES]]
+=== SIGNALS / FINISHES ===
+
+================================
+----
+(signals CONDITION &body body)
+----
+
+include::docstrings/OP_SIGNALS.txt[]
+================================
+
+================================
+----
+(finishes &body body)
+----
+
+include::docstrings/OP_FINISHES.txt[]
+================================
+
+[[OP_PASS]]
+[[OP_FAIL]]
+[[OP_SKIP]]
+=== PASS / FAIL / SKIP ===
+
+================================
+----
+(skip &rest REASON-ARGS)
+----
+
+include::docstrings/OP_SKIP.txt[]
+================================
+
+================================
+----
+(pass &rest REASON-ARGS)
+----
+
+include::docstrings/OP_PASS.txt[]
+================================
+
+================================
+----
+(fail &rest REASON-ARGS)
+----
+
+include::docstrings/OP_FAIL.txt[]
+================================
+
+[[OP_-EPOINT-]]
+[[OP_-EPOINT--EPOINT-]]
+[[OP_-EPOINT--EPOINT--EPOINT-]]
+
+[[OP_RUN-EPOINT-]]
+[[OP_EXPLAIN-EPOINT-]]
+[[OP_DEBUG-EPOINT-]]
+=== RUN! / EXPLAIN! / DEBUG! ===
+
+================================
+----
+(run! &optional TEST-NAME)
+----
+
+include::docstrings/OP_RUN-EPOINT-.txt[]
+================================
+
+================================
+----
+(explain! RESULT-LIST)
+----
+
+include::docstrings/OP_EXPLAIN-EPOINT-.txt[]
+================================
+
+================================
+----
+(debug! TEST-NAME)
+----
+
+include::docstrings/OP_DEBUG-EPOINT-.txt[]
+================================
+
+[[OP_RUN]]
+=== RUN ===
+
+================================
+----
+(run TEST-SPEC)
+----
+
+include::docstrings/OP_RUN.txt[]
+================================
+
+[[OP_DEF-FIXTURE]]
+=== DEF-FIXTURE ===
+
+================================
+----
+(def-fixture (NAME (&rest ARGS) &body BODY)
+----
+
+include::docstrings/OP_DEF-FIXTURE.txt[]
+================================
+
+[[OP_WITH-FIXTURE]]
+=== WITH-FIXTURE ===
+
+================================
+----
+(with-fixture NAME (&rest ARGS) &body BODY)
+----
+
+include::docstrings/OP_WITH-FIXTURE.txt[]
+================================
+
+[[OP_FOR-ALL]]
+=== FOR-ALL ===
+
+================================
+--------------------------------
+(for-all (&rest (NAME VALUE &optional GUARD))
+ &body body)
+--------------------------------
+
+include::docstrings/OP_FOR-ALL.txt[]
+================================
+
+[[VAR_-STAR-NUM-TRIALS-STAR-]]
+[[VAR_-STAR-MAX-TRIALS-STAR-]]
+=== \*NUM-TRIALS* / \*MAX-TRIALS* ===
+
+================================
+----
+*num-trials*
+----
+
+include::docstrings/VAR_-STAR-NUM-TRIALS-STAR-.txt[]
+================================
+
+================================
+----
+*max-trials*
+----
+
+include::docstrings/VAR_-STAR-MAX-TRIALS-STAR-.txt[]
+================================
+
+[[OP_GEN-INTEGER]]
+[[OP_GEN-FLOAT]]
+=== GEN-INTEGER / GEN-FLOAT ===
+
+================================
+----
+(gen-integer &key MIN MAX)
+----
+
+include::docstrings/OP_GEN-INTEGER.txt[]
+================================
+
+================================
+----
+(gen-float &key BOUND TYPE MIN MAX)
+----
+
+include::docstrings/OP_GEN-FLOAT.txt[]
+================================
+
+[[OP_GEN-CHARACTER]]
+[[OP_GEN-STRING]]
+=== GEN-CHARACTER / GEN-STRING ===
+
+================================
+----
+(gen-character &key CODE-LIMIT CODE ALPHANUMERICP)
+----
+
+include::docstrings/OP_GEN-CHARACTER.txt[]
+================================
+
+================================
+----
+(gen-string &key LENGTH ELEMENTS)
+----
+
+include::docstrings/OP_GEN-STRING.txt[]
+================================
+
+[[OP_GEN-BUFFER]]
+=== GEN-BUFFER ===
+
+================================
+----
+(gen-buffer &key LENGTH ELEMENTS ELEMENT-TYPE)
+----
+
+include::docstrings/OP_GEN-STRING.txt[]
+================================
+
+[[OP_GEN-LIST]]
+[[OP_GEN-TREE]]
+=== GEN-LIST / GEN-TREE ===
+
+================================
+----
+(gen-list &key LENGTH ELEMENTS)
+----
+
+include::docstrings/OP_GEN-LIST.txt[]
+================================
+
+================================
+
+----
+(gen-tree &key SIZE ELEMENTS)
+----
+
+include::docstrings/OP_GEN-TREE.txt[]
+================================
+
+[[OP_GEN-ONE-ELEMENT]]
+=== GEN-ONE-ELEMENT ===
+
+================================
+----
+(gen-one-element &rest ELEMENTS)
+----
+
+include::docstrings/OP_GEN-ONE-ELEMENT.txt[]
+================================
+
+
+
+////////////////////////////////
+
+////////////////////////////////
--- /dev/null
+= FiveAM Tutorial =
+Marco Baringer <mb@bese.it>
+Fall/Winter 2012
+:Author Initials: MB
+:toc:
+:icons:
+:numbered:
+:website: http://common-lisp.net/project/fiveam
+:stylesheet: fiveam.css
+:linkcss:
+
+== Setup ==
+
+Before we even start, we'll need to load FiveAM itself:
+
+--------------------------------
+CL-USER> (quicklisp:quickload :fiveam)
+To load "fiveam":
+ Load 1 ASDF system:
+ fiveam
+; Loading "fiveam"
+
+(:FIVEAM)
+CL-USER> (use-package :5am)
+T
+--------------------------------
+
+== Failure For Beginners ==
+
+Now, this is a tutorial to the testing framework FiveAM. Over the
+course of this tutorial we're going to test an implementation of
+link:https://en.wikipedia.org/wiki/Peano_axioms[peano numbers]
+(basically, pretend that lisp didn't have integers or arithmetic built
+in and we wanted to add it in the least efficent way possible). The
+first thing we need is the constant `0`, a function `zero-p` for
+testing if a number is zero, and function `succ` which, given a number
+`N`, returns its successor (in other words `N + 1`).
+
+It's still not totally clear to me what the `succ` function should
+look like, but the `zero` and `zero-p` functions are easy enough, so
+let's define a test for those two funtions. We'll start by testing
+`zero` as much as we can:
+
+--------------------------------
+(def-test zero ()
+ (finishes (zero)))
+--------------------------------
+
+[NOTE]
+ignore the second argument to def-test for now. if it helps pretend it's filler to make the identation look better.
+
+Since we don't know, nor really care at this stage, what the function
+`zero` returns, we simply use the
+link:manual.html#FUNCTION_FINISHES[`FINISHES`] macro to make sure that
+the function does in fact return (as opposed to signaling some weird
+error). Our `zero-p` test, on the other hand, does actually have
+something we can test. Whatever is returned by `zero` should be
+`zero-p`:
+
+--------------------------------
+(def-test zero-p ()
+ (is-true (zero-p (zero))))
+--------------------------------
+
+Finally, let's run our tests:
+
+--------------------------------
+CL-USER> (run!)
+XXf
+ Did 2 checks.
+ Pass: 0 ( 0%)
+ Skip: 0 ( 0%)
+ Fail: 2 (100%)
+
+ Failure Details:
+ --------------------------------
+ ZERO []:
+ Unexpected Error: #<UNDEFINED-FUNCTION ZERO {10058AD6F3}>
+The function COMMON-LISP-USER::ZERO is undefined..
+ --------------------------------
+ --------------------------------
+ ZERO-P []:
+ Unexpected Error: #<UNDEFINED-FUNCTION ZERO {10056FE5A3}>
+The function COMMON-LISP-USER::ZERO is undefined..
+ --------------------------------
+
+--------------------------------
+
+so, 100% failure rate, and even an Unexpected error...that's bad, but
+it's also what we should have been expecting given that we haven't
+actually defined `zero-p` or `zero`. So, let's define those two
+functions:
+
+--------------------------------
+CL-USER> (defun zero () 'zero)
+ZERO
+CL-USER> (defun zero-p (value) (eql 'zero value))
+ZERO-P
+--------------------------------
+
+Now let's run our test again:
+
+--------------------------------
+CL-USER> (run!)
+..
+ Did 2 checks.
+ Pass: 2 (100%)
+ Skip: 0 ( 0%)
+ Fail: 0 ( 0%)
+--------------------------------
+
+Much better.
+
+[NOTE]
+TEST ALL THE THINGS!
+.
+There's actually a bit of work being done with suites and default
+tests and stuff in order to make that `run!` call do what it just did
+(call our previously defined tests). If you never create a suite on
+your own then you can think of `run!` as being the 'run every test'
+function, if you start creating your own suites (and you will
+eventually), then you'll want to know that run's second, optional,
+argument is the name of a test or suite to run, but until then just go
+with `(run!)`.
+
+== More code ==
+
+So, we have zero, and we can test for zero ness, wouldn't it be nice
+to have the number one too? How about the number two? how about a
+billion? I like the number 1 billion. Now, since we thoroughly read
+through the wiki page on peano numbers we now that there's a function,
+called `succ` which, give one number returns the "next" one. In this
+implementation we're going to represent numbers as nested lists, so
+our `succ` function just wraps its input in another cons cell:
+
+--------------------------------
+(defun succ (number)
+ (cons number nil))
+--------------------------------
+
+Easy enough. That could also be right, it could also be wrong too, we
+don't really have a way to check (yet). We do know one thing though,
+the `succ` of any number (even zero) isn't zero. So let's redefine our
+zero test to check that zero plus one isn't zero:
+
+--------------------------------
+(def-test zero-p ()
+ (is-true (zero-p (zero)))
+ (is-false (zero-p (succ (zero)))))
+--------------------------------
+
+and let's run the test:
+
+--------------------------------
+CL-USER> (run!)
+...
+ Did 3 checks.
+ Pass: 3 (100%)
+ Skip: 0 ( 0%)
+ Fail: 0 ( 0%)
+--------------------------------
+
+Nice!
+
+== Elementary, my dear watson. Run the test. ==
+
+When working interactively like this, we almost always define a
+test and then immediately run it, we can tell fiveam to do that
+automatically by setting `*run-test-when-defined*` to T:
+
+--------------------------------
+CL-USER> (setf *run-test-when-defined* t)
+T
+--------------------------------
+
+Now if we were to redefine (either via the repl as I'm doing here or
+via C-cC-c in a slime buffer), we'll see:
+
+--------------------------------
+CL-USER> (def-test zero-p ()
+ (is-true (zero-p (zero)))
+ (is-false (zero-p (plus-one (zero)))))
+..
+ Did 2 checks.
+ Pass: 2 (100%)
+ Skip: 0 ( 0%)
+ Fail: 0 ( 0%)
+ZERO-P
+--------------------------------
+
+Great, at this point it's time we add a function for testing integer
+equality (in other words, `cl:=`). Let's try with this:
+
+--------------------------------
+CL-USER> (defun equiv (a b)
+ (and (zero-p a) (zero-p b)))
+EQUIV
+--------------------------------
+
+[NOTE]
+Since i'm doing everything in the package common-lisp-user i
+couldn't use the name `=` (or even `equal`). I don't want to talk
+about packages at this point, so we'll just have to live with `equiv`
+for now.
+
+And let's test it:
+
+--------------------------------
+CL-USER> (def-test equiv () (equiv (zero) (zero)))
+ Didn't run anything...huh?
+EQUIV
+--------------------------------
+
+Well, that's not what I was expecting. I'd forgotten that FiveAM,
+unlike other test frameworks, doesn't actually look at the return
+value of the function, it only runs its so called checks (one of which
+is the `is-true` function we've been using so far). So let's add that
+in and try again:
+
+--------------------------------
+CL-USER> (def-test equiv ()
+ (is-true (equiv (zero) (zero))))
+.
+ Did 1 check.
+ Pass: 1 (100%)
+ Skip: 0 ( 0%)
+ Fail: 0 ( 0%)
+
+EQUIV
+--------------------------------
+
+== Failing, but gently. ==
+
+Nice, now, finally, we can test that 1 is equal to 1 (or, in our
+implementation, the successor of zero is equal to the successor of
+zero):
+
+--------------------------------
+CL-USER> (def-test equiv ()
+ (is-true (equiv (zero) (zero)))
+ (is-true (equiv (succ (zero)) (succ (zero)))))
+.f
+ Did 2 checks.
+ Pass: 1 (50%)
+ Skip: 0 ( 0%)
+ Fail: 1 (50%)
+
+ Failure Details:
+ --------------------------------
+ EQUIV []:
+ (EQUIV (SUCC (ZERO)) (SUCC (ZERO))) did not return a true value
+ --------------------------------
+
+EQUIV
+--------------------------------
+
+Oh, cry, baby cry. The important part of that output is this line:
+
+--------------------------------
+ EQUIV []:
+ (EQUIV (SUCC (ZERO)) (SUCC (ZERO))) did not return a true value
+--------------------------------
+
+That means that, in the test `EQUIV` the form `(EQUIV (SUCC (ZERO))
+(SUCC (ZERO)))` evaluated to NIL. I wonder why? It'd be nice to see
+what the values evaluated to, what the actual arguments and return
+value of `EQUIV` was. There are two things we could do at this point:
+
+. Set 5am:*debug-on-failure* to `T` and re-run the test and dig around
+ in the backtrace for the info we need.
+
+. Use the `IS` check macro to get a more informative message in the
+ output.
+
+In practice you'll end up using a combination of both (though i prefer
+that tests run to completion without hitting the debugger, and this
+may have influenced fiveam a bit, but others prefer working with live
+data in a debugger window and that's an equally valid approach).
+
+== Tell me what I need to know ==
+
+However, since this a non-interactive static file, and debuggers are
+really interactive and implementation specific, I'm going to go with
+the second option for now, here's the same test using the `IS` check
+instead of `IS-TRUE`:
+
+--------------------------------
+CL-USER> (def-test equiv ()
+ (is (equiv (zero) (zero)))
+ (is (equiv (succ (zero)) (succ (zero)))))
+.f
+ Did 2 checks.
+ Pass: 1 (50%)
+ Skip: 0 ( 0%)
+ Fail: 1 (50%)
+
+ Failure Details:
+ --------------------------------
+ EQUIV []:
+
+(SUCC (ZERO)) <1>
+
+ evaluated to
+
+(ZERO) <2>
+
+ which is not
+
+EQUIV <3>
+
+ to
+
+(ZERO) <4>
+
+ --------------------------------
+
+EQUIV
+
+<1> actual value's source code
+<2> actual value's value
+<3> comparison operator
+<4> expected value
+--------------------------------
+
+I need to mention something at this point: the `IS-TRUE` and `IS`
+macro do not do anything different at run time. They both have some
+code, which they run, and if the result is NIL they record a failure
+and if not they record a success (which 5am calls a pass). The only
+difference is in how they report a failure: The `IS-TRUE` function
+just stores the source form and prints that back, the `IS` macro
+assumes that the form has a specific format:
+
+ (TEST-FUNCTION EXPECTED-VALUE ACTUAL-VALUE)
+
+and generates a failure message based on that. In this case we
+evaluated `(succ (zero))`, and got `(zero)`, and passed this value,
+along with the result of the expected value (`(succ (zero))`) to
+`equiv` and got `NIL`.
+
+Now, back to our test, it's actually pretty obvious that our current
+implementation of equiv:
+
+--------------------------------
+(defun equiv (a b)
+ (and (zero-p a) (zero-p b)))
+--------------------------------
+
+is buggy, so let's fix and run the test again:
+
+--------------------------------
+CL-USER> (defun equiv (a b)
+ (if (and (zero-p a) (zero-p b))
+ t
+ (equiv (car a) (car b))))
+EQUIV
+CL-USER> (!)
+..
+ Did 2 checks.
+ Pass: 2 (100%)
+ Skip: 0 ( 0%)
+ Fail: 0 ( 0%)
+
+NIL
+--------------------------------
+
+== Again, from the top ==
+
+Great, our tests passed. You'll notice though that this time we used
+the `!` function instead of `run!`.
+
+== Birds of a feather flock together. Horses of a different color stay home. ==
+
+So far we've always defined and run single tests, while it's certainly
+possible to continue this way it gets unweidly pretty quickly.
+
(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))
+ (test-expr :accessor test-expr :initarg :test-expr)
+ (test-case :accessor test-case
+ :initarg :test-case
+ :initform (with-run-state (current-test)
+ current-test)))
(:documentation "All checking macros will generate an object of
- type TEST-RESULT."))
+type TEST-RESULT."))
+
+(defgeneric test-result-p (object)
+ (:method ((o test-result)) t)
+ (:method ((o t)) nil))
(defclass test-passed (test-result)
()
(:method ((o t)) nil)
(:method ((o test-passed)) t))
+;; if a condition could inhert from a class we could avoid duplicating
+;; these slot definitions...
+
(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))
+ ((failure :accessor failure :initarg :failure)
+ (test-expr :accessor test-expr :initarg :test-expr)
+ (test-case :accessor test-case
+ :initarg :test-case
+ :initform (with-run-state (current-test)
+ current-test)))
(:documentation "Signaled when a check fails.")
(:report (lambda (c stream)
(format stream "The following check failed: ~S~%~A."
- (test-expr c)
- (reason c)))))
+ (test-expr (failure c))
+ (reason (failure c))))))
-(defmacro process-failure (&rest args)
- `(progn
- (with-simple-restart (ignore-failure "Continue the test run.")
- (error 'check-failure ,@args))
- (add-result 'test-failure ,@args)))
+(defun process-failure (failure-object)
+ (restartable-check-failure failure-object)
+ (add-result failure-object))
+
+(defun restartable-check-failure (failure)
+ (with-simple-restart (ignore-failure "Continue the test run.")
+ (error 'check-failure :failure failure)))
(defclass test-failure (test-result)
()
(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 adds 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)))))
+initialize args MAKE-INSTANCE-ARGS and adds the resulting object to
+the list of test results.
+
+If RESULT-TYPE is already a TEST-RESULT object it is used as is and
+the MAKE-INSTANCE-ARGS are ignored."
+ (with-run-state (result-list)
+ (let ((result (if (test-result-p result-type)
+ result-type
+ (apply #'make-instance result-type make-instance-args))))
(etypecase result
(test-passed (format *test-dribble* "."))
(unexpected-test-failure (format *test-dribble* "X"))
;;;; *** The IS check
+(defun parse-dwim-is-arguments (form)
+ (destructuring-bind (test &optional reason-string &rest reason-args)
+ form
+ (let ((reason-form (if reason-string
+ `(:reason (format nil ,reason-string ,@reason-args))
+ nil))
+ (expected-value (gensym))
+ (actual-value (gensym)))
+ (flet ((make-failure-instance (type &key predicate expected actual condition)
+ (values `(make-instance ',type
+ ,@reason-form
+ :predicate ',predicate
+ :test-expr ',test
+ ,@(when expected
+ `(:expected-form ',expected :expected-value ,expected-value))
+ ,@(when actual
+ `(:actual-form ',actual :actual-value ,actual-value)))
+ (append (when expected
+ `((,expected-value ,expected)))
+ (when actual
+ `((,actual-value ,actual))))
+ condition)))
+ (list-match-case test
+ ((not (?predicate ?expected ?actual))
+
+ (make-failure-instance 'is-negated-binary-failure
+ :predicate ?predicate
+ :expected ?expected
+ :actual ?actual
+
+ :condition `(not (,?predicate ,expected-value ,actual-value))))
+
+ ((not (?predicate ?expected))
+
+ (make-failure-instance 'is-negated-unary-failure
+ :predicate ?predicate
+ :expected ?expected
+ :condition `(not (,?predicate ,expected-value))))
+
+ ((?predicate ?expected ?actual)
+
+ (make-failure-instance 'is-binary-failure
+ :predicate ?predicate
+ :expected ?expected
+ :actual ?actual
+ :condition `(,?predicate ,expected-value ,actual-value)))
+ ((?predicate ?expected)
+
+ (make-failure-instance 'is-unary-failure
+ :predicate ?predicate
+ :expected ?expected
+ :condition `(,?predicate ,expected-value)))
+ (_
+ (values `(make-instance 'test-failure ,@reason-form)
+ '()
+ test)))))))
+
(defmacro is (test &rest reason-args)
"The DWIM checking operator.
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 expected actual)`::
+
+Means that we want to check whether, according to PREDICATE, the
+ACTUAL value is in fact what we EXPECTED.
+
+`(predicate value)`::
- (predicate value) - Means that we want to ensure that VALUE
- satisfies PREDICATE.
+Means that we want to ensure that VALUE satisfies PREDICATE.
- Wrapping the TEST form in a NOT simply produces a negated reason
- string."
+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 :reason (format nil ,@(or reason-args default-reason-args))
- :test-expr ',test))))))
+ (multiple-value-bind (make-failure-form bindings predicate)
+ (parse-dwim-is-arguments (list* test reason-args))
+ `(let ,bindings
+ (if ,predicate
+ (add-result 'test-passed :test-expr ',test)
+ (process-failure ,make-failure-form)))))
+
+(defclass is-failure-mixin ()
+ ((predicate :initarg :predicate :accessor predicate)
+ (expected-value :initarg :expected-value :accessor expected-value)
+ (expected-form :initarg :expected-form :accessor expected-form)))
+
+(defclass is-binary-failure-mixin (is-failure-mixin)
+ ((actual-form :initarg :actual-form :accessor actual-form)
+ (actual-value :initarg :actual-value :accessor actual-value)))
+
+(defclass is-failure (test-failure)
+ ((reason :initform nil :initarg :reason)))
+
+(defmethod reason :around ((result is-failure))
+ (or (slot-value result 'reason)
+ (call-next-method)))
+
+(defclass is-binary-failure (is-failure is-binary-failure-mixin)
+ ())
+
+(defmethod reason ((result is-binary-failure))
+ (format nil
+ "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
+ (actual-form result)
+ (actual-value result)
+ (predicate result)
+ (expected-value result)))
+
+(defclass is-negated-binary-failure (is-failure is-binary-failure-mixin)
+ ())
+
+(defmethod reason ((result is-binary-failure))
+ (format nil
+ "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2%to ~2&~S~2% (it should be)"
+ (actual-form result)
+ (actual-value result)
+ (predicate result)
+ (expected-value result)))
+
+(defclass is-unary-failure (is-failure is-failure-mixin)
+ ())
+
+(defmethod reason ((result is-unary-failure))
+ (format nil
+ "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)"
+ (expected-form result)
+ (expected-value result)
+ (predicate result)))
+
+(defclass is-negated-unary-failure (is-failure is-failure-mixin)
+ ())
+
+(defmethod reason ((result is-negated-unary-failure))
+ (format nil
+ "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
+ (expected-form result)
+ (expected-value result)
+ (predicate result)))
;;;; *** 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."
+ "Tests that all the elements of CLAUSES are equal, according to PREDICATE.
+
+If every element of CLAUSES is a cons we assume the `first` of each
+element is the expected value, and the `second` of each element is the
+actual value and generate a call to `IS` accordingly.
+
+If not every element of CLAUSES is a cons then we assume that each
+element is a value to pass to predicate (the 1 argument form of `IS`)"
`(progn
,@(if (every #'consp clauses)
(loop for (expected actual . reason) in clauses
`(if ,condition
(add-result 'test-passed :test-expr ',condition)
(process-failure
- :reason ,(if reason-args
- `(format nil ,@reason-args)
- `(format nil "~S did not return a true value" ',condition))
- :test-expr ',condition)))
+ (make-instance 'test-failure
+ :reason ,(if reason-args
+ `(format nil ,@reason-args)
+ `(format nil "~S did not return a true value" ',condition))
+ :test-expr ',condition))))
(defmacro is-false (condition &rest reason-args)
"Generates a pass if CONDITION returns false, generates a
`(let ((,value ,condition))
(if ,value
(process-failure
- :reason ,(if reason-args
- `(format nil ,@reason-args)
- `(format nil "~S returned the value ~S, which is true" ',condition ,value ))
- :test-expr ',condition)
+ (make-instance 'test-failure
+ :reason ,(if reason-args
+ `(format nil ,@reason-args)
+ `(format nil "~S returned the value ~S, which is true" ',condition ,value ))
+ :test-expr ',condition))
(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."
+ "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 nil
,@body))
(process-failure
- :reason ,(if reason-control
- `(format nil ,reason-control ,@reason-args)
- `(format nil "Failed to signal a ~S" ',condition))
- :test-expr ',condition)
+ (make-instance 'test-failure
+ :reason ,(if reason-control
+ `(format nil ,reason-control ,@reason-args)
+ `(format nil "Failed to signal a ~S" ',condition))
+ :test-expr ',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."
+ "Generates a pass if BODY executes to normal completion.
+
+In other words if body signals a condition (which is then handled),
+return-froms or throws this test fails."
`(let ((ok nil))
(unwind-protect
(progn
(if ok
(add-result 'test-passed :test-expr ',body)
(process-failure
- :reason (format nil "Test didn't finish")
- :test-expr ',body)))))
+ (make-instance 'test-failure
+ :reason (format nil "Test didn't finish")
+ :test-expr ',body))))))
(defmacro pass (&rest message-args)
- "Simply generate a PASS."
+ "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."
+ "Generate a FAIL."
`(process-failure
- :test-expr ',message-args
- ,@(when message-args
- `(:reason (format nil ,@message-args)))))
+ (make-instance 'test-failure
+ :test-expr ',message-args
+ ,@(when message-args
+ `(:reason (format nil ,@message-args))))))
+
+(defmacro skip (&rest message-args)
+ "Generates a SKIP result."
+ `(progn
+ (format *test-dribble* "s")
+ (add-result 'test-skipped :reason (format nil ,@message-args))))
;; Copyright (c) 2002-2003, Edward Marco Baringer
;; All rights reserved.
information will be collected when the
test is run.")))
+(defgeneric testable-object-p (object)
+ (:method ((object testable-object)) t)
+ (:method ((object t)) nil))
+
(defmethod print-object ((test testable-object) stream)
(print-unreadable-object (test stream :type t :identity t)
(format stream "~S" (name test))))
((tests :accessor tests :initform (make-hash-table :test 'eql)
:documentation "The hash table mapping names to test
objects in this suite. The values in this hash table
- can be either test-cases or other test-suites."))
+ can be either test-cases or other test-suites.")
+ (fixture :accessor fixture :initform nil :initarg :fixture
+ :documentation "FIXTURE to use, by default, for tests in
+ this suite."))
(:documentation "A test suite is a collection of tests or test suites.
Test suites serve to organize tests into groups so that the
((test-lambda :initarg :test-lambda :accessor test-lambda
:documentation "The function to run.")
(runtime-package :initarg :runtime-package :accessor runtime-package
- :documentation "By default it stores *package* from the time this test was defined (macroexpanded)."))
+ :documentation "By default it stores *package*
+ from the time this test was
+ defined (macroexpanded)."))
(:documentation "A test case is a single, named, collection of
checks.
(remhash key *fixture*))
(defmacro def-fixture (name (&rest args) &body body)
- "Defines a fixture named NAME. A fixture is very much like a
-macro but is used only for simple templating. A fixture created
-with DEF-FIXTURE is a macro which can use the special macrolet
-&BODY to specify where the body should go.
+ "Defines a fixture named NAME. At \"evaluation time\" (not macro
+expansion time) `BODY` will be run, however `BODY` can call the local
+macro `&body` which will expand to the body passed to the
+`with-fixture` call.
-See Also: WITH-FIXTURE
-"
+See Also: `WITH-FIXTURE`"
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get-fixture ',name) (cons ',args ',body))
',name))
(defmacro with-fixture (fixture-name (&rest args) &body body)
- "Insert BODY into the fixture named FIXTURE-NAME.
+ "Lookup a fixture named `NAME` (at macro expansion time),
+replace the fixture's `&body` with `BODY` and compile the resulting
+form.
-See Also: DEF-FIXTURE"
+See Also: `DEF-FIXTURE`"
(assert (get-fixture fixture-name)
(fixture-name)
"Unknown fixture ~S." fixture-name)
#:fail
#:*test-dribble*
#:for-all
+ #:*num-trials*
+ #:*max-trials*
#:gen-integer
#:gen-float
#:gen-character
;; running tests
#:run
#:run-all-tests
+ #:run-all-test-suites
#:explain
#:explain!
#:run!
+ #:run-all-tests!
+ #:run-all-test-suites!
#:debug!
#:!
#:!!
#:*debug-on-error*
#:*debug-on-failure*
#:*verbose-failures*
- #:results-status))
+ #:results-status
+ ;; introspection
+ #:list-all-suites))
;;;; You can use #+5am to put your test-defining code inline with your
;;;; other code - and not require people to have fiveam to run your
FOR-ALL test including when the body is skipped due to failed
guard conditions.
-Since we have guard conditions we may get into infinite loops
-where the test code is never run due to the guards never
-returning true. This second run limit prevents that.")
+Since we have guard conditions we may get into infinite loops where
+the test code is never run due to the guards never returning
+true. This second limit prevents that from happening.")
(defmacro for-all (bindings &body body)
- "Bind BINDINGS to random variables and test BODY *num-trials* times.
-
-BINDINGS is a list of binding forms, each element is a list
-of (BINDING VALUE &optional GUARD). Value, which is evaluated
-once when the for-all is evaluated, must return a generator which
-be called each time BODY is evaluated. BINDING is either a symbol
-or a list which will be passed to destructuring-bind. GUARD is a
-form which, if present, stops BODY from executing when IT returns
-NIL. The GUARDS are evaluated after all the random data has been
-generated and they can refer to the current value of any
-binding. NB: Generator forms, unlike guard forms, can not contain
-references to the boud variables.
+ "Bind BINDINGS to random variables and execute BODY `*num-trials*` times.
+
+BINDINGS::
+
+A a list of binding forms, each element is a list of:
++
+ (BINDING VALUE &optional GUARD)
++
+VALUE, which is evaluated once when the for-all is evaluated, must
+return a generator which be called each time BODY is
+evaluated. BINDING is either a symbol or a list which will be passed
+to destructuring-bind. GUARD is a form which, if present, stops BODY
+from executing when it returns NIL. The GUARDS are evaluated after all
+the random data has been generated and they can refer to the current
+value of any binding.
++
+[NOTE]
+Generator forms, unlike guard forms, can not contain references to the
+bound variables.
+
+BODY::
+
+The code to run. Will be run `*NUM-TRIALS*` times (unless the `*MAX-TRIALS*` limit is reached).
Examples:
- (for-all ((a (gen-integer)))
- (is (integerp a)))
+--------------------------------
+\(for-all ((a (gen-integer)))
+ (is (integerp a)))
- (for-all ((a (gen-integer) (plusp a)))
- (is (integerp a))
- (is (plusp a)))
+\(for-all ((a (gen-integer) (plusp a)))
+ (is (integerp a))
+ (is (plusp a)))
- (for-all ((less (gen-integer))
- (more (gen-integer) (< less more)))
- (is (<= less more)))
+\(for-all ((less (gen-integer))
+ (more (gen-integer) (< less more)))
+ (is (<= less more)))
- (for-all (((a b) (gen-two-integers)))
- (is (integerp a))
- (is (integerp b)))"
+\(defun gen-two-integers ()
+ (lambda ()
+ (list (funcall (gen-integer))
+ (funcall (gen-integer)))))
+
+\(for-all (((a b) (gen-two-integers)))
+ (is (integerp a))
+ (is (integerp b)))
+--------------------------------
+"
(with-gensyms (test-lambda-args)
`(perform-random-testing
(list ,@(mapcar #'second bindings))
(lambda ()
(+ min (random (1+ (- max min))))))
-(defun gen-float (&key bound (type 'short-float))
- "Returns a generator which producs floats of type TYPE. BOUND,
-if specified, constrains the ruselts to be in the range (-BOUND,
-BOUND)."
+(defun type-most-negative (floating-point-type)
+ (ecase floating-point-type
+ (short-float most-negative-short-float)
+ (single-float most-negative-single-float)
+ (double-float most-negative-double-float)
+ (long-float most-negative-long-float)))
+
+(defun type-most-positive (floating-point-type)
+ (ecase floating-point-type
+ (short-float most-positive-short-float)
+ (single-float most-positive-single-float)
+ (double-float most-positive-double-float)
+ (long-float most-positive-long-float)) )
+
+(defun gen-float (&key bound (type 'short-float) min max)
+ "Returns a generator which producs floats of type TYPE.
+
+BOUND::
+
+Constrains the results to be in the range (-BOUND, BOUND). Default
+value is the most-positive value of TYPE.
+
+MIN and MAX::
+
+If supplied, cause the returned float to be within the floating point
+interval (MIN, MAX). It is the caller's responsibility to ensure that
+the range between MIN and MAX is less than the requested type's
+maximum interval. MIN defaults to 0.0 (when only MAX is supplied), MAX
+defaults to MOST-POSITIVE-<TYPE> (when only MIN is supplied). This
+peculiar calling convention is designed for the common case of
+generating positive values below a known limit.
+
+TYPE::
+
+The type of the returned float. Defaults to `SHORT-FLOAT`. Effects the
+default values of BOUND, MIN and MAX.
+
+[NOTE]
+Since GEN-FLOAT is built on CL:RANDOM the distribution of returned
+values will be continuous, not discrete. In other words: the values
+will be evenly distributed across the specified numeric range, the
+distribution of possible floating point values, when seen as a
+sequence of bits, will not be even."
(lambda ()
- (let* ((most-negative (ecase type
- (short-float most-negative-short-float)
- (single-float most-negative-single-float)
- (double-float most-negative-double-float)
- (long-float most-negative-long-float)))
- (most-positive (ecase type
- (short-float most-positive-short-float)
- (single-float most-positive-single-float)
- (double-float most-positive-double-float)
- (long-float most-positive-long-float)))
- (bound (or bound (max most-positive (- most-negative)))))
- (coerce
- (ecase (random 2)
- (0 ;; generate a positive number
- (random (min most-positive bound)))
- (1 ;; generate a negative number
- (- (random (min (- most-negative) bound)))))
- type))))
+ (flet ((rand (limit) (random (coerce limit type))))
+ (when (and bound (or min max))
+ (error "GET-FLOAT does not support specifying :BOUND and :MAX/:MIN."))
+ (if (or min max)
+ (handler-bind ((arithmetic-error (lambda (c)
+ (error "ERROR ~S occured when attempting to generate a random value between ~S and ~S." c min max))))
+ (setf min (or min 0)
+ max (or max (type-most-positive type)))
+ (+ min (rand (- max min))))
+ (let ((min (if bound bound (- (type-most-negative type))))
+ (max (if bound bound (type-most-positive type))))
+ (ecase (random 2)
+ (0 ;; generate a positive number
+ (rand max))
+ (1 ;; generate a negative number NB: min is actually
+ ;; positive. see the if statement above.
+ (- (rand min)))))))))
(defun gen-character (&key (code-limit char-code-limit)
(code (gen-integer :min 0 :max (1- code-limit)))
(alphanumericp nil))
"Returns a generator of characters.
-CODE must be a generator of random integers. ALPHANUMERICP, if
-non-NIL, limits the returned chars to those which pass
-alphanumericp."
+CODE::
+
+A generater for random integers.
+
+CODE-LIMIT::
+
+If set only characters whose code-char is below this value will be
+returned.
+
+ALPHANUMERICP::
+
+Limits the returned chars to those which pass alphanumericp.
+"
(lambda ()
(loop
for count upfrom 0
finally (return char))))
(defun gen-string (&key (length (gen-integer :min 0 :max 80))
- (elements (gen-character))
- (element-type 'character))
- "Returns a generator which producs random strings. LENGTH must
-be a generator which producs integers, ELEMENTS must be a
-generator which produces characters of type ELEMENT-TYPE."
+ (elements (gen-character)))
+ "Returns a generator which producs random strings of characters.
+
+LENGTH::
+
+A random integer generator specifying how long to make the generated string.
+
+ELEMENTS::
+
+A random character generator which producs the characters in the
+string.
+"
+ (gen-buffer :length length
+ :element-type 'character
+ :elements elements))
+
+(defun gen-buffer (&key (length (gen-integer :min 0 :max 50))
+ (element-type '(unsigned-byte 8))
+ (elements (gen-integer :min 0 :max (1- (expt 2 8)))))
+ "Generates a random vector, defaults to a random (unsigned-byte 8)
+vector with elements between 0 and 255.
+
+LENGTH::
+
+The length of the buffer to create (a random integer generator)
+
+ELEMENT-TYPE::
+
+The type of array to create.
+
+ELEMENTS::
+
+The random element generator.
+"
(lambda ()
- (loop
- with length = (funcall length)
- with string = (make-string length :element-type element-type)
- for index below length
- do (setf (aref string index) (funcall elements))
- finally (return string))))
+ (let ((buffer (make-array (funcall length) :element-type element-type)))
+ (map-into buffer elements))))
(defun gen-list (&key (length (gen-integer :min 0 :max 10))
(elements (gen-integer :min -10 :max 10)))
- "Returns a generator which producs random lists. LENGTH must be
-an integer generator and ELEMENTS must be a generator which
-producs objects."
+ "Returns a generator which producs random lists.
+
+LENGTH::
+
+As with GEN-STRING, a random integer generator specifying the length of the list to create.
+
+ELEMENTS::
+
+A random object generator.
+"
(lambda ()
(loop
repeat (funcall length)
(lambda ()
(rec))))
-(defun gen-buffer (&key (length (gen-integer :min 0 :max 50))
- (element-type '(unsigned-byte 8))
- (elements (gen-integer :min 0 :max (1- (expt 2 8)))))
- (lambda ()
- (let ((buffer (make-array (funcall length) :element-type element-type)))
- (map-into buffer elements))))
-
(defun gen-one-element (&rest elements)
+ "Produces one randomly selected element of ELEMENTS.
+
+ELEMENTS::
+
+A list of objects (note: objects, not generators) to choose from."
(lambda ()
(nth (random (length elements)) elements)))
;;;; on this one (even if the dependency is not circular) will be
;;;; skipped.
-;;;; The functions RUN!, !, !! and !!! are convenient wrappers around
-;;;; RUN and EXPLAIN.
+;;;; The functions RUN! is a convenient wrapper around RUN and
+;;;; EXPLAIN.
(defparameter *debug-on-error* nil
"T if we should drop into a debugger on error, NIL otherwise.")
(defun explain! (result-list)
"Explain the results of RESULT-LIST using a
-detailed-text-explainer with output going to *test-dribble*"
+detailed-text-explainer with output going to `*test-dribble*`"
(explain (make-instance 'detailed-text-explainer) result-list *test-dribble*))
(defun debug! (&optional (test-spec *suite*))
(*debug-on-failure* t))
(run! test-spec)))
+(defun reset-all-tests-status (&optional (tests *test*))
+ "Resets the status of all TESTS to :unknown."
+ (maphash-values
+ (lambda (test)
+ (setf (status test) :unknown))
+ tests))
+
+(defun run-and-set-recently (function)
+ "Shifts the recently executed tests and lastly executes FUNCTION."
+ (shiftf *!!!* *!!* *!* function)
+ (funcall function))
+
+(defun run-and-bind-result-list (function)
+ (run-and-set-recently
+ (lambda ()
+ (reset-all-tests-status)
+ (bind-run-state ((result-list '()))
+ (with-simple-restart
+ (explain "Ignore the rest of the tests and explain current results")
+ (funcall function))
+ result-list))))
+
(defun run (test-spec)
"Run the test specified by TEST-SPEC.
TEST-SPEC can be either a symbol naming a test or test suite, or
a testable-object object. This function changes the operations
performed by the !, !! and !!! functions."
- (psetf *!* (lambda ()
- (loop :for test :being :the :hash-keys :of *test*
- :do (setf (status (get-test test)) :unknown))
- (bind-run-state ((result-list '()))
- (with-simple-restart (explain "Ignore the rest of the tests and explain current results")
- (%run test-spec))
- result-list))
- *!!* *!*
- *!!!* *!!*)
- (funcall *!*))
-
-(defun ! ()
- "Rerun the most recently run test and explain the results."
- (explain! (funcall *!*)))
-
-(defun !! ()
- "Rerun the second most recently run test and explain the results."
- (explain! (funcall *!!*)))
-
-(defun !!! ()
- "Rerun the third most recently run test and explain the results."
- (explain! (funcall *!!!*)))
+ (run-and-bind-result-list (lambda () (%run test-spec))))
+
+(defun run-all-tests ()
+ "Run all tests in arbitrary order."
+ (run-and-bind-result-list
+ (lambda ()
+ (maphash-values
+ (lambda (test)
+ (when (typep test 'test-case)
+ (%run test)))
+ *test*))))
+
+(defun run-all-tests! ()
+ "Equivalent to (explain! (run-all-tests))."
+ (explain! (run-all-tests)))
+
+(defun run-all-test-suites ()
+ "Run all test suites in arbitrary order."
+ (run-and-bind-result-list
+ (lambda ()
+ (maphash-values
+ (lambda (test)
+ (when (typep test 'test-suite)
+ (format *test-dribble* "~& ~A: " (name test))
+ (%run test)))
+ *test*))))
+
+(defun run-all-test-suites! ()
+ "Equivalent to (explain (run-all-test-suites))."
+ (explain! (run-all-test-suites)))
;; Copyright (c) 2002-2003, Edward Marco Baringer
;; All rights reserved.
;;;; ** Creating Suits
-(defmacro def-suite (name &key description in)
+(defvar *suites* (make-hash-table :test 'eql))
+
+(defmacro def-suite (name &key description (in nil in-p) (fixture nil fixture-p))
"Define a new test-suite named NAME.
-IN (a symbol), if provided, causes this suite te be nested in the
-suite named by IN. NB: This macro is built on top of make-suite,
-as such it, like make-suite, will overrwrite any existing suite
-named NAME."
+NAME::
+ The symbol naming the test.
+
+DESCRIPTION::
+ A string describing the contents/purpose of this suite.
+
+IN (a symbol)::
+ If provided, causes this suite te be nested in the suite named by
+ `IN`. If `IN` is `NIL`, as opposed to not being passed at all, the
+ new suite will not be a part of any existing suite.
+
+FIXTURE::
+ Whatever value is passed here will be passed, unevaluated, to all
+ tests defined in this suite.
+
+[NOTE]
+This macro is built on top of `make-suite` as such it, like `make-suite`,
+will overrwrite any existing suite named `NAME`."
`(eval-when (:compile-toplevel :load-toplevel :execute)
(make-suite ',name
,@(when description `(:description ,description))
- ,@(when in `(:in ',in)))
+ ,@(when in-p `(:in ',in))
+ ,@(when fixture-p `(:fixture ',fixture)))
',name))
-(defmacro def-suite* (name &rest def-suite-args)
- `(progn
- (def-suite ,name ,@def-suite-args)
- (in-suite ,name)))
+(defun remove-from-suites (test-name)
+ (when (get-test test-name)
+ ;; if this suite alruady exists, and its :IN some other suite, remove it.
+ (dolist (s (list-all-suites))
+ (when (gethash test-name (tests s))
+ (remhash test-name (tests s))))))
-(defun make-suite (name &key description ((:in parent-suite)))
+(defun make-suite (name &key description ((:in parent-suite) *suite*) fixture)
"Create a new test suite object.
Overrides any existing suite named NAME."
- (let ((suite (make-instance 'test-suite :name name)))
+ (remove-from-suites name)
+ (let ((suite (make-instance 'test-suite :name name :fixture fixture)))
(when description
(setf (description suite) description))
+ (setf (gethash name *suites*) suite)
(loop for i in (ensure-list parent-suite)
for in-suite = (get-test i)
do (progn
(setf (get-test name) suite)
suite))
+(defun list-all-suites ()
+ (loop for suite being the hash-value in *suites*
+ collect suite))
+
;;;; ** Managing the Current Suite
-(defvar *suite* (setf (get-test 'NIL)
- (make-suite 'NIL :description "Global Suite"))
+(defvar *suite* (setf (get-test 'T) (make-suite 'T :description "Default global suite" :in nil))
"The current test suite object")
(defmacro in-suite (suite-name)
- "Set the *suite* special variable so that all tests defined
+ "Set the `*suite*` special variable so that all tests defined
after the execution of this form are, unless specified otherwise,
-in the test-suite named SUITE-NAME.
+in the test-suite named `SUITE-NAME`.
-See also: DEF-SUITE *SUITE*"
+See also: `DEF-SUITE` and `*SUITE*`. "
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%in-suite ,suite-name)))
-(defmacro in-suite* (suite-name &key in)
- "Just like in-suite, but silently creates missing suites."
- `(%in-suite ,suite-name :in ,in :fail-on-error nil))
-
-(defmacro %in-suite (suite-name &key (fail-on-error t) in)
+(defmacro %in-suite (suite-name &rest def-suite-args)
(with-gensyms (suite)
`(progn
(if-let (,suite (get-test ',suite-name))
(setf *suite* ,suite)
(progn
- (when ,fail-on-error
- (cerror "Create a new suite named ~A."
- "Unknown suite ~A." ',suite-name))
- (setf (get-test ',suite-name) (make-suite ',suite-name :in ',in)
+ (cerror "Create a new suite named ~A." "Unknown suite ~A." ',suite-name)
+ (setf (get-test ',suite-name) (make-suite ',suite-name ,@def-suite-args)
*suite* (get-test ',suite-name))))
',suite-name)))
(defvar *test*
(make-hash-table :test 'eql)
- "Lookup table mapping test (and test suite)
- names to objects.")
-
-(defun get-test (key &optional default)
- (gethash key *test* default))
+ "Lookup table mapping test (and test suite) names to objects.")
+
+(defun get-test (key &key default error)
+ "Finds the test named KEY. If KEY is a testable-object (a test case
+or a test suite) then we just return KEY, otherwise we look for a test
+named KEY in the *TEST* hash table."
+ (if (testable-object-p key)
+ key
+ (multiple-value-bind (value foundp)
+ (gethash key *test*)
+ (if foundp
+ value
+ (if error
+ (error "Unable to find test named ~S." key)
+ default)))))
(defun (setf get-test) (value key)
(setf (gethash key *test*) value))
collect test))
(defmacro test (name &body body)
- "Create a test named NAME. If NAME is a list it must be of the
-form:
-
- (name &key depends-on suite fixture compile-at profile)
-
-NAME is the symbol which names the test.
-
-DEPENDS-ON is a list of the form:
-
- (AND . test-names) - This test is run only if all of the tests
- in TEST-NAMES have passed, otherwise a single test-skipped
- result is generated.
-
- (OR . test-names) - If any of TEST-NAMES has passed this test is
- run, otherwise a test-skipped result is generated.
-
- (NOT test-name) - This is test is run only if TEST-NAME failed.
-
-AND, OR and NOT can be combined to produce complex dependencies.
-
-If DEPENDS-ON is a symbol it is interpreted as `(AND
-,depends-on), this is accomadate the common case of one test
-depending on another.
-
-FIXTURE specifies a fixture to wrap the body in.
-
-If PROFILE is T profiling information will be collected as well."
+ "Deprecated. See DEF-TEST."
+ (simple-style-warning "~A is OBSOLETE! Use ~A instead." 'test 'def-test)
(destructuring-bind (name &rest args)
(ensure-list name)
`(def-test ,name (,@args) ,@body)))
-(defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture
- (compile-at :run-time) profile)
+(defmacro def-test (name (&key (suite nil suite-p)
+ fixture
+ (compile-at :run-time)
+ depends-on
+ profile)
&body body)
"Create a test named NAME.
-NAME is the symbol which names the test.
+NAME (a symbol)::
+ The name of the test.
+
+SUITE (a test name)::
+ The suite to put the test under. It defaults to *SUITE* (which
+ itself defaults to the default global suite).
-DEPENDS-ON is a list of the form:
+FIXTURE::
+ The name of the fixture to use for this test. See `WITH-FIXTURE` for
+ details on fixtures.
- (AND . test-names) - This test is run only if all of the tests
- in TEST-NAMES have passed, otherwise a single test-skipped
- result is generated.
+COMPILE-AT (a keyword)::
+ When the body of this test should be compiled. By default, or when
+ `:compile-at` is `:run-time`, test bodies are only compiled before
+ they are run. Set this to to `:definition-time` to force
+ compilation, and errors/warnings, to be done at compile time.
- (OR . test-names) - If any of TEST-NAMES has passed this test is
- run, otherwise a test-skipped result is generated.
+DEPENDS-ON::
+ A list, or a symbol, which specifies the relationship between this
+ test and other tests. These conditions, `AND`, `OR` and `NOT` can be
+ combined to produce complex dependencies (whethere this is something
+ you should actually be doing is a question for another day).
- (NOT test-name) - This is test is run only if TEST-NAME failed.
+ `(and &rest TEST-NAMES)`:::
+ This test is run only if all of the tests in TEST-NAMES have
+ passed, otherwise a single test-skipped result is generated.
-AND, OR and NOT can be combined to produce complex dependencies.
+ `(or &rest TEST-NAMES)`:::
+ If any of TEST-NAMES has passed this test is run, otherwise a
+ test-skipped result is generated.
-If DEPENDS-ON is a symbol it is interpreted as `(AND
-,depends-on), this is accomadate the common case of one test
-depending on another.
+ `(NOT TEST-NAME`:::
+ This is test is run only if TEST-NAME failed.
-FIXTURE specifies a fixture to wrap the body in.
+ __a-symbol__:::
+ Shorthand for `(AND a-symbol)`
-If PROFILE is T profiling information will be collected as well."
+PROFILE::
+ When non-`NIL` profiling information will be collected as well."
(check-type compile-at (member :run-time :definition-time))
(multiple-value-bind (forms decls docstring)
(parse-body body :documentation t :whole name)
(let* ((description (or docstring ""))
(body-forms (append decls forms))
(suite-form (if suite-p
- `(get-test ',suite)
- (or suite '*suite*)))
- (effective-body (if fixture
- (destructuring-bind (name &rest args)
- (ensure-list fixture)
- `((with-fixture ,name ,args ,@body-forms)))
- body-forms)))
+ (if suite
+ `(get-test ',suite)
+ nil)
+ '*suite*))
+ (effective-body (let* ((test-fixture fixture)
+ (suite-fixture (if suite-p
+ (if suite
+ (fixture (get-test suite :error t))
+ nil)
+ (if *suite*
+ (fixture *suite*)
+ nil)))
+ (effective-fixture (or test-fixture suite-fixture)))
+ (if effective-fixture
+ (destructuring-bind (name &rest args)
+ (ensure-list effective-fixture)
+ `((with-fixture ,name ,args ,@body-forms)))
+ body-forms))))
`(progn
- (register-test ',name ,description ',effective-body ,suite-form ',depends-on ,compile-at ,profile)
+ (register-test :name ',name
+ :description ,description
+ :body ',effective-body
+ :suite ,suite-form
+ :depends-on ',depends-on
+ :compile-at ,compile-at
+ :profile ,profile)
(when *run-test-when-defined*
(run! ',name))
',name))))
-(defun register-test (name description body suite depends-on compile-at profile)
+(defun register-test (&key name description body suite depends-on compile-at profile)
+ (remove-from-suites name)
(let ((lambda-name
(format-symbol t "%~A-~A" '#:test name))
(inner-lambda-name
:description description
:depends-on depends-on
:collect-profiling-info profile))
- (setf (gethash name (tests suite)) name)))
+ (when suite
+ (setf (gethash name (tests (get-test suite :error t))) name))))
(defvar *run-test-when-defined* nil
"When non-NIL tests are run as soon as they are defined.")
(return-from item)))))
(mapcar #'funcall (mapcar #'cdr collectors))))
-;;;; ** Anaphoric conditionals
-
-(defmacro if-bind (var test &body then/else)
- "Anaphoric IF control structure.
-
-VAR (a symbol) will be bound to the primary value of TEST. If
-TEST returns a true value then THEN will be executed, otherwise
-ELSE will be executed."
- (assert (first then/else)
- (then/else)
- "IF-BIND missing THEN clause.")
- (destructuring-bind (then &optional else)
- then/else
- `(let ((,var ,test))
- (if ,var ,then ,else))))
-
-(defmacro aif (test then &optional else)
- "Just like IF-BIND but the var is always IT."
- `(if-bind it ,test ,then ,else))
-
;;;; ** Simple list matching based on code from Paul Graham's On Lisp.
(defmacro acond2 (&rest clauses)
(defun binding (x binds)
(labels ((recbind (x binds)
- (aif (assoc x binds)
- (or (recbind (cdr it) binds)
- it))))
+ (if-let (value (assoc x binds))
+ (or (recbind (cdr value) binds)
+ value))))
(let ((b (recbind x binds)))
(values (cdr b) b))))
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
-(in-package :it.bese.fiveam)
+(in-package :it.bese.FiveAM)
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (get-test :it.bese)
(def-suite :it.bese)))
-(def-suite :it.bese.fiveam :in :it.bese)
+(def-suite :it.bese.FiveAM :in :it.bese)
(in-suite :it.bese.fiveam)
-(def-suite test-suite :description "Suite for tests which should fail.")
+(def-suite test-suite
+ :description "Suite for tests which should fail."
+ :in nil)
(defmacro with-test-results ((results test-name) &body body)
`(let ((,results (with-*test-dribble* nil (run ',test-name))))
(is (= 1 (length (remove-if-not #'test-failure-p results))))))
(def-test circular-0 (:depends-on (and circular-1 circular-2 or1)
- :suite test-suite)
+ :suite test-suite)
(fail "we depend on a circular dependency, we should not be tested."))
(def-test circular-1 (:depends-on (and circular-2)
- :suite test-suite)
+ :suite test-suite)
(fail "we have a circular depednency, we should not be tested."))
(def-test circular-2 (:depends-on (and circular-1)
- :suite test-suite)
+ :suite test-suite)
(fail "we have a circular depednency, we should not be tested."))
(def-test circular ()
(run 'circular-2)))
-(def-suite before-test-suite :description "Suite for before test")
+(def-suite before-test-suite :description "Suite for before test" :in nil)
(def-test before-0 (:suite before-test-suite)
(pass))
(def-test before-1 (:depends-on (:before before-0)
- :suite before-test-suite)
+ :suite before-test-suite)
(fail))
-(def-suite before-test-suite-2 :description "Suite for before test")
+(def-suite before-test-suite-2 :description "Suite for before test" :in nil)
(def-test before-2 (:depends-on (:before before-3)
- :suite before-test-suite-2)
+ :suite before-test-suite-2)
(pass))
(def-test before-3 (:suite before-test-suite-2)
(test-gen-float single-float)
(test-gen-float short-float)
(test-gen-float double-float)
- (test-gen-float long-float)))
+ (test-gen-float long-float)
+
+ (for-all ((value (gen-float :type 'single-float :min 1 :max 2)))
+ (is (typep value 'single-float))
+ (is (<= (coerce 1 'single-float) value (coerce 2 'single-float))))))
(def-test gen-character ()
(for-all ((c (gen-character)))
(for-all (((a b) (dummy-mv-generator)))
(is (= 1 a))
(is (= 1 b))))
+
+(def-test introspection ()
+ (is (= (length (list-all-suites))
+ (hash-table-count *suites*))))
+
+(defvar *special-variable* nil)
+
+(def-fixture fixture-for-suite (value)
+ (progn
+ (setf *special-variable* value)
+ (&body)))
+
+(def-suite suite-with-fixture :fixture (fixture-for-suite 42) :in :it.bese.fiveam)
+
+(def-test test-with-suite-fixture (:suite suite-with-fixture)
+ (is (= 42 *special-variable*)))
+
+(def-test add-remove-test-from-suite ()
+ (let ((*test* (make-hash-table :test 'eql))
+ (*suites* (make-hash-table :test 'eql)))
+ (def-suite empty :in nil)
+ (in-suite empty)
+ (is (null (get-test 'foo)))
+
+ (def-test foo (:suite nil) t)
+ (is-true (get-test 'foo))
+ (is-false (gethash 'foo (tests *suite*)))
+
+ (def-test foo () t)
+ (is-true (gethash 'foo (tests *suite*)))
+
+ (def-test foo (:suite nil) t)
+ (is-false (gethash 'foo (tests *suite*)))))
projects / fiveam.git / commitdiff