Vim window logic, slimv
This commit is contained in:
Ian Keane
parent
babcc9e44b
commit
515847d07e
791 changed files with 51552 additions and 86 deletions
3
sbcl/.quicklisp/dists/quicklisp/software/prove-20171130-git/.gitignore
vendored
Normal file
3
sbcl/.quicklisp/dists/quicklisp/software/prove-20171130-git/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
*.fasl
|
||||
*.dx32fsl
|
||||
*.dx64fsl
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
language: common-lisp
|
||||
sudo: false
|
||||
|
||||
env:
|
||||
global:
|
||||
- PATH=~/.roswell/bin:$PATH
|
||||
- ROSWELL_BRANCH=release
|
||||
- ROSWELL_INSTALL_DIR=$HOME/.roswell
|
||||
matrix:
|
||||
- LISP=sbcl-bin
|
||||
- LISP=ccl-bin
|
||||
- LISP=ecl
|
||||
- LISP=abcl
|
||||
- LISP=allegro
|
||||
- LISP=cmucl
|
||||
- LISP=clisp
|
||||
|
||||
matrix:
|
||||
allow_failures:
|
||||
# there is some issue with clisp,
|
||||
# roswell installs ASDF3, but clisp doesn't see it
|
||||
- env: LISP=clisp
|
||||
|
||||
addons:
|
||||
apt:
|
||||
packages:
|
||||
# it is required for some reason
|
||||
# to install allegrocl and cmucl
|
||||
- libc6-i386
|
||||
|
||||
install:
|
||||
- curl -L https://raw.githubusercontent.com/snmsts/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh
|
||||
|
||||
before_script:
|
||||
- ros --version
|
||||
- ros config
|
||||
- ros -e '(princ (lisp-implementation-type))
|
||||
(terpri)
|
||||
(princ (lisp-implementation-version))
|
||||
(terpri)
|
||||
(princ *features*)
|
||||
(terpri)'
|
||||
|
||||
|
||||
script:
|
||||
# prove-asdf must be independent.
|
||||
- ros +Q -e '(require "asdf")' -l prove-asdf.asd -e '(asdf:load-system :prove-asdf)'
|
||||
- ros -l prove.asd -e '(ql:quickload :prove)'
|
||||
- ros -l cl-test-more.asd -e '(ql:quickload :cl-test-more)'
|
||||
- ros -e '(ql:quickload :prove) (uiop:quit (if (prove:run-test-system :prove-test) 0 1))'
|
||||
|
|
@ -0,0 +1,369 @@
|
|||
# prove
|
||||
|
||||
_This project was originally called 'CL-TEST-MORE'._
|
||||
|
||||
'prove' is yet another unit testing framework for Common Lisp.
|
||||
|
||||
The advantages of 'prove' are:
|
||||
|
||||
* Various simple functions for testing and informative error messages
|
||||
* [ASDF integration](#asdf-integration)
|
||||
* [Extensible test reporters](#reporters)
|
||||
* Colorizes the report if it's available ([note for SLIME](#colorize-test-reports-on-slime))
|
||||
* Reports test durations
|
||||
|
||||
## Quickstart
|
||||
|
||||
### 1. Writing a test file
|
||||
|
||||
```common-lisp
|
||||
(in-package :cl-user)
|
||||
(defpackage my-test
|
||||
(:use :cl
|
||||
:prove))
|
||||
(in-package :my-test)
|
||||
|
||||
(plan 3)
|
||||
|
||||
(ok (not (find 4 '(1 2 3))))
|
||||
(is 4 4)
|
||||
(isnt 1 #\1)
|
||||
|
||||
(finalize)
|
||||
```
|
||||
|
||||
### 2. Run a test file
|
||||
|
||||
```common-lisp
|
||||
(prove:run #P"myapp/tests/my-test.lisp")
|
||||
(prove:run #P"myapp/tests/my-test.lisp" :reporter :list)
|
||||
```
|
||||
|
||||
See also: [ASDF integration](#asdf-integration), [Reporters](#reporters)
|
||||
|
||||
### 3. Get a report
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
## Installation
|
||||
|
||||
You can install 'prove' via [Quicklisp](http://www.quicklisp.org/beta/).
|
||||
|
||||
```common-lisp
|
||||
(ql:quickload :prove)
|
||||
```
|
||||
|
||||
## Testing functions
|
||||
|
||||
### (ok test &optional desc)
|
||||
|
||||
Checks if `test` is true (non-NIL).
|
||||
|
||||
```common-lisp
|
||||
(ok 1)
|
||||
;-> ✓ 1 is expected to be T
|
||||
```
|
||||
|
||||
### (is got expected &rest test-args)
|
||||
|
||||
Checks if `got` is equivalent to `expected`.
|
||||
|
||||
```common-lisp
|
||||
(is 1 1)
|
||||
;-> ✓ 1 is expected to be 1
|
||||
|
||||
(is #(1 2 3) #(1 2 3))
|
||||
;-> × #(1 2 3) is expected to be #(1 2 3)
|
||||
|
||||
(is #(1 2 3) #(1 2 3) :test #'equalp)
|
||||
;-> ✓ #(1 2 3) is expected to be #(1 2 3)
|
||||
|
||||
;; with description
|
||||
(is 1 #\1 "Integer = Character ?")
|
||||
;-> × Integer = Character ?
|
||||
```
|
||||
|
||||
### (isnt got expected &rest test-args)
|
||||
|
||||
Checks if `got` is _not_ equivalent to `expected`.
|
||||
|
||||
```common-lisp
|
||||
(isnt 1 1)
|
||||
;-> × 1 is not expected to be 1
|
||||
|
||||
(isnt #(1 2 3) #(1 2 3))
|
||||
;-> ✓ #(1 2 3) is not expected to be #(1 2 3)
|
||||
```
|
||||
|
||||
### (is-values got expected &rest test-args)
|
||||
|
||||
Checks if the multiple values of `got` is equivalent to `expected`. This is same to `(is (multiple-value-list got) expected)`.
|
||||
|
||||
```common-lisp
|
||||
(defvar *person* (make-hash-table))
|
||||
|
||||
(is-values (gethash :name *person*) '("Eitaro" T))
|
||||
;-> × (NIL NIL) is expected to be ("Eitaro" T)
|
||||
|
||||
(setf (gethash :name *person*) "Eitaro")
|
||||
|
||||
(is-values (gethash :name *person*) '("Eitaro" T))
|
||||
;-> ✓ ("Eitaro" T) is expected to be ("Eitaro" T)
|
||||
```
|
||||
|
||||
### (is-type got expected-type &optional desc)
|
||||
|
||||
Checks if `got` is a type of `expected-type`.
|
||||
|
||||
```common-lisp
|
||||
(is-type #(1 2 3) 'simple-vector)
|
||||
;-> ✓ #(1 2 3) is expected to be a type of SIMPLE-VECTOR (got (SIMPLE-VECTOR 3))
|
||||
|
||||
(is-type (make-array 0 :adjustable t) 'simple-vector)
|
||||
;-> × #() is expected to be a type of SIMPLE-VECTOR (got (VECTOR T 0))
|
||||
```
|
||||
|
||||
### (like got regex &optional desc)
|
||||
|
||||
Checks if `got` matches a regular expression `regex`.
|
||||
|
||||
```common-lisp
|
||||
(like "Hatsune 39" "\\d")
|
||||
;-> ✓ "Hatsune 39" is expected to be like "\\d"
|
||||
|
||||
(like "初音ミク" "\\d")
|
||||
;-> × "初音ミク" is expected to be like "\\d"
|
||||
```
|
||||
|
||||
### (is-print got expected &optional desc)
|
||||
|
||||
Checks if `got` outputs `expected` to `*standard-output*`
|
||||
|
||||
```common-lisp
|
||||
(is-print (princ "Hi, there") "Hi, there")
|
||||
;-> ✓ (PRINC "Hi, there") is expected to output "Hi, there" (got "Hi, there")
|
||||
```
|
||||
|
||||
### (is-error form condition &optional desc)
|
||||
|
||||
Checks if `form` raises a condition and that is a subtype of `condition`.
|
||||
|
||||
```common-lisp
|
||||
(is-error (error "Something wrong") 'simple-error)
|
||||
;-> ✓ (ERROR "Something wrong") is expected to raise a condition SIMPLE-ERROR (got #<SIMPLE-ERROR "Something wrong" {100628FE53}>)
|
||||
|
||||
(define-condition my-error (simple-error) ())
|
||||
|
||||
(is-error (error "Something wrong") 'my-error)
|
||||
;-> × (ERROR "Something wrong") is expected to raise a condition MY-ERROR (got #<SIMPLE-ERROR "Something wrong" {100648E553}>)
|
||||
```
|
||||
|
||||
### (is-expand got expected &optional desc)
|
||||
|
||||
Checks if `got` will be `macroexpand`ed to `expected`.
|
||||
|
||||
```common-lisp
|
||||
(is-expand (when T (princ "Hi")) (if T (progn (princ "Hi"))))
|
||||
;-> ✓ (WHEN T (PRINC "Hi")) is expected to be expanded to (IF T
|
||||
; (PROGN (PRINC "Hi"))) (got (IF T
|
||||
; (PROGN
|
||||
; (PRINC
|
||||
; "Hi"))
|
||||
; NIL))
|
||||
```
|
||||
|
||||
If a symbol that starts with "$" is contained, it will be treated as a gensym.
|
||||
|
||||
### (pass desc)
|
||||
|
||||
This will always be passed. This is convenient if the test case is complicated and hard to test with `ok`.
|
||||
|
||||
```common-lisp
|
||||
(pass "Looks good")
|
||||
;-> ✓ Looks good
|
||||
```
|
||||
|
||||
### (fail desc)
|
||||
|
||||
This will always be failed. This is convenient if the test case is complicated and hard to test with `ok`.
|
||||
|
||||
```common-lisp
|
||||
(fail "Hopeless")
|
||||
;-> × Hopeless
|
||||
```
|
||||
|
||||
### (skip how-many why)
|
||||
|
||||
Skip a number of `how-many` tests and mark them passed.
|
||||
|
||||
```common-lisp
|
||||
(skip 3 "No need to test these on Mac OS X")
|
||||
;-> ✓ No need to test these on Mac OS X (Skipped)
|
||||
; ✓ No need to test these on Mac OS X (Skipped)
|
||||
; ✓ No need to test these on Mac OS X (Skipped)
|
||||
```
|
||||
|
||||
### (subtest desc &body body)
|
||||
|
||||
Run tests of `body` in a new sub test suite.
|
||||
|
||||
```common-lisp
|
||||
(subtest "Testing integers"
|
||||
(is 1 1)
|
||||
(is-type 1 'bit)
|
||||
(is-type 10 'fixnum))
|
||||
;-> ✓ 1 is expected to be 1
|
||||
; ✓ 1 is expected to be a type of BIT (got BIT)
|
||||
; ✓ 10 is expected to be a type of FIXNUM (got (INTEGER 0 4611686018427387903))
|
||||
;-> ✓ Testing integers
|
||||
```
|
||||
|
||||
## Other functions
|
||||
|
||||
### (diag desc)
|
||||
|
||||
Outputs `desc` to a `*test-result-output*`.
|
||||
|
||||
```common-lisp
|
||||
(diag "Gonna run tests")
|
||||
;-> # Gonna run tests
|
||||
```
|
||||
|
||||
### (plan num)
|
||||
|
||||
Declares a number of `num` tests are going to run. If `finalize` is called with no `plan`, a warning message will be output. `num` is allows to be `NIL` if you have no plan yet.
|
||||
|
||||
### (finalize)
|
||||
|
||||
Finalizes the current test suite and outputs the test reports.
|
||||
|
||||
### (slow-threshold milliseconds)
|
||||
|
||||
Set the threshold of slow test durations for the current test suite. The default threshold value is `prove:*default-slow-threshold*`.
|
||||
|
||||
```common-lisp
|
||||
(slow-threshold 150)
|
||||
```
|
||||
|
||||
## Reporters
|
||||
|
||||
You can change the test report formats by setting `prove:*default-reporter*` to `:list`, `:dot`, `:tap` or `:fiveam`. The default value is `:list`.
|
||||
|
||||
`prove:run` also takes a keyword argument `:reporter`.
|
||||
|
||||
### List (Default)
|
||||
|
||||
The `:list` repoter outputs test results list as test cases pass or fail.
|
||||
|
||||
|
||||
|
||||
### Dot
|
||||
|
||||
The `:dot` reporter outputs a series of dots that represent test cases, failures highlight in red, skipping in cyan.
|
||||
|
||||
|
||||
|
||||
### FiveAM
|
||||
|
||||
The `:fiveam` reporter outputs test results like [FiveAM](http://common-lisp.net/project/fiveam/) does.
|
||||
|
||||
|
||||
|
||||
### TAP
|
||||
|
||||
The `:tap` reporter outputs in [Test Anything Protocol](http://testanything.org) format.
|
||||
|
||||
|
||||
|
||||
## Tips
|
||||
|
||||
### Debugging with CL debugger
|
||||
|
||||
Set `prove:*debug-on-error*` T for invoking CL debugger whenever getting an error during running tests.
|
||||
|
||||
### Colorize test reports on SLIME
|
||||
|
||||
SLIME doesn't support to color with ANSI colors in the REPL buffer officially.
|
||||
|
||||
You can add the feature by using [slime-repl-ansi-color.el](https://github.com/enriquefernandez/slime-repl-ansi-color).
|
||||
|
||||
After installing it, set `prove:*enable-colors*` to `T` before running tests.
|
||||
|
||||
```common-lisp
|
||||
;; A part of my ~/.sbclrc
|
||||
(ql:quickload :prove)
|
||||
(setf prove:*enable-colors* t)
|
||||
```
|
||||
|
||||
The following snippet is a little bit complicated, however it would be better if you don't like to load `prove` in all sessions.
|
||||
|
||||
```common-lisp
|
||||
(defmethod asdf:perform :after ((op asdf:load-op) (c (eql (asdf:find-system :prove))))
|
||||
(setf (symbol-value (intern (string :*enable-colors*) :prove)) t))
|
||||
```
|
||||
|
||||
### ASDF integration
|
||||
|
||||
Add `:defsystem-depends-on (:prove-asdf)` to your testing ASDF system to enable `:test-file` in the `:components`.
|
||||
|
||||
`:test-file` is same as `:file` except it will be loaded only when `asdf:test-system`.
|
||||
|
||||
```common-lisp
|
||||
;; Main ASDF system
|
||||
(defsystem my-app
|
||||
|
||||
;; ...
|
||||
|
||||
:in-order-to ((test-op (test-op my-app-test))))
|
||||
|
||||
;; Testing ASDF system
|
||||
(defsystem my-app-test
|
||||
:depends-on (:my-app
|
||||
:prove)
|
||||
:defsystem-depends-on (:prove-asdf)
|
||||
:components
|
||||
((:test-file "my-app"))
|
||||
:perform (test-op :after (op c)
|
||||
(funcall (intern #.(string :run) :prove) c)))
|
||||
```
|
||||
|
||||
To run tests, execute `asdf:test-system` or `prove:run` in your REPL.
|
||||
|
||||
```common-lisp
|
||||
(asdf:test-system :my-app)
|
||||
(asdf:test-system :my-app-test)
|
||||
|
||||
;; Same as 'asdf:test-system' except it returns T or NIL as the result of tests.
|
||||
(prove:run :my-app-test)
|
||||
```
|
||||
|
||||
### Changing default test function
|
||||
|
||||
Test functions like `is` uses `prove:*default-test-function*` for testing if no `:test` argument is specified. The default value is `#'equal`.
|
||||
|
||||
### Changing output stream
|
||||
|
||||
Test reports will be output to `prove:*test-result-output*`. The default value is `T`, which means `*standard-output*`.
|
||||
|
||||
### Running tests on Travis CI
|
||||
|
||||
Although Common Lisp isn't supported by Travis CI officially, you can run tests by using [cl-travis](https://github.com/luismbo/cl-travis).
|
||||
|
||||
Here's a list of `.travis.yml` from projects using `prove` on Travis CI:
|
||||
|
||||
- [Clack](https://github.com/fukamachi/clack/blob/master/.travis.yml)
|
||||
- [CL-DBI](https://github.com/fukamachi/cl-dbi/blob/master/.travis.yml)
|
||||
- [Woo](https://github.com/fukamachi/Woo/blob/master/.travis.yml)
|
||||
- [fast-http](https://github.com/fukamachi/fast-http/blob/master/.travis.yml)
|
||||
- [defclass-std](https://github.com/EuAndreh/defclass-std/blob/master/.travis.yml)
|
||||
|
||||
## Bugs
|
||||
|
||||
Please report any bugs to e.arrows@gmail.com, or post an issue to [GitHub](http://github.com/fukamachi/prove/issues).
|
||||
|
||||
## License
|
||||
|
||||
Copyright (c) 2010-2014 Eitaro Fukamachi <e.arrows@gmail.com>
|
||||
'prove' and CL-TEST-MORE is freely distributable under the MIT License (http://www.opensource.org/licenses/mit-license).
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
(defsystem "cl-test-more"
|
||||
:version "2.0.0"
|
||||
:author "Eitaro Fukamachi"
|
||||
:license "MIT"
|
||||
:depends-on ("prove"))
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 138 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 156 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 179 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 186 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 141 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 167 KiB |
|
|
@ -0,0 +1,5 @@
|
|||
(defsystem "prove-asdf"
|
||||
:components ((:module "src"
|
||||
:components
|
||||
((:file "asdf" :depends-on ("output"))
|
||||
(:file "output")))))
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
(defsystem "prove-test"
|
||||
:author "Eitaro Fukamachi"
|
||||
:license "MIT"
|
||||
:depends-on (:split-sequence
|
||||
:alexandria
|
||||
:prove)
|
||||
:components ((:module "t"
|
||||
:serial t
|
||||
:components
|
||||
((:file "utils")
|
||||
(:test-file "prove"))))
|
||||
:description "Test system for Prove."
|
||||
|
||||
:defsystem-depends-on ("prove-asdf")
|
||||
:perform (test-op (o c) (symbol-call :prove-asdf :run-test-system c)))
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
(defsystem "prove"
|
||||
:version "1.0.0"
|
||||
:author "Eitaro Fukamachi"
|
||||
:license "MIT"
|
||||
:depends-on ("cl-ppcre"
|
||||
"cl-ansi-text"
|
||||
"cl-colors"
|
||||
"alexandria"
|
||||
"uiop")
|
||||
:components ((:module "src"
|
||||
:components
|
||||
((:file "prove" :depends-on ("output" "test" "suite" "asdf" "color"))
|
||||
(:file "test" :depends-on ("output" "report" "reporter" "suite"))
|
||||
(:file "report")
|
||||
(:file "reporter" :depends-on ("report" "output"))
|
||||
(:module "reporter-components"
|
||||
:pathname "reporter"
|
||||
:depends-on ("report" "reporter" "color")
|
||||
:components
|
||||
((:file "tap")
|
||||
(:file "fiveam")
|
||||
(:file "list")
|
||||
(:file "dot" :depends-on ("list"))))
|
||||
(:file "suite" :depends-on ("output" "report" "reporter" "asdf"))
|
||||
(:file "asdf" :depends-on ("output" "color"))
|
||||
(:file "color")
|
||||
(:file "output")))))
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
#!/bin/sh
|
||||
#|-*- mode:lisp -*-|#
|
||||
#|
|
||||
exec ros -Q -- $0 "$@"
|
||||
|#
|
||||
|
||||
(unless (find-package :uiop)
|
||||
(ql:quickload :uiop :silent t))
|
||||
|
||||
(ql:quickload :prove :silent t)
|
||||
|
||||
(when (uiop:getenv "COVERALLS")
|
||||
(ql:quickload '(:cl-coveralls :split-sequence) :silent t))
|
||||
|
||||
(defun print-error (format-string &rest format-args)
|
||||
(format *error-output* "~&[Error] ")
|
||||
(apply #'format *error-output*
|
||||
format-string format-args)
|
||||
(fresh-line *error-output*)
|
||||
(uiop:quit -1))
|
||||
|
||||
(defun main (&rest test-files)
|
||||
(let (reporter color)
|
||||
(when (or (string= (first test-files) "-r")
|
||||
(string= (first test-files) "--reporter"))
|
||||
(setf reporter (second test-files)
|
||||
test-files (cddr test-files)))
|
||||
(flet ((not-color-p (arg) (or (string= "-c" arg)
|
||||
(string= "--without-colors" arg))))
|
||||
(setf color (not (loop :for a :in test-files :thereis (not-color-p a)))
|
||||
test-files (remove-if #'not-color-p test-files)))
|
||||
(labels ((run-tests ()
|
||||
(not
|
||||
(some #'null
|
||||
(mapcar (lambda (test-file)
|
||||
(unless (probe-file test-file)
|
||||
(print-error "test file '~A' does not exist." test-file))
|
||||
(let ((prove.output:*default-reporter*
|
||||
(or reporter
|
||||
prove.output:*default-reporter*)))
|
||||
(unless (string= (pathname-type (probe-file test-file)) "asd")
|
||||
(print-error "test file '~A' is not an asd file." test-file))
|
||||
(let ((test-file (probe-file test-file))
|
||||
(prove:*enable-colors* color))
|
||||
(#+asdf3.3 asdf::with-asdf-session
|
||||
#-asdf3.3 asdf::with-asdf-cache ()
|
||||
(asdf::load-asd test-file)
|
||||
(prove:run-test-system (asdf:find-system (pathname-name test-file)))))))
|
||||
test-files)))))
|
||||
(or #.(if (uiop:getenv "COVERALLS")
|
||||
`(,(intern (string :with-coveralls) :coveralls)
|
||||
(:exclude
|
||||
(,(intern (string :split-sequence) :split-sequence)
|
||||
#\: (or (uiop:getenv "COVERAGE_EXCLUDE") "")
|
||||
:remove-empty-subseqs t))
|
||||
(run-tests))
|
||||
'(run-tests))
|
||||
(uiop:quit -1)))))
|
||||
|
|
@ -0,0 +1,144 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.asdf
|
||||
(:nicknames :prove-asdf)
|
||||
(:use :cl
|
||||
:asdf)
|
||||
(:import-from :prove.output
|
||||
:*test-result-output*
|
||||
:*default-reporter*)
|
||||
(:export :test-file
|
||||
:run-test-system
|
||||
:run
|
||||
|
||||
:*last-suite-report*))
|
||||
(in-package :prove.asdf)
|
||||
|
||||
(defvar *last-suite-report* nil)
|
||||
|
||||
(defvar *system-test-files* (make-hash-table))
|
||||
|
||||
(defclass test-file (asdf:cl-source-file) ())
|
||||
|
||||
(defmethod asdf:perform ((op asdf:compile-op) (c test-file))
|
||||
;; do nothing
|
||||
)
|
||||
|
||||
#+asdf3
|
||||
(defmethod asdf::compute-action-stamp :around (plan (o asdf:operation) (c test-file) &key just-done)
|
||||
(declare (ignore just-done))
|
||||
(let ((*error-output* (make-broadcast-stream)))
|
||||
(call-next-method)))
|
||||
|
||||
(defmethod asdf:perform ((op asdf:load-op) (c test-file))
|
||||
(pushnew c (gethash (asdf:component-system c) *system-test-files*)
|
||||
:key #'asdf:component-pathname
|
||||
:test #'equal))
|
||||
|
||||
(defun run-test-system (system-designator)
|
||||
"Runs a testing ASDF system."
|
||||
#+quicklisp (ql:quickload (if (typep system-designator 'asdf:system)
|
||||
(asdf:component-name system-designator)
|
||||
system-designator))
|
||||
#-quicklisp (asdf:load-system system-designator)
|
||||
(let ((passed-files '()) (failed-files '()))
|
||||
(restart-case
|
||||
(dolist (c (reverse
|
||||
(gethash (asdf:find-system system-designator) *system-test-files*)))
|
||||
(setf *last-suite-report* nil)
|
||||
(format *test-result-output* "~2&Running a test file '~A'~%" (asdf:component-pathname c))
|
||||
(restart-case
|
||||
(progn
|
||||
(asdf:perform 'asdf:load-source-op c)
|
||||
(unless *last-suite-report*
|
||||
(warn "Test completed without 'finalize'd."))
|
||||
(if (eql (getf *last-suite-report* :failed) 0)
|
||||
(push (asdf:component-pathname c) passed-files)
|
||||
(push (asdf:component-pathname c) failed-files)))
|
||||
(skip-test-file ()
|
||||
:report "Skip this test file."
|
||||
(push (asdf:component-pathname c) failed-files))))
|
||||
(skip-all-test-files ()
|
||||
:report "Give up all test files."
|
||||
nil))
|
||||
(setf passed-files (nreverse passed-files)
|
||||
failed-files (nreverse failed-files))
|
||||
(format t "~2&Summary:~%")
|
||||
(if failed-files
|
||||
(format t " ~D file~:*~P failed.~{~% - ~A~}
|
||||
"
|
||||
(length failed-files)
|
||||
failed-files)
|
||||
(format t " All ~D file~:*~P passed.~%"
|
||||
(length passed-files)))
|
||||
(values (null failed-files)
|
||||
passed-files
|
||||
failed-files)))
|
||||
|
||||
(defun test-files-in-directory (directory)
|
||||
(check-type directory pathname)
|
||||
(flet ((always-true (&rest args)
|
||||
(declare (ignore args))
|
||||
T))
|
||||
(let ((directories '()))
|
||||
(#+asdf3 uiop:collect-sub*directories
|
||||
#-asdf3 asdf::collect-sub*directories
|
||||
directory
|
||||
#'always-true
|
||||
#'always-true
|
||||
(lambda (dir)
|
||||
(push dir directories)))
|
||||
(mapcan (lambda (dir)
|
||||
(#+asdf3 uiop:directory-files
|
||||
#-asdf3 asdf::directory-files dir "*.lisp"))
|
||||
(nreverse directories)))))
|
||||
|
||||
(defun run (object &key (reporter *default-reporter*))
|
||||
"Runs a test. OBJECT can be one of a file pathname, a directory pathname or an ASDF system name.
|
||||
Returns 3 multiple-values, a flag if the tests passed as T or NIL, passed test files as a list and failed test files also as a list.
|
||||
|
||||
Example:
|
||||
(prove:run :myapp-test)
|
||||
(prove:run #P\"myapp/tests/\")
|
||||
(prove:run #P\"myapp/tests/01-main.lisp\")
|
||||
"
|
||||
(check-type reporter keyword)
|
||||
(flet ((directory-pathname-p (path)
|
||||
(string= (file-namestring path) "")))
|
||||
(let ((*default-reporter* reporter))
|
||||
(cond
|
||||
((and (stringp object)
|
||||
(asdf:find-system object nil))
|
||||
(run-test-system object))
|
||||
((stringp object)
|
||||
(run (pathname object)))
|
||||
((and (pathnamep object)
|
||||
(directory-pathname-p object))
|
||||
(let ((all-passed-p T) (all-passed-files '()) (all-failed-files '()))
|
||||
(restart-case
|
||||
(dolist (file (test-files-in-directory object))
|
||||
(multiple-value-bind (passedp passed-files failed-files)
|
||||
(run file)
|
||||
(setf all-passed-files (append all-passed-files passed-files))
|
||||
(setf all-failed-files (append all-failed-files failed-files))
|
||||
(unless passedp
|
||||
(setf all-passed-p nil))))
|
||||
(skip-all-test-files ()
|
||||
:report "Give up all test files."
|
||||
nil))
|
||||
(values all-passed-p all-passed-files all-failed-files)))
|
||||
((pathnamep object)
|
||||
(setf *last-suite-report* nil)
|
||||
(restart-case
|
||||
(progn
|
||||
(load object)
|
||||
(unless *last-suite-report*
|
||||
(warn "Test completed without 'finalize'd.")))
|
||||
(skip-test-file ()
|
||||
:report "Skip this test file."
|
||||
nil))
|
||||
(if (eql (getf *last-suite-report* :failed) 0)
|
||||
(values T (list object) '())
|
||||
(values NIL '() (list object))))
|
||||
(T (run-test-system object))))))
|
||||
|
||||
(import 'test-file :asdf)
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.color
|
||||
(:use :cl)
|
||||
(:import-from :cl-ansi-text
|
||||
:generate-color-string)
|
||||
(:import-from :cl-colors
|
||||
:+gray+
|
||||
:+grey+)
|
||||
(:export :*enable-colors*
|
||||
:with-color))
|
||||
(in-package :prove.color)
|
||||
|
||||
(defvar *enable-colors*
|
||||
(not (equal (uiop:getenv "EMACS") "t"))
|
||||
"Flag whether colorize a test report. The default is T except on Emacs (SLIME).")
|
||||
|
||||
(defmacro with-gray (stream &body body)
|
||||
`(progn
|
||||
(format ,stream (cl-ansi-text::generate-color-string 90))
|
||||
(unwind-protect (progn ,@body)
|
||||
(format ,stream (cl-ansi-text::generate-color-string 0)))))
|
||||
|
||||
(defmacro with-color ((color &rest args) &body body)
|
||||
(cond
|
||||
((or (eq color :gray)
|
||||
(eq color :grey))
|
||||
`(if *enable-colors*
|
||||
(with-gray ,(or (getf args :stream) t) ,@body)
|
||||
(progn ,@body)))
|
||||
(T `(if *enable-colors*
|
||||
(if (or (eq ,color :gray)
|
||||
(eq ,color :grey)
|
||||
(eq ,color cl-colors:+gray+)
|
||||
(eq ,color cl-colors:+grey+))
|
||||
(with-gray ,(or (getf args :stream) t) ,@body)
|
||||
(cl-ansi-text:with-color (,color ,@args) ,@body))
|
||||
(progn ,@body)))))
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.output
|
||||
(:use :cl)
|
||||
(:export :*test-result-output*
|
||||
:test-result-output
|
||||
:*default-reporter*))
|
||||
(in-package :prove.output)
|
||||
|
||||
(defvar *test-result-output* (make-synonym-stream '*standard-output*))
|
||||
|
||||
;; This should be in prove.reporter,
|
||||
;; but it's here because this will also be used in prove-asdf.
|
||||
(defvar *default-reporter* :list)
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove
|
||||
(:nicknames :cl-test-more :test-more)
|
||||
(:use :cl)
|
||||
(:import-from :prove.output
|
||||
:*test-result-output*
|
||||
:*default-reporter*)
|
||||
(:import-from :prove.asdf
|
||||
:test-file
|
||||
:run-test-system
|
||||
:run)
|
||||
(:import-from :prove.test
|
||||
:*debug-on-error*
|
||||
:*default-test-function*
|
||||
:ok
|
||||
:is
|
||||
:isnt
|
||||
:is-values
|
||||
:is-print
|
||||
:is-condition
|
||||
:is-error
|
||||
:is-type
|
||||
:like
|
||||
:is-expand
|
||||
:diag
|
||||
:skip
|
||||
:pass
|
||||
:fail
|
||||
:subtest
|
||||
:deftest
|
||||
:run-test
|
||||
:run-test-package
|
||||
:run-test-all
|
||||
:remove-test
|
||||
:remove-test-all
|
||||
:*gensym-prefix*)
|
||||
(:import-from :prove.suite
|
||||
:*default-slow-threshold*
|
||||
:slow-threshold
|
||||
:plan
|
||||
:finalize
|
||||
:current-suite
|
||||
:*suite*
|
||||
:reset-suite
|
||||
:suite
|
||||
:package-suite)
|
||||
(:import-from :prove.color
|
||||
:*enable-colors*)
|
||||
(:export :*debug-on-error*
|
||||
:*test-result-output*
|
||||
:*default-test-function*
|
||||
:*default-reporter*
|
||||
:test-file
|
||||
:run-test-system
|
||||
:run
|
||||
:ok
|
||||
:is
|
||||
:isnt
|
||||
:is-values
|
||||
:is-print
|
||||
:is-condition
|
||||
:is-error
|
||||
:is-type
|
||||
:like
|
||||
:is-expand
|
||||
:diag
|
||||
:skip
|
||||
:pass
|
||||
:fail
|
||||
:subtest
|
||||
:deftest
|
||||
:run-test
|
||||
:run-test-package
|
||||
:run-test-all
|
||||
:remove-test
|
||||
:remove-test-all
|
||||
:plan
|
||||
:finalize
|
||||
:*gensym-prefix*
|
||||
:*default-slow-threshold*
|
||||
:slow-threshold
|
||||
:current-suite
|
||||
:*suite*
|
||||
:reset-suite
|
||||
:suite
|
||||
:package-suite
|
||||
:*enable-colors*))
|
||||
|
|
@ -0,0 +1,113 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.report
|
||||
(:use :cl)
|
||||
(:export :report
|
||||
:test-report
|
||||
:normal-test-report
|
||||
:passed-test-report
|
||||
:failed-test-report
|
||||
:error-test-report
|
||||
:skipped-test-report
|
||||
:comment-report
|
||||
:composed-test-report
|
||||
|
||||
:test-report-p
|
||||
:passed-report-p
|
||||
:failed-report-p
|
||||
:error-report-p
|
||||
:skipped-report-p
|
||||
|
||||
:plan
|
||||
:children
|
||||
:description
|
||||
:notp
|
||||
:got
|
||||
:got-form
|
||||
:expected
|
||||
:report-expected-label
|
||||
:duration
|
||||
:slow-threshold
|
||||
:print-error-detail))
|
||||
(in-package :prove.report)
|
||||
|
||||
(defclass report ()
|
||||
((description :type (or null string)
|
||||
:initarg :description
|
||||
:initform nil)))
|
||||
|
||||
(defclass comment-report (report) ())
|
||||
|
||||
(defclass test-report (report)
|
||||
((duration :initarg :duration
|
||||
:initform nil)
|
||||
(slow-threshold :initarg :slow-threshold)
|
||||
(print-error-detail :type boolean
|
||||
:initarg :print-error-detail
|
||||
:initform t)))
|
||||
|
||||
(defclass normal-test-report (test-report)
|
||||
((test-function :type (or function symbol)
|
||||
:initarg :test-function)
|
||||
(notp :type boolean
|
||||
:initarg :notp
|
||||
:initform nil)
|
||||
(got :initarg :got
|
||||
:initform (error ":got is required"))
|
||||
(got-form :initarg :got-form
|
||||
:initform '#:unbound)
|
||||
(expected :initarg :expected
|
||||
:initform (error ":expected is required"))
|
||||
(report-expected-label :type (or null string)
|
||||
:initarg :report-expected-label
|
||||
:initform nil)))
|
||||
|
||||
(defclass composed-test-report (test-report)
|
||||
((plan :initarg :plan
|
||||
:initform nil)
|
||||
(children :initarg :children
|
||||
:initform (make-array 0 :adjustable t :fill-pointer 0))))
|
||||
|
||||
(defclass passed-test-report (normal-test-report) ())
|
||||
(defclass failed-test-report (normal-test-report) ())
|
||||
(defclass error-test-report (failed-test-report) ())
|
||||
(defclass skipped-test-report (normal-test-report) ())
|
||||
|
||||
(defun test-report-p (report)
|
||||
(typep report 'test-report))
|
||||
|
||||
(defun passed-report-p (report)
|
||||
(typecase report
|
||||
(skipped-test-report nil)
|
||||
(passed-test-report t)
|
||||
(composed-test-report
|
||||
(every #'passed-report-p (slot-value report 'children)))
|
||||
(otherwise nil)))
|
||||
|
||||
(defun failed-report-p (report)
|
||||
(typecase report
|
||||
(skipped-test-report nil)
|
||||
(failed-test-report t)
|
||||
(composed-test-report
|
||||
(some #'failed-report-p (slot-value report 'children)))
|
||||
(otherwise nil)))
|
||||
|
||||
(defun error-report-p (report)
|
||||
(typep report 'error-test-report))
|
||||
|
||||
(defun skipped-report-p (report)
|
||||
(typecase report
|
||||
(skipped-test-report t)
|
||||
(composed-test-report
|
||||
(some #'skipped-report-p (slot-value report 'children)))
|
||||
(otherwise nil)))
|
||||
|
||||
(defmethod print-object ((report normal-test-report) stream)
|
||||
(with-slots (got notp expected description) report
|
||||
(format stream
|
||||
"#<~A RESULT: ~S, GOT: ~S, ~:[~;NOT ~]EXPECTED: ~S~:[~;~:*, DESCRIPTION: ~A~]>"
|
||||
(type-of report)
|
||||
(passed-report-p report)
|
||||
got
|
||||
notp
|
||||
expected
|
||||
description)))
|
||||
|
|
@ -0,0 +1,175 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter
|
||||
(:use :cl)
|
||||
(:import-from :prove.report
|
||||
:report
|
||||
:test-report
|
||||
:description)
|
||||
(:import-from :prove.output
|
||||
:*default-reporter*)
|
||||
(:export :*indent-level*
|
||||
:indent-space
|
||||
:format/indent
|
||||
:reporter
|
||||
:format-report
|
||||
:print-error-report
|
||||
:print-plan-report
|
||||
:print-finalize-report
|
||||
:with-additional-indent))
|
||||
(in-package :prove.reporter)
|
||||
|
||||
(defparameter *indent-level* 0
|
||||
"Level for nested test-cases output.
|
||||
Number of spaces, added for each indentation level
|
||||
is described in reporter's indent-space slot.
|
||||
|
||||
Also, macro shift-indent could be used to slightly
|
||||
indent content inside the main indentation level.
|
||||
|
||||
full-indent = indent-space * indent-level + additional-indent
|
||||
|
||||
Here is an example of the output:
|
||||
|
||||
1| x Blah minor.
|
||||
2| Next line of description:
|
||||
3|
|
||||
4| x Nested test.
|
||||
5| Also has multiline description.
|
||||
|
||||
In this example, indent-space is 4, that is why
|
||||
text on lines 1 and 4 have 4 spaces between the 'x'
|
||||
horizontally.
|
||||
|
||||
Outputting the first line \" x \", reporter sets
|
||||
*additional-indent* to 4. That is why these additional
|
||||
4 lines are prepended to the rest lines of the main
|
||||
test case description.
|
||||
|
||||
When inner testcase runs, it increments *indent-level*,
|
||||
which shifts output to another 4 spaces (indent-space)
|
||||
to the right, simultaneously resetting *additional-indent*
|
||||
to zero.
|
||||
|
||||
For nested test, reporter writes \" x \" and again,
|
||||
sets *additional-indent* to 4 and every other lines now
|
||||
shifted by 1 * 4 + 4 = 8 spaces.
|
||||
")
|
||||
|
||||
(defparameter *additional-indent* 0
|
||||
"Number of spaces to add to each line. see *indent-level* docstring for full description.")
|
||||
|
||||
(defvar *debug-indentation* nil
|
||||
"If True, then indentation will have '=' and '-' symbols for main indentaion and additional, instead of spaces.")
|
||||
|
||||
(defun indent (space &optional (count *indent-level*))
|
||||
"Creates a string with a number of spaces to indent new line
|
||||
of a test report."
|
||||
(if *debug-indentation*
|
||||
(concatenate 'string
|
||||
(make-string (* count space)
|
||||
:initial-element #\=)
|
||||
(make-string *additional-indent*
|
||||
:initial-element #\-))
|
||||
(make-string (+ (* count space)
|
||||
*additional-indent*)
|
||||
:initial-element #\space)))
|
||||
|
||||
|
||||
(defmacro with-additional-indent ((reporter stream control-string &rest format-arguments) &body body)
|
||||
(declare (ignorable reporter stream control-string))
|
||||
(let* ((need-new-line (ppcre:scan "^~&" control-string))
|
||||
(string (apply #'format nil control-string format-arguments))
|
||||
(increment (length string)))
|
||||
`(with-slots (indent-space) reporter
|
||||
(let* ((first-line-indent (indent indent-space))
|
||||
(*additional-indent* ,(if need-new-line
|
||||
increment
|
||||
`(+ *additional-indent*
|
||||
,increment))))
|
||||
(declare (ignorable first-line-indent))
|
||||
,(if need-new-line
|
||||
`(progn (fresh-line stream)
|
||||
(write-string first-line-indent ,stream)
|
||||
;; because we just started a new line, we
|
||||
;; should use format/indent to write string
|
||||
;; taking into account a main indentation level
|
||||
(format/indent ,reporter ,stream ,string))
|
||||
;; otherwise, just output our prefix
|
||||
`(write-string ,string ,stream))
|
||||
|
||||
|
||||
,@body))))
|
||||
|
||||
|
||||
|
||||
(defun format/indent (reporter stream control-string &rest format-arguments)
|
||||
"Writes a text to given stream with indentation, dictated by
|
||||
*indent-level* and *additional-indent*.
|
||||
|
||||
If first line start with ~&, then output will start from a fresh line.
|
||||
Otherwise, all lines except the first one are indented."
|
||||
|
||||
(with-slots (indent-space) reporter
|
||||
(let ((output (apply #'format nil control-string format-arguments)))
|
||||
;; if string starts with new line, then we have to add indentation
|
||||
;; otherwise we think it is already written to the stream
|
||||
(when (ppcre:scan "^~&" control-string)
|
||||
(fresh-line stream)
|
||||
(format stream (indent indent-space)))
|
||||
|
||||
;; if this (?!$) is indended to not insert spaces
|
||||
;; into empty lines, then (?m) should be inserted
|
||||
;; before
|
||||
;; TODO: make a pull-request
|
||||
(write-string (ppcre:regex-replace-all
|
||||
"(\\n)(?!$)"
|
||||
output
|
||||
(format nil "\\1~A"
|
||||
(indent indent-space)))
|
||||
stream))))
|
||||
|
||||
|
||||
(defclass reporter ()
|
||||
((indent-space :initform 2)))
|
||||
|
||||
(defun find-reporter (name)
|
||||
(make-instance
|
||||
(intern (format nil "~:@(~A~)-~A" name #.(string :reporter))
|
||||
(intern (format nil "~A.~:@(~A~)"
|
||||
#.(string :prove.reporter)
|
||||
name)
|
||||
:keyword))))
|
||||
|
||||
(defgeneric format-report (stream reporter report &rest args)
|
||||
(:method (stream (reporter null) (report report) &rest args)
|
||||
(apply #'format-report
|
||||
stream
|
||||
(find-reporter *default-reporter*)
|
||||
report
|
||||
args))
|
||||
(:method (stream (reporter reporter) (report report) &rest args)
|
||||
(declare (ignore args))
|
||||
(format/indent reporter stream "~&~A~%"
|
||||
(slot-value report 'description))))
|
||||
|
||||
(defgeneric print-error-report (reporter report stream)
|
||||
(:method ((reporter reporter) (report report) stream)
|
||||
;; Do nothing.
|
||||
)
|
||||
(:method ((reporter null) (report test-report) stream)
|
||||
(print-error-report (find-reporter *default-reporter*) report stream)))
|
||||
|
||||
(defgeneric print-plan-report (reporter num stream)
|
||||
(:method ((reporter null) num stream)
|
||||
(print-plan-report (find-reporter *default-reporter*) num stream))
|
||||
(:method ((reporter t) num stream)
|
||||
(declare (ignore reporter num))
|
||||
;; Do nothing
|
||||
))
|
||||
|
||||
(defgeneric print-finalize-report (reporter plan reports stream)
|
||||
(:method ((reporter null) plan reports stream)
|
||||
(print-finalize-report (find-reporter *default-reporter*)
|
||||
plan
|
||||
reports
|
||||
stream)))
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter.dot
|
||||
(:use :cl
|
||||
:prove.report
|
||||
:prove.reporter
|
||||
:prove.reporter.list
|
||||
:prove.color))
|
||||
(in-package :prove.reporter.dot)
|
||||
|
||||
(defclass dot-reporter (list-reporter) ())
|
||||
|
||||
(defmethod format-report (stream (reporter dot-reporter) (report comment-report) &rest args)
|
||||
(declare (ignore args))
|
||||
;; Do nothing. This reporter doesn't support 'diag'.
|
||||
)
|
||||
|
||||
(defmethod format-report (stream (reporter dot-reporter) (report test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(when (zerop *indent-level*)
|
||||
(if *enable-colors*
|
||||
(with-color ((cond
|
||||
((failed-report-p report) :red)
|
||||
((skipped-report-p report) :cyan)
|
||||
(T :gray)) :stream stream)
|
||||
(format stream (if (error-report-p report)
|
||||
"x"
|
||||
".")))
|
||||
(write-char (if (failed-report-p report) #\f #\.) stream))))
|
||||
|
||||
(defmethod print-finalize-report :before ((reporter dot-reporter) plan reports stream)
|
||||
(declare (ignore plan reports))
|
||||
(fresh-line stream))
|
||||
|
||||
(defmethod print-finalize-report :after ((reporter dot-reporter) plan reports stream)
|
||||
(let ((failed-reports (remove-if-not #'failed-report-p reports))
|
||||
(list-reporter (make-instance 'list-reporter)))
|
||||
(when failed-reports
|
||||
(format stream "~2&")
|
||||
(map nil
|
||||
(lambda (report)
|
||||
(format-report stream list-reporter report))
|
||||
failed-reports))))
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter.fiveam
|
||||
(:use :cl
|
||||
:prove.report
|
||||
:prove.reporter))
|
||||
(in-package :prove.reporter.fiveam)
|
||||
|
||||
(defclass fiveam-reporter (reporter) ())
|
||||
|
||||
(defmethod format-report (stream (reporter fiveam-reporter) (report comment-report) &rest args)
|
||||
(declare (ignore stream reporter report args))
|
||||
;; Do nothing. This reporter doesn't support 'diag'.
|
||||
)
|
||||
|
||||
(defmethod format-report (stream (reporter fiveam-reporter) (report test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(when (zerop *indent-level*)
|
||||
(write-char (if (failed-report-p report) #\f #\.) stream)))
|
||||
|
||||
(defmethod print-error-report ((reporter fiveam-reporter) (report failed-test-report) stream)
|
||||
(with-slots (description got got-form expected notp report-expected-label print-error-detail) report
|
||||
(cond
|
||||
(print-error-detail
|
||||
(format/indent reporter
|
||||
stream "~& ~:[(no description)~;~:*~A~]:~% ~S~:[~*~; => ~S~]~% is ~:[~;not ~]expected to ~:[be~;~:*~A~]~% ~S~%"
|
||||
description
|
||||
got-form
|
||||
(not (eq got got-form))
|
||||
got
|
||||
notp
|
||||
report-expected-label
|
||||
expected))
|
||||
(T (format/indent reporter stream "~& ~:[(no description)~;~:*~A~]: Failed~%"
|
||||
description)))))
|
||||
|
||||
(defmethod print-error-report ((reporter fiveam-reporter) (report composed-test-report) stream)
|
||||
(with-slots (plan children description) report
|
||||
(format/indent reporter stream "~& ~:[(no description)~;~:*~A~]:~%"
|
||||
description)
|
||||
(let ((*indent-level* (1+ *indent-level*)))
|
||||
(print-finalize-report reporter plan children stream))))
|
||||
|
||||
(defmethod print-error-report ((reporter fiveam-reporter) (report comment-report) stream)
|
||||
(format/indent reporter stream "~& ~A~%"
|
||||
(slot-value report 'description)))
|
||||
|
||||
(defmethod print-finalize-report ((reporter fiveam-reporter) plan reports stream)
|
||||
(let ((failed-count (count-if #'failed-report-p reports))
|
||||
(passed-count (count-if #'passed-report-p reports))
|
||||
(skipped-count (count-if #'skipped-report-p reports))
|
||||
(count (count-if #'test-report-p reports)))
|
||||
(format/indent reporter stream
|
||||
"~& Did ~D checks.~:[~*~; (planned ~D tests)~]~%"
|
||||
count
|
||||
(not (eql plan count))
|
||||
plan)
|
||||
(unless (zerop count)
|
||||
(format/indent reporter
|
||||
stream " Pass: ~D (~3D%)~%" passed-count (round (* (/ passed-count count) 100)))
|
||||
(unless (zerop skipped-count)
|
||||
(format/indent reporter
|
||||
stream " Skip: ~D (~3D%)~%" skipped-count (round (* (/ skipped-count count) 100))))
|
||||
(format/indent reporter
|
||||
stream " Fail: ~D (~3D%)~%" failed-count (round (* (/ failed-count count) 100))))
|
||||
(unless (zerop failed-count)
|
||||
(format/indent reporter
|
||||
stream "~2& Failure Details:~% --------------------------------~%")
|
||||
(loop for report across reports
|
||||
when (failed-report-p report)
|
||||
do (print-error-report reporter report stream)
|
||||
(format/indent reporter stream " --------------------------------~%")))))
|
||||
|
|
@ -0,0 +1,171 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter.list
|
||||
(:use :cl
|
||||
:prove.report
|
||||
:prove.reporter)
|
||||
(:import-from :prove.color
|
||||
:with-color)
|
||||
(:export :list-reporter
|
||||
:report-expected-line))
|
||||
(in-package :prove.reporter.list)
|
||||
|
||||
(defclass list-reporter (reporter) ())
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report comment-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:white :stream stream)
|
||||
(format/indent reporter stream (slot-value report 'description)))
|
||||
(terpri stream)))
|
||||
|
||||
|
||||
(defun omit-long-value (value)
|
||||
(typecase value
|
||||
(string
|
||||
(if (< 500 (length value))
|
||||
(format nil "\"~A ...\"" (subseq value 0 94))
|
||||
(prin1-to-string value)))
|
||||
(otherwise
|
||||
(let ((value (prin1-to-string value)))
|
||||
(if (< 500 (length value))
|
||||
(format nil "~A ..." (subseq value 0 96))
|
||||
value)))))
|
||||
|
||||
|
||||
(defgeneric report-expected-line (report)
|
||||
(:documentation "Reports about failed or passed test.
|
||||
Should return a string with description of what have happened.")
|
||||
|
||||
(:method ((report normal-test-report))
|
||||
(with-slots (got got-form notp report-expected-label expected) report
|
||||
(escape-tildes
|
||||
(format nil "~A is ~:[~;not ~]expected to ~:[be~;~:*~A~] ~A~:[ (got ~S)~;~*~]"
|
||||
(omit-long-value (or got-form got))
|
||||
notp
|
||||
report-expected-label
|
||||
(omit-long-value expected)
|
||||
(eq got got-form)
|
||||
got)))))
|
||||
|
||||
|
||||
(defun escape-tildes (text)
|
||||
(ppcre:regex-replace-all "~" text "~~"))
|
||||
|
||||
|
||||
(defun possible-report-description (report)
|
||||
(cond
|
||||
((slot-value report 'description)
|
||||
(format nil "~A~:[~; (Skipped)~]"
|
||||
(escape-tildes (slot-value report 'description))
|
||||
(skipped-report-p report)))
|
||||
(T (report-expected-line report))))
|
||||
|
||||
(defun print-duration (stream duration &optional slow-threshold)
|
||||
(let ((color (if slow-threshold
|
||||
(cond
|
||||
((< slow-threshold duration) :red)
|
||||
((< (/ slow-threshold 2) duration) :yellow))
|
||||
:gray)))
|
||||
(when color
|
||||
(with-color (color :stream stream)
|
||||
(format stream "(~Dms)" duration)))))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report normal-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:green :stream stream)
|
||||
(with-additional-indent (reporter stream "✓ ")
|
||||
(let ((description (possible-report-description report))
|
||||
(duration (slot-value report 'duration)))
|
||||
(when description
|
||||
(with-color (:gray :stream stream)
|
||||
(format/indent reporter stream description)))
|
||||
|
||||
(when duration
|
||||
(format stream " ")
|
||||
(print-duration stream duration (slot-value report 'slow-threshold))))
|
||||
(terpri stream)))))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report skipped-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:cyan :stream stream)
|
||||
(with-additional-indent (reporter stream "- ")
|
||||
(let ((description (possible-report-description report)))
|
||||
(when description
|
||||
(format/indent reporter stream description))))
|
||||
(terpri stream))))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report failed-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:red :stream stream)
|
||||
(with-additional-indent (reporter stream "× ")
|
||||
(let ((description (possible-report-description report))
|
||||
(duration (slot-value report 'duration)))
|
||||
(when description
|
||||
(format/indent reporter stream description))
|
||||
(when duration
|
||||
(format stream " ")
|
||||
(print-duration stream duration (slot-value report 'slow-threshold))))
|
||||
(when (slot-value report 'description)
|
||||
(format/indent reporter stream
|
||||
(concatenate 'string "~&" (report-expected-line report)))))
|
||||
(terpri stream))))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report error-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
;; format/indent
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:red :stream stream)
|
||||
(with-additional-indent (reporter stream "× ")
|
||||
(when (slot-value report 'description)
|
||||
(format/indent reporter stream "~A~%" (slot-value report 'description)))
|
||||
(format/indent reporter stream "Raised an error ~A (expected: ~S)"
|
||||
(slot-value report 'got)
|
||||
(slot-value report 'expected)))))
|
||||
(terpri stream))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report composed-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
;; Do nothing
|
||||
)
|
||||
|
||||
(defmethod print-plan-report ((reporter list-reporter) num stream)
|
||||
(when (numberp num)
|
||||
(format/indent reporter stream "~&1..~A~2%" num)))
|
||||
|
||||
(defmethod print-finalize-report ((reporter list-reporter) plan reports stream)
|
||||
(let ((failed-count (count-if #'failed-report-p reports))
|
||||
(skipped-count (count-if #'skipped-report-p reports))
|
||||
(count (count-if #'test-report-p reports)))
|
||||
(format/indent reporter stream "~2&")
|
||||
(cond
|
||||
((eq plan :unspecified)
|
||||
(with-color (:yellow :stream stream)
|
||||
(format/indent reporter stream
|
||||
"△ Tests were run but no plan was declared.~%")))
|
||||
((and plan
|
||||
(not (= count plan)))
|
||||
(with-color (:yellow :stream stream)
|
||||
(format/indent reporter stream
|
||||
"△ Looks like you planned ~D test~:*~P but ran ~A.~%"
|
||||
plan count))))
|
||||
(if (< 0 failed-count)
|
||||
(with-color (:red :stream stream)
|
||||
(format/indent reporter stream
|
||||
"× ~D of ~D test~:*~P failed"
|
||||
failed-count count))
|
||||
(with-color (:green :stream stream)
|
||||
(format/indent reporter stream
|
||||
"✓ ~D test~:*~P completed" count)))
|
||||
(format stream " ")
|
||||
(print-duration stream
|
||||
(reduce #'+
|
||||
(remove-if-not #'test-report-p reports)
|
||||
:key (lambda (report) (or (slot-value report 'duration) 0))))
|
||||
(terpri stream)
|
||||
(unless (zerop skipped-count)
|
||||
(with-color (:cyan :stream stream)
|
||||
(format/indent reporter stream "● ~D test~:*~P skipped" skipped-count))
|
||||
(terpri stream))))
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter.tap
|
||||
(:use :cl
|
||||
:prove.report
|
||||
:prove.reporter))
|
||||
(in-package :prove.reporter.tap)
|
||||
|
||||
(defclass tap-reporter (reporter)
|
||||
((indent-space :initform 4)))
|
||||
|
||||
(defmethod format-report (stream (reporter tap-reporter) (report comment-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(format/indent reporter stream "~&# ~A~%"
|
||||
(slot-value report 'description)))
|
||||
|
||||
(defmethod format-report (stream (reporter tap-reporter) (report test-report) &key count)
|
||||
(with-slots (description print-error-detail) report
|
||||
(format/indent reporter stream
|
||||
"~&~:[not ~;~]ok~:[~;~:* ~D~]~:[~;~:* - ~A~]~%"
|
||||
(or (passed-report-p report)
|
||||
(skipped-report-p report))
|
||||
count
|
||||
description)
|
||||
(print-error-report reporter report stream)))
|
||||
|
||||
(defmethod format-report (stream (reporter tap-reporter) (report skipped-test-report) &key count)
|
||||
(format/indent reporter stream
|
||||
"~&ok~:[~;~:* ~D~] - skip~:[~;~:* ~A~]~%"
|
||||
count
|
||||
(slot-value report 'description)))
|
||||
|
||||
(defmethod print-error-report ((reporter tap-reporter) (report failed-test-report) stream)
|
||||
(with-slots (got got-form expected notp report-expected-label print-error-detail) report
|
||||
(when print-error-detail
|
||||
(format/indent reporter stream
|
||||
"~&# got: ~S~:[~*~; => ~S~]~%# ~:[~;not ~]expected~:[~;~:* to ~A~]: ~S~%"
|
||||
got-form
|
||||
(not (eq got got-form))
|
||||
got
|
||||
notp
|
||||
report-expected-label
|
||||
expected))))
|
||||
|
||||
(defmethod print-plan-report ((reporter tap-reporter) num stream)
|
||||
(when (numberp num)
|
||||
(format-report stream
|
||||
reporter
|
||||
(make-instance 'report
|
||||
:description (format nil "1..~A" num)))))
|
||||
|
||||
(defmethod print-finalize-report ((reporter tap-reporter) plan reports stream)
|
||||
(let ((failed-count (count-if #'failed-report-p reports))
|
||||
(count (count-if #'test-report-p reports)))
|
||||
(cond
|
||||
((eq plan :unspecified)
|
||||
(format/indent reporter stream
|
||||
"~&# Tests were run but no plan was declared.~%"))
|
||||
((and plan
|
||||
(not (= count plan)))
|
||||
(format/indent reporter stream
|
||||
"~&# Looks like you planned ~D test~:*~P but ran ~A.~%"
|
||||
plan count)))
|
||||
(fresh-line stream)
|
||||
(if (< 0 failed-count)
|
||||
(format/indent reporter stream
|
||||
"# Looks like you failed ~D test~:*~P of ~A run."
|
||||
failed-count count)
|
||||
(format/indent reporter stream "# All ~D test~:*~P passed."
|
||||
count))
|
||||
(terpri stream)))
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.suite
|
||||
(:use :cl)
|
||||
(:import-from :prove.output
|
||||
:*test-result-output*)
|
||||
(:import-from :prove.report
|
||||
:report
|
||||
:failed-report-p)
|
||||
(:import-from :prove.reporter
|
||||
:print-plan-report
|
||||
:print-finalize-report)
|
||||
(:import-from :prove.asdf
|
||||
:*last-suite-report*)
|
||||
(:export :*suite*
|
||||
|
||||
:current-suite
|
||||
|
||||
:suite
|
||||
:package-suite
|
||||
:suite-plan
|
||||
:test-count
|
||||
:failed
|
||||
:reports
|
||||
:slow-threshold
|
||||
:*default-slow-threshold*
|
||||
|
||||
:add-report
|
||||
:plan
|
||||
:finalize))
|
||||
(in-package :prove.suite)
|
||||
|
||||
(defparameter *suite* nil)
|
||||
(defparameter *default-slow-threshold* 75)
|
||||
|
||||
(defclass suite ()
|
||||
((plan :initarg :plan
|
||||
:initform :unspecified
|
||||
:accessor suite-plan)
|
||||
(slow-threshold :initarg :slow-threshold
|
||||
:initform *default-slow-threshold*)
|
||||
(test-count :initform 0
|
||||
:accessor test-count)
|
||||
(failed :initform 0
|
||||
:accessor failed)
|
||||
(reports :initform (make-array 0 :adjustable t :fill-pointer 0)
|
||||
:accessor reports)))
|
||||
|
||||
(defun slow-threshold (&optional new-threshold)
|
||||
(if new-threshold
|
||||
(setf (slot-value (current-suite) 'slow-threshold) new-threshold)
|
||||
(slot-value (current-suite) 'slow-threshold)))
|
||||
|
||||
(defclass package-suite (suite) ())
|
||||
|
||||
(defvar *defined-suites* (make-hash-table :test 'equal))
|
||||
|
||||
(defun find-package-suite (package-designator)
|
||||
(let ((package (typecase package-designator
|
||||
(package package-designator)
|
||||
(T (find-package package-designator)))))
|
||||
(or (gethash (package-name package) *defined-suites*)
|
||||
(setf (gethash (package-name package) *defined-suites*)
|
||||
(make-instance 'package-suite)))))
|
||||
|
||||
(defun current-suite ()
|
||||
(or *suite*
|
||||
(find-package-suite *package*)))
|
||||
|
||||
(defun reset-suite (suite)
|
||||
(with-slots (test-count failed reports) suite
|
||||
(setf test-count 0)
|
||||
(setf failed 0)
|
||||
(setf reports (make-array 0 :adjustable t :fill-pointer 0))))
|
||||
|
||||
(defun add-report (report suite)
|
||||
(check-type report report)
|
||||
(when (failed-report-p report)
|
||||
(incf (slot-value suite 'failed)))
|
||||
(vector-push-extend report (slot-value suite 'reports)))
|
||||
|
||||
(defun plan (num)
|
||||
(let ((suite (current-suite)))
|
||||
(setf (slot-value suite 'plan) num)
|
||||
(reset-suite suite))
|
||||
(print-plan-report nil num *test-result-output*))
|
||||
|
||||
(defun finalize (&optional (suite (current-suite)))
|
||||
(with-slots (plan reports failed) suite
|
||||
(print-finalize-report nil plan reports *test-result-output*)
|
||||
(setf *last-suite-report*
|
||||
(list :plan plan :failed failed))
|
||||
(zerop failed)))
|
||||
|
|
@ -0,0 +1,366 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.test
|
||||
(:use :cl)
|
||||
(:import-from :prove.output
|
||||
:*test-result-output*)
|
||||
(:import-from :prove.report
|
||||
:test-report-p
|
||||
:passed-test-report
|
||||
:failed-test-report
|
||||
:error-test-report
|
||||
:skipped-test-report
|
||||
:comment-report
|
||||
:composed-test-report
|
||||
:failed-report-p
|
||||
:duration)
|
||||
(:import-from :prove.reporter
|
||||
:format-report
|
||||
:*indent-level*
|
||||
:*additional-indent*)
|
||||
(:import-from :prove.suite
|
||||
:suite
|
||||
:*suite*
|
||||
:suite-plan
|
||||
:test-count
|
||||
:failed
|
||||
:reports
|
||||
:slow-threshold
|
||||
:current-suite
|
||||
:finalize
|
||||
:add-report)
|
||||
(:import-from :alexandria
|
||||
:with-gensyms
|
||||
:once-only)
|
||||
(:export :*default-test-function*
|
||||
:*debug-on-error*
|
||||
|
||||
:ok
|
||||
:is
|
||||
:isnt
|
||||
:is-values
|
||||
:is-print
|
||||
:is-condition
|
||||
:is-error
|
||||
:is-type
|
||||
:like
|
||||
:is-expand
|
||||
:diag
|
||||
:skip
|
||||
:pass
|
||||
:fail
|
||||
:subtest
|
||||
|
||||
:*gensym-prefix*
|
||||
|
||||
:deftest
|
||||
:run-test
|
||||
:run-test-package
|
||||
:run-test-all
|
||||
:remove-test
|
||||
:remove-test-all))
|
||||
(in-package :prove.test)
|
||||
|
||||
(defvar *debug-on-error* nil)
|
||||
(defvar *default-test-function* #'equal)
|
||||
|
||||
(defun parse-description-and-test (args)
|
||||
(if (consp args)
|
||||
(case (length args)
|
||||
(1 (car args))
|
||||
(2 (if (eq :test (car args))
|
||||
(values nil (cadr args))
|
||||
(car args)))
|
||||
(t (let ((k (member :test args)))
|
||||
(case (length k)
|
||||
((0 1) (car args))
|
||||
(2 (values (car args) (cadr k)))
|
||||
(t (values (nth 2 k) (cadr k)))))))
|
||||
args))
|
||||
|
||||
(defun test (got expected args
|
||||
&key notp
|
||||
duration
|
||||
(got-form nil got-form-supplied-p)
|
||||
(test-fn *default-test-function*)
|
||||
(passed-report-class 'passed-test-report)
|
||||
(failed-report-class 'failed-test-report)
|
||||
report-expected-label
|
||||
(print-error-detail t)
|
||||
(output t))
|
||||
(multiple-value-bind (desc arg-test)
|
||||
(parse-description-and-test args)
|
||||
(let* ((test-function (or arg-test test-fn))
|
||||
(result (funcall test-function got expected))
|
||||
(result (if notp (not result) result))
|
||||
(suite (current-suite))
|
||||
(report (apply #'make-instance
|
||||
(if result
|
||||
passed-report-class
|
||||
failed-report-class)
|
||||
:duration duration
|
||||
:slow-threshold (slot-value suite 'slow-threshold)
|
||||
:test-function test-function
|
||||
:notp notp
|
||||
:got got
|
||||
:got-form (if got-form-supplied-p
|
||||
got-form
|
||||
got)
|
||||
:expected expected
|
||||
:description desc
|
||||
:print-error-detail print-error-detail
|
||||
(and report-expected-label
|
||||
(list :report-expected-label report-expected-label)))))
|
||||
(add-report report suite)
|
||||
(unless result
|
||||
(incf (failed suite)))
|
||||
(incf (test-count suite))
|
||||
(when output
|
||||
(format-report *test-result-output* nil report :count (test-count suite)))
|
||||
(values result report))))
|
||||
|
||||
(defmacro with-duration (((duration result) form) &body body)
|
||||
(with-gensyms (start end)
|
||||
`(let* ((,start (get-internal-real-time))
|
||||
(,result ,form)
|
||||
(,end (get-internal-real-time))
|
||||
(,duration (- ,end ,start)))
|
||||
,@body)))
|
||||
|
||||
(defmacro with-catching-errors ((&key description expected) &body body)
|
||||
(with-gensyms (e suite report)
|
||||
`(if *debug-on-error*
|
||||
(progn ,@body)
|
||||
(handler-case (progn ,@body)
|
||||
(error (,e)
|
||||
(let ((,suite (current-suite))
|
||||
(,report (make-instance 'error-test-report
|
||||
:got ,e
|
||||
:got-form ,e
|
||||
:expected ,expected
|
||||
:description ,description
|
||||
:duration nil)))
|
||||
(add-report ,report ,suite)
|
||||
(incf (failed ,suite))
|
||||
(incf (test-count ,suite))
|
||||
(format-report *test-result-output* nil ,report :count (test-count ,suite))))))))
|
||||
|
||||
(defmacro ok (test &optional desc)
|
||||
(with-gensyms (duration result)
|
||||
(once-only (test desc)
|
||||
`(with-catching-errors (:expected T :description ,desc)
|
||||
(with-duration ((,duration ,result) ,test)
|
||||
(test ,result t ,desc
|
||||
:duration ,duration
|
||||
:test-fn (lambda (x y)
|
||||
(eq (not (null x)) y))
|
||||
:got-form ,test))))))
|
||||
|
||||
(defmacro is (got expected &rest args)
|
||||
(with-gensyms (duration result new-args desc)
|
||||
(once-only (expected)
|
||||
`(let* ((,new-args (list ,@args))
|
||||
(,desc (parse-description-and-test ,new-args)))
|
||||
(with-catching-errors (:description ,desc :expected ,expected)
|
||||
(with-duration ((,duration ,result) ,got)
|
||||
(test ,result ,expected ,new-args
|
||||
:duration ,duration)))))))
|
||||
|
||||
(defmacro isnt (got expected &rest args)
|
||||
(with-gensyms (duration result new-args desc)
|
||||
(once-only (expected)
|
||||
`(let* ((,new-args (list ,@args))
|
||||
(,desc (parse-description-and-test ,new-args)))
|
||||
(with-catching-errors (:description ,desc :expected ,expected)
|
||||
(with-duration ((,duration ,result) ,got)
|
||||
(test ,result ,expected ,new-args
|
||||
:notp t
|
||||
:duration ,duration)))))))
|
||||
|
||||
(defmacro is-values (got expected &rest args)
|
||||
`(is (multiple-value-list ,got) ,expected ,@args))
|
||||
|
||||
(defmacro is-print (got expected &optional desc)
|
||||
(with-gensyms (output duration duration-inner)
|
||||
(once-only (expected desc)
|
||||
`(with-catching-errors (:description ,desc :expected ,expected)
|
||||
(let* (,duration
|
||||
(,output (with-output-to-string (*standard-output*)
|
||||
(with-duration ((,duration-inner ,output) ,got)
|
||||
(declare (ignore ,output))
|
||||
(setq ,duration ,duration-inner)))))
|
||||
(test ,output ,expected ,desc
|
||||
:duration ,duration
|
||||
:got-form ',got
|
||||
:test-fn #'string=
|
||||
:report-expected-label "output"))))))
|
||||
|
||||
(defmacro is-condition (form condition &optional desc)
|
||||
(with-gensyms (error duration)
|
||||
`(with-duration ((,duration ,error) (handler-case ,form
|
||||
(condition (,error) ,error)))
|
||||
(test ,error
|
||||
,(if (and (listp condition) (eq 'quote (car condition)))
|
||||
condition
|
||||
`(quote ,condition))
|
||||
,desc
|
||||
:duration ,duration
|
||||
:got-form ',form
|
||||
:test-fn #'typep
|
||||
:report-expected-label "raise a condition"))))
|
||||
|
||||
;;; alias is-error to is-condition
|
||||
(setf (macro-function 'is-error) (macro-function 'is-condition))
|
||||
|
||||
(defmacro is-type (got expected-type &optional desc)
|
||||
(with-gensyms (duration result)
|
||||
(once-only (desc expected-type)
|
||||
`(with-catching-errors (:description ,desc :expected ,expected-type)
|
||||
(with-duration ((,duration ,result) ,got)
|
||||
(test ,result ,expected-type ,desc
|
||||
:duration ,duration
|
||||
:got-form ',got
|
||||
:test-fn #'typep
|
||||
:report-expected-label "be a type of"))))))
|
||||
|
||||
(defmacro like (got regex &optional desc)
|
||||
(with-gensyms (duration result)
|
||||
(once-only (regex desc)
|
||||
`(with-catching-errors (:description ,desc :expected ,regex)
|
||||
(with-duration ((,duration ,result) ,got)
|
||||
(test ,result ,regex ,desc
|
||||
:duration ,duration
|
||||
:test-fn (lambda (x y) (not (null (ppcre:scan y x))))
|
||||
:report-expected-label "be like"))))))
|
||||
|
||||
(defvar *gensym-prefix* "$")
|
||||
(defvar *gensym-alist* nil)
|
||||
|
||||
(defun gensymp (val)
|
||||
(and (symbolp val)
|
||||
(string= (subseq (symbol-name val) 0 (length *gensym-prefix*)) *gensym-prefix*)))
|
||||
|
||||
(defgeneric gensym-tree-equal (x y)
|
||||
(:method (x y)
|
||||
(if (and (gensymp y) (symbolp x))
|
||||
(if (assoc y *gensym-alist*)
|
||||
(eq x (cdr (assoc y *gensym-alist*)))
|
||||
(unless (rassoc x *gensym-alist*)
|
||||
(setf *gensym-alist* `((,y . ,x) ,@*gensym-alist*))
|
||||
t))
|
||||
(equal x y)))
|
||||
(:method ((x cons) (y cons))
|
||||
(loop for a in x for b in y
|
||||
always (gensym-tree-equal a b))))
|
||||
|
||||
(defmacro is-expand (got expected &optional desc)
|
||||
(with-gensyms (duration expanded)
|
||||
(once-only (desc)
|
||||
`(with-duration ((,duration ,expanded) (macroexpand-1 ',got))
|
||||
(let (*gensym-alist*)
|
||||
(test ,expanded ',expected ,desc
|
||||
:duration ,duration
|
||||
:got-form ',got
|
||||
:report-expected-label "be expanded to"
|
||||
:test-fn #'gensym-tree-equal))))))
|
||||
|
||||
(defun diag (desc)
|
||||
(let ((report (make-instance 'comment-report
|
||||
:description desc)))
|
||||
(add-report report (current-suite))
|
||||
(format-report *test-result-output* nil report)))
|
||||
|
||||
(defun skip (how-many why &rest format-args)
|
||||
(check-type how-many integer)
|
||||
(dotimes (i how-many)
|
||||
(test t t (apply #'format nil why format-args)
|
||||
:passed-report-class 'skipped-test-report)))
|
||||
|
||||
(defun pass (desc)
|
||||
(test t t desc))
|
||||
|
||||
(defun fail (desc)
|
||||
(test t nil desc
|
||||
:print-error-detail nil))
|
||||
|
||||
(defun %subtest (desc body-fn)
|
||||
(diag desc)
|
||||
(let ((report
|
||||
(let ((*suite* (make-instance 'suite))
|
||||
(*indent-level* (1+ *indent-level*))
|
||||
(*additional-indent* 0))
|
||||
(if *debug-on-error*
|
||||
(funcall body-fn)
|
||||
(handler-case (funcall body-fn)
|
||||
(error (e)
|
||||
(let ((error-report
|
||||
(make-instance 'error-test-report
|
||||
:expected :non-error
|
||||
:got e
|
||||
:description (format nil "Aborted due to an error in subtest ~S" desc))))
|
||||
(add-report error-report *suite*)
|
||||
(format-report *test-result-output* nil error-report :count (test-count *suite*))))))
|
||||
(make-instance 'composed-test-report
|
||||
:duration (reduce #'+
|
||||
(remove-if-not #'test-report-p (reports *suite*))
|
||||
:key (lambda (report) (or (slot-value report 'duration) 0)))
|
||||
:plan (suite-plan *suite*)
|
||||
:description desc
|
||||
:children (reports *suite*))))
|
||||
(suite (current-suite)))
|
||||
(add-report report suite)
|
||||
(incf (test-count suite))
|
||||
(format-report *test-result-output* nil report :count (test-count suite))))
|
||||
|
||||
(defmacro subtest (desc &body body)
|
||||
`(%subtest ,desc (lambda () ,@body)))
|
||||
|
||||
(defvar *package-tests* (make-hash-table))
|
||||
|
||||
(defmacro deftest (name &body test-forms)
|
||||
(let ((tests (gensym "TESTS"))
|
||||
(test (gensym "TEST"))
|
||||
(test-fn (gensym "TEST-FN")))
|
||||
`(progn
|
||||
(unless (nth-value 1 (gethash *package* *package-tests*))
|
||||
(setf (gethash *package* *package-tests*) '()))
|
||||
(let* ((,tests (gethash *package* *package-tests*))
|
||||
(,test (assoc ',name ,tests :test #'string=))
|
||||
(,test-fn (lambda ()
|
||||
(subtest (princ-to-string ',name)
|
||||
,@test-forms))))
|
||||
(if ,test
|
||||
(rplacd ,test ,test-fn)
|
||||
(push (cons ',name ,test-fn) (gethash *package* *package-tests*)))
|
||||
',name))))
|
||||
|
||||
(defun run-test (name)
|
||||
(let ((test (assoc name
|
||||
(gethash *package* *package-tests*)
|
||||
:test #'string=)))
|
||||
(unless test
|
||||
(error "Test not found: ~S" name))
|
||||
(funcall (cdr test))))
|
||||
|
||||
(defun run-test-package (package-designator)
|
||||
(let ((*package* (typecase package-designator
|
||||
(package package-designator)
|
||||
(T (find-package package-designator)))))
|
||||
(loop for (name . test-fn) in (reverse (gethash *package* *package-tests*))
|
||||
do (funcall test-fn))
|
||||
(finalize)))
|
||||
|
||||
(defun run-test-all ()
|
||||
(maphash (lambda (package tests)
|
||||
(declare (ignore tests))
|
||||
(run-test-package package))
|
||||
*package-tests*))
|
||||
|
||||
(defun remove-test (name)
|
||||
(setf (gethash *package* *package-tests*)
|
||||
(delete name
|
||||
(gethash *package* *package-tests*)
|
||||
:key #'car
|
||||
:test #'string=)))
|
||||
|
||||
(defun remove-test-all ()
|
||||
(setf (gethash *package* *package-tests*) nil))
|
||||
|
|
@ -0,0 +1,166 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage t.prove
|
||||
(:use :cl
|
||||
:prove
|
||||
:prove.t.utils))
|
||||
(in-package :t.prove)
|
||||
|
||||
(setf *default-reporter* :list)
|
||||
|
||||
|
||||
(plan 22)
|
||||
|
||||
(test-assertion "Successful OK"
|
||||
(ok t)
|
||||
"✓ T is expected to be T")
|
||||
|
||||
|
||||
(test-assertion "Failed ok without description"
|
||||
(ok nil)
|
||||
"× NIL is expected to be T")
|
||||
|
||||
|
||||
(test-assertion "Failed ok with description"
|
||||
(ok nil "This supposed to be failed")
|
||||
"
|
||||
× This supposed to be failed
|
||||
NIL is expected to be T")
|
||||
|
||||
|
||||
(test-assertion "Simple number equality check"
|
||||
(is 1 1)
|
||||
"✓ 1 is expected to be 1")
|
||||
|
||||
|
||||
(test-assertion "String and number shouldn't be equal"
|
||||
(is "1" 1)
|
||||
"× \"1\" is expected to be 1")
|
||||
|
||||
|
||||
(test-assertion "String and number are not equal and isnt assertion returns OK"
|
||||
(isnt "1" 1)
|
||||
"✓ \"1\" is not expected to be 1")
|
||||
|
||||
|
||||
(test-assertion "Subtest with diagnostic message"
|
||||
(subtest "Subtest"
|
||||
(diag "in subtest")
|
||||
(is #\a #\a)
|
||||
(like "truth" "^true"))
|
||||
"
|
||||
Subtest
|
||||
in subtest
|
||||
✓ #\\a is expected to be #\\a
|
||||
× \"truth\" is expected to be like \"^true\"")
|
||||
|
||||
|
||||
(test-assertion "Check if (is-values ...) works propertly"
|
||||
(is-values (values 1 2 nil 3)
|
||||
'(1 2 nil 3))
|
||||
"✓ (1 2 NIL 3) is expected to be (1 2 NIL 3)")
|
||||
|
||||
|
||||
(test-assertion "Standalone diagnostic message"
|
||||
(diag "comment")
|
||||
"comment")
|
||||
|
||||
|
||||
(test-assertion "Just a pass"
|
||||
(pass "pass")
|
||||
"✓ pass")
|
||||
|
||||
|
||||
(test-assertion "Fail"
|
||||
(fail "fail")
|
||||
"
|
||||
× fail
|
||||
T is expected to be NIL")
|
||||
|
||||
|
||||
(test-assertion "Pass with parameter"
|
||||
(pass "<~S>")
|
||||
"✓ <~S>")
|
||||
|
||||
|
||||
(test-assertion "Equality for strings with formatting"
|
||||
(is "<~S>" "<~S>")
|
||||
"✓ \"<~S>\" is expected to be \"<~S>\"")
|
||||
|
||||
|
||||
(test-assertion "\"Skip\" with reason as control-string with arguments should substitute arguments"
|
||||
(skip 1 "Because ~A" 42)
|
||||
"- Because 42 (Skipped)")
|
||||
|
||||
|
||||
(test-assertion "\"Skip\" without reason have default message \"skipping\""
|
||||
(skip 1 "skipping")
|
||||
"- skipping (Skipped)")
|
||||
|
||||
|
||||
(test-assertion "Assert is-print compares form's output to standart-output"
|
||||
(is-print (princ "ABCDEFGH")
|
||||
"ABCDEFGHIJKLMNO")
|
||||
"× (PRINC \"ABCDEFGH\") is expected to output \"ABCDEFGHIJKLMNO\" (got \"ABCDEFGH\")")
|
||||
|
||||
|
||||
(test-assertion "Type assertion fails if type mismatch"
|
||||
(is-type 1 'string)
|
||||
"× 1 is expected to be a type of STRING")
|
||||
|
||||
|
||||
(test-assertion "Assertion \"is-error\" checks if condition of given type was thrown"
|
||||
(is-error (error "Raising an error") 'simple-error)
|
||||
"(?s)✓ \\(ERROR \"Raising an error\"\\) is expected to raise a condition SIMPLE-ERROR \\(got #<(a )?SIMPLE-ERROR.*>\\)")
|
||||
|
||||
|
||||
(define-condition my-condition () ())
|
||||
|
||||
(test-assertion "If condition type mismatch, \"is-error\" fails"
|
||||
(is-error (error 'my-condition) 'simple-error)
|
||||
"(?s)× \\(ERROR ('MY-CONDITION|\\(QUOTE MY-CONDITION\\))\\) is expected to raise a condition SIMPLE-ERROR \\(got #<(a T.PROVE::)?MY-CONDITION.*>\\)")
|
||||
|
||||
|
||||
(test-assertion
|
||||
"All lines of multiline description should be indented"
|
||||
(is 'blah 'blah
|
||||
"Blah with multiline
|
||||
description!")
|
||||
"
|
||||
✓ Blah with multiline
|
||||
description!")
|
||||
|
||||
|
||||
(test-assertion
|
||||
"Multiline indentation should work for nested tests"
|
||||
(subtest "Outer testcase
|
||||
with multiline
|
||||
description."
|
||||
(is 'blah 'blah
|
||||
"Blah with multiline
|
||||
description!")
|
||||
|
||||
(subtest "Inner testcase
|
||||
with multiline description."
|
||||
(is 'foo 'foo
|
||||
"Foo with multiline
|
||||
description!")))
|
||||
"
|
||||
Outer testcase
|
||||
with multiline
|
||||
description.
|
||||
✓ Blah with multiline
|
||||
description!
|
||||
Inner testcase
|
||||
with multiline description.
|
||||
✓ Foo with multiline
|
||||
description!")
|
||||
|
||||
|
||||
(test-assertion "Check finalize's output without a plan"
|
||||
(finalize)
|
||||
"
|
||||
△ Tests were run but no plan was declared.
|
||||
✓ 0 tests completed (0ms)")
|
||||
|
||||
|
||||
(finalize)
|
||||
|
|
@ -0,0 +1,118 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.t.utils
|
||||
(:use :cl)
|
||||
(:import-from :split-sequence
|
||||
:split-sequence)
|
||||
(:import-from :alexandria
|
||||
:with-gensyms)
|
||||
(:import-from :prove
|
||||
:like
|
||||
:subtest
|
||||
:is)
|
||||
(:export :test-assertion))
|
||||
(in-package :prove.t.utils)
|
||||
|
||||
|
||||
(defun empty-line-p (line)
|
||||
"Checks if line of text is empty."
|
||||
(equal line ""))
|
||||
|
||||
|
||||
(defun get-indentation (line)
|
||||
"Returns numbers of leading spaces for the line."
|
||||
(loop
|
||||
:for char :across line
|
||||
:for num-spaces :upfrom 0
|
||||
:when (not (equal char #\Space))
|
||||
:do (return num-spaces)))
|
||||
|
||||
|
||||
(defun left-remove-if (items predicate)
|
||||
"Returns list skipping leftmost items
|
||||
which match a predicate."
|
||||
(do ()
|
||||
((not (funcall predicate (car items))) items)
|
||||
(setf items (cdr items))))
|
||||
|
||||
(defun right-remove-if (items predicate)
|
||||
"Returns a new list, without rightmost items
|
||||
which match a predicate."
|
||||
(labels ((recur (items)
|
||||
(destructuring-bind (head . tail) items
|
||||
(if tail
|
||||
(let ((tail (recur tail)))
|
||||
(if tail
|
||||
(cons head tail)
|
||||
(unless (funcall predicate head)
|
||||
(list head))))
|
||||
(if (funcall predicate head)
|
||||
nil
|
||||
(list head))))))
|
||||
(recur items)))
|
||||
|
||||
|
||||
(defun deindent (text)
|
||||
"Removes empty new lines at the begining and at the end of the text,
|
||||
and removes common number of whitespaces from rest of the lines."
|
||||
(let* ((all-lines (split-sequence
|
||||
#\Newline
|
||||
text))
|
||||
;; remove empty lines at beginning
|
||||
(left-trimmed (left-remove-if
|
||||
all-lines
|
||||
#'empty-line-p))
|
||||
;; and at the end
|
||||
(lines (right-remove-if
|
||||
left-trimmed
|
||||
#'empty-line-p))
|
||||
|
||||
;; calculate common indentation
|
||||
(min-indent (apply #'min (mapcar #'get-indentation lines)))
|
||||
|
||||
;; remove common indentation from lines
|
||||
(new-lines (loop :for line :in lines
|
||||
:collect (subseq line min-indent))))
|
||||
|
||||
;; now join lines together and separate them with new-lines
|
||||
(values (format nil "~{~a~^~%~}" new-lines)
|
||||
min-indent)))
|
||||
|
||||
|
||||
(defmacro test-assertion (title body expected
|
||||
&aux (method (if (search ".*" expected)
|
||||
'like
|
||||
'is)))
|
||||
"Tests that assertion result in prove's output
|
||||
matches given regular expression.
|
||||
|
||||
Body evaluated and it's result is matched agains expected string,
|
||||
using prove:like. Dangling spaces and newlines are trimmed from
|
||||
the result before trying to match."
|
||||
|
||||
(with-gensyms (result trimmed-result deindented-expected)
|
||||
`(subtest ,title
|
||||
(let* ((,result
|
||||
;; All output during the test, should be captured
|
||||
;; to test against give regex
|
||||
(with-output-to-string
|
||||
(prove.output:*test-result-output*)
|
||||
|
||||
(let ( ;; Colors whould be turned off to
|
||||
;; prevent Prove's reporter return
|
||||
;; string with terminal sequences.
|
||||
;; This way it will be easier to compare
|
||||
;; results with usual strings
|
||||
(prove.color:*enable-colors* nil)
|
||||
;; We need to overide current suite, to prevent
|
||||
;; tested assert-that macro from modifying real testsuite.
|
||||
;; Otherwise it can increment failed or success tests count
|
||||
;; and prove will output wrong data.
|
||||
(prove.suite:*suite* (make-instance 'prove.suite:suite))
|
||||
(prove.reporter::*debug-indentation* nil))
|
||||
,body)))
|
||||
|
||||
(,trimmed-result (string-trim '(#\Space #\Newline)
|
||||
(deindent ,result)))
|
||||
(,deindented-expected (deindent ,expected)))
|
||||
(,method ,trimmed-result
|
||||
,deindented-expected)))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue