├── .gitignore ├── .travis.yml ├── README.markdown ├── cl-test-more.asd ├── images ├── dot.png ├── failed.png ├── fiveam.png ├── list.png ├── passed.png └── tap.png ├── prove-asdf.asd ├── prove-test.asd ├── prove.asd ├── roswell └── run-prove.ros ├── src ├── asdf.lisp ├── color.lisp ├── output.lisp ├── prove.lisp ├── report.lisp ├── reporter.lisp ├── reporter │ ├── dot.lisp │ ├── fiveam.lisp │ ├── list.lisp │ └── tap.lisp ├── suite.lisp └── test.lisp └── t ├── prove.lisp └── utils.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | env: 5 | global: 6 | - PATH=~/.roswell/bin:$PATH 7 | - ROSWELL_BRANCH=release 8 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 9 | matrix: 10 | - LISP=sbcl-bin 11 | - LISP=ccl-bin 12 | - LISP=ecl 13 | - LISP=abcl 14 | - LISP=allegro 15 | - LISP=cmucl 16 | - LISP=clisp 17 | 18 | matrix: 19 | allow_failures: 20 | # there is some issue with clisp, 21 | # roswell installs ASDF3, but clisp doesn't see it 22 | - env: LISP=clisp 23 | 24 | addons: 25 | apt: 26 | packages: 27 | # it is required for some reason 28 | # to install allegrocl and cmucl 29 | - libc6-i386 30 | 31 | install: 32 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh 33 | - ros install pnathan/cl-ansi-text 34 | 35 | before_script: 36 | - ros --version 37 | - ros config 38 | - ros -e '(princ (lisp-implementation-type)) 39 | (terpri) 40 | (princ (lisp-implementation-version)) 41 | (terpri) 42 | (princ *features*) 43 | (terpri)' 44 | 45 | 46 | script: 47 | # prove-asdf must be independent. 48 | - ros +Q -e '(require "asdf")' -e '(asdf:load-asd "prove-asdf.asd")' -e '(asdf:load-system :prove-asdf)' 49 | - ros -e '(asdf:load-asd "prove.asd")' -e '(ql:quickload :prove)' 50 | - ros -e '(asdf:load-asd "cl-test-more.asd")' -e '(ql:quickload :cl-test-more)' 51 | - ros -e '(ql:quickload :prove) (uiop:quit (if (prove:run-test-system :prove-test) 0 1))' 52 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # prove 2 | 3 | _This project was originally called 'CL-TEST-MORE'._ 4 | 5 | 'prove' is yet another unit testing framework for Common Lisp. 6 | 7 | The advantages of 'prove' are: 8 | 9 | * Various simple functions for testing and informative error messages 10 | * [ASDF integration](#asdf-integration) 11 | * [Extensible test reporters](#reporters) 12 | * Colorizes the report if it's available ([note for SLIME](#colorize-test-reports-on-slime)) 13 | * Reports test durations 14 | 15 | ## Quickstart 16 | 17 | ### 1. Writing a test file 18 | 19 | ```common-lisp 20 | (in-package :cl-user) 21 | (defpackage my-test 22 | (:use :cl 23 | :prove)) 24 | (in-package :my-test) 25 | 26 | (plan 3) 27 | 28 | (ok (not (find 4 '(1 2 3)))) 29 | (is 4 4) 30 | (isnt 1 #\1) 31 | 32 | (finalize) 33 | ``` 34 | 35 | ### 2. Run a test file 36 | 37 | ```common-lisp 38 | (prove:run #P"myapp/tests/my-test.lisp") 39 | (prove:run #P"myapp/tests/my-test.lisp" :reporter :list) 40 | ``` 41 | 42 | See also: [ASDF integration](#asdf-integration), [Reporters](#reporters) 43 | 44 | ### 3. Get a report 45 | 46 | ![](images/passed.png) 47 | 48 | ![](images/failed.png) 49 | 50 | ## Installation 51 | 52 | You can install 'prove' via [Quicklisp](http://www.quicklisp.org/beta/). 53 | 54 | ```common-lisp 55 | (ql:quickload :prove) 56 | ``` 57 | 58 | ## Testing functions 59 | 60 | ### (ok test &optional desc) 61 | 62 | Checks if `test` is true (non-NIL). 63 | 64 | ```common-lisp 65 | (ok 1) 66 | ;-> ✓ 1 is expected to be T 67 | ``` 68 | 69 | ### (is got expected &rest test-args) 70 | 71 | Checks if `got` is equivalent to `expected`. 72 | 73 | ```common-lisp 74 | (is 1 1) 75 | ;-> ✓ 1 is expected to be 1 76 | 77 | (is #(1 2 3) #(1 2 3)) 78 | ;-> × #(1 2 3) is expected to be #(1 2 3) 79 | 80 | (is #(1 2 3) #(1 2 3) :test #'equalp) 81 | ;-> ✓ #(1 2 3) is expected to be #(1 2 3) 82 | 83 | ;; with description 84 | (is 1 #\1 "Integer = Character ?") 85 | ;-> × Integer = Character ? 86 | ``` 87 | 88 | ### (isnt got expected &rest test-args) 89 | 90 | Checks if `got` is _not_ equivalent to `expected`. 91 | 92 | ```common-lisp 93 | (isnt 1 1) 94 | ;-> × 1 is not expected to be 1 95 | 96 | (isnt #(1 2 3) #(1 2 3)) 97 | ;-> ✓ #(1 2 3) is not expected to be #(1 2 3) 98 | ``` 99 | 100 | ### (is-values got expected &rest test-args) 101 | 102 | Checks if the multiple values of `got` is equivalent to `expected`. This is same to `(is (multiple-value-list got) expected)`. 103 | 104 | ```common-lisp 105 | (defvar *person* (make-hash-table)) 106 | 107 | (is-values (gethash :name *person*) '("Eitaro" T)) 108 | ;-> × (NIL NIL) is expected to be ("Eitaro" T) 109 | 110 | (setf (gethash :name *person*) "Eitaro") 111 | 112 | (is-values (gethash :name *person*) '("Eitaro" T)) 113 | ;-> ✓ ("Eitaro" T) is expected to be ("Eitaro" T) 114 | ``` 115 | 116 | ### (is-type got expected-type &optional desc) 117 | 118 | Checks if `got` is a type of `expected-type`. 119 | 120 | ```common-lisp 121 | (is-type #(1 2 3) 'simple-vector) 122 | ;-> ✓ #(1 2 3) is expected to be a type of SIMPLE-VECTOR (got (SIMPLE-VECTOR 3)) 123 | 124 | (is-type (make-array 0 :adjustable t) 'simple-vector) 125 | ;-> × #() is expected to be a type of SIMPLE-VECTOR (got (VECTOR T 0)) 126 | ``` 127 | 128 | ### (like got regex &optional desc) 129 | 130 | Checks if `got` matches a regular expression `regex`. 131 | 132 | ```common-lisp 133 | (like "Hatsune 39" "\\d") 134 | ;-> ✓ "Hatsune 39" is expected to be like "\\d" 135 | 136 | (like "初音ミク" "\\d") 137 | ;-> × "初音ミク" is expected to be like "\\d" 138 | ``` 139 | 140 | ### (is-print got expected &optional desc) 141 | 142 | Checks if `got` outputs `expected` to `*standard-output*` 143 | 144 | ```common-lisp 145 | (is-print (princ "Hi, there") "Hi, there") 146 | ;-> ✓ (PRINC "Hi, there") is expected to output "Hi, there" (got "Hi, there") 147 | ``` 148 | 149 | ### (is-error form condition &optional desc) 150 | 151 | Checks if `form` raises a condition and that is a subtype of `condition`. 152 | 153 | ```common-lisp 154 | (is-error (error "Something wrong") 'simple-error) 155 | ;-> ✓ (ERROR "Something wrong") is expected to raise a condition SIMPLE-ERROR (got #) 156 | 157 | (define-condition my-error (simple-error) ()) 158 | 159 | (is-error (error "Something wrong") 'my-error) 160 | ;-> × (ERROR "Something wrong") is expected to raise a condition MY-ERROR (got #) 161 | ``` 162 | 163 | ### (is-expand got expected &optional desc) 164 | 165 | Checks if `got` will be `macroexpand`ed to `expected`. 166 | 167 | ```common-lisp 168 | (is-expand (when T (princ "Hi")) (if T (progn (princ "Hi")))) 169 | ;-> ✓ (WHEN T (PRINC "Hi")) is expected to be expanded to (IF T 170 | ; (PROGN (PRINC "Hi"))) (got (IF T 171 | ; (PROGN 172 | ; (PRINC 173 | ; "Hi")) 174 | ; NIL)) 175 | ``` 176 | 177 | If a symbol that starts with "$" is contained, it will be treated as a gensym. 178 | 179 | ### (pass desc) 180 | 181 | This will always be passed. This is convenient if the test case is complicated and hard to test with `ok`. 182 | 183 | ```common-lisp 184 | (pass "Looks good") 185 | ;-> ✓ Looks good 186 | ``` 187 | 188 | ### (fail desc) 189 | 190 | This will always be failed. This is convenient if the test case is complicated and hard to test with `ok`. 191 | 192 | ```common-lisp 193 | (fail "Hopeless") 194 | ;-> × Hopeless 195 | ``` 196 | 197 | ### (skip how-many why) 198 | 199 | Skip a number of `how-many` tests and mark them passed. 200 | 201 | ```common-lisp 202 | (skip 3 "No need to test these on Mac OS X") 203 | ;-> ✓ No need to test these on Mac OS X (Skipped) 204 | ; ✓ No need to test these on Mac OS X (Skipped) 205 | ; ✓ No need to test these on Mac OS X (Skipped) 206 | ``` 207 | 208 | ### (subtest desc &body body) 209 | 210 | Run tests of `body` in a new sub test suite. 211 | 212 | ```common-lisp 213 | (subtest "Testing integers" 214 | (is 1 1) 215 | (is-type 1 'bit) 216 | (is-type 10 'fixnum)) 217 | ;-> ✓ 1 is expected to be 1 218 | ; ✓ 1 is expected to be a type of BIT (got BIT) 219 | ; ✓ 10 is expected to be a type of FIXNUM (got (INTEGER 0 4611686018427387903)) 220 | ;-> ✓ Testing integers 221 | ``` 222 | 223 | ## Other functions 224 | 225 | ### (diag desc) 226 | 227 | Outputs `desc` to a `*test-result-output*`. 228 | 229 | ```common-lisp 230 | (diag "Gonna run tests") 231 | ;-> # Gonna run tests 232 | ``` 233 | 234 | ### (plan num) 235 | 236 | 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. 237 | 238 | ### (finalize) 239 | 240 | Finalizes the current test suite and outputs the test reports. 241 | 242 | ### (slow-threshold milliseconds) 243 | 244 | Set the threshold of slow test durations for the current test suite. The default threshold value is `prove:*default-slow-threshold*`. 245 | 246 | ```common-lisp 247 | (slow-threshold 150) 248 | ``` 249 | 250 | ## Reporters 251 | 252 | You can change the test report formats by setting `prove:*default-reporter*` to `:list`, `:dot`, `:tap` or `:fiveam`. The default value is `:list`. 253 | 254 | `prove:run` also takes a keyword argument `:reporter`. 255 | 256 | ### List (Default) 257 | 258 | The `:list` repoter outputs test results list as test cases pass or fail. 259 | 260 | ![](images/list.png) 261 | 262 | ### Dot 263 | 264 | The `:dot` reporter outputs a series of dots that represent test cases, failures highlight in red, skipping in cyan. 265 | 266 | ![](images/dot.png) 267 | 268 | ### FiveAM 269 | 270 | The `:fiveam` reporter outputs test results like [FiveAM](http://common-lisp.net/project/fiveam/) does. 271 | 272 | ![](images/fiveam.png) 273 | 274 | ### TAP 275 | 276 | The `:tap` reporter outputs in [Test Anything Protocol](http://testanything.org) format. 277 | 278 | ![](images/tap.png) 279 | 280 | ## Tips 281 | 282 | ### Debugging with CL debugger 283 | 284 | Set `prove:*debug-on-error*` T for invoking CL debugger whenever getting an error during running tests. 285 | 286 | ### Colorize test reports on SLIME 287 | 288 | SLIME doesn't support to color with ANSI colors in the REPL buffer officially. 289 | 290 | You can add the feature by using [slime-repl-ansi-color.el](https://github.com/enriquefernandez/slime-repl-ansi-color). 291 | 292 | After installing it, set `prove:*enable-colors*` to `T` before running tests. 293 | 294 | ```common-lisp 295 | ;; A part of my ~/.sbclrc 296 | (ql:quickload :prove) 297 | (setf prove:*enable-colors* t) 298 | ``` 299 | 300 | The following snippet is a little bit complicated, however it would be better if you don't like to load `prove` in all sessions. 301 | 302 | ```common-lisp 303 | (defmethod asdf:perform :after ((op asdf:load-op) (c (eql (asdf:find-system :prove)))) 304 | (setf (symbol-value (intern (string :*enable-colors*) :prove)) t)) 305 | ``` 306 | 307 | ### ASDF integration 308 | 309 | Add `:defsystem-depends-on (:prove-asdf)` to your testing ASDF system to enable `:test-file` in the `:components`. 310 | 311 | `:test-file` is same as `:file` except it will be loaded only when `asdf:test-system`. 312 | 313 | ```common-lisp 314 | ;; Main ASDF system 315 | (defsystem my-app 316 | 317 | ;; ... 318 | 319 | :in-order-to ((test-op (test-op my-app-test)))) 320 | 321 | ;; Testing ASDF system 322 | (defsystem my-app-test 323 | :depends-on (:my-app 324 | :prove) 325 | :defsystem-depends-on (:prove-asdf) 326 | :components 327 | ((:test-file "my-app")) 328 | :perform (test-op :after (op c) 329 | (funcall (intern #.(string :run) :prove) c))) 330 | ``` 331 | 332 | To run tests, execute `asdf:test-system` or `prove:run` in your REPL. 333 | 334 | ```common-lisp 335 | (asdf:test-system :my-app) 336 | (asdf:test-system :my-app-test) 337 | 338 | ;; Same as 'asdf:test-system' except it returns T or NIL as the result of tests. 339 | (prove:run :my-app-test) 340 | ``` 341 | 342 | ### Changing default test function 343 | 344 | Test functions like `is` uses `prove:*default-test-function*` for testing if no `:test` argument is specified. The default value is `#'equal`. 345 | 346 | ### Changing output stream 347 | 348 | Test reports will be output to `prove:*test-result-output*`. The default value is `T`, which means `*standard-output*`. 349 | 350 | ### Running tests on Travis CI 351 | 352 | Although Common Lisp isn't supported by Travis CI officially, you can run tests by using [cl-travis](https://github.com/luismbo/cl-travis). 353 | 354 | Here's a list of `.travis.yml` from projects using `prove` on Travis CI: 355 | 356 | - [Clack](https://github.com/fukamachi/clack/blob/master/.travis.yml) 357 | - [CL-DBI](https://github.com/fukamachi/cl-dbi/blob/master/.travis.yml) 358 | - [Woo](https://github.com/fukamachi/Woo/blob/master/.travis.yml) 359 | - [fast-http](https://github.com/fukamachi/fast-http/blob/master/.travis.yml) 360 | - [defclass-std](https://github.com/EuAndreh/defclass-std/blob/master/.travis.yml) 361 | 362 | ## Bugs 363 | 364 | Please report any bugs to e.arrows@gmail.com, or post an issue to [GitHub](http://github.com/fukamachi/prove/issues). 365 | 366 | ## License 367 | 368 | Copyright (c) 2010-2014 Eitaro Fukamachi <e.arrows@gmail.com> 369 | 'prove' and CL-TEST-MORE is freely distributable under the MIT License (http://www.opensource.org/licenses/mit-license). 370 | -------------------------------------------------------------------------------- /cl-test-more.asd: -------------------------------------------------------------------------------- 1 | (defsystem "cl-test-more" 2 | :version "2.0.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("prove")) 6 | -------------------------------------------------------------------------------- /images/dot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/prove/5d71f02795b89e36f34e8c7d50e69b67ec6ca2de/images/dot.png -------------------------------------------------------------------------------- /images/failed.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/prove/5d71f02795b89e36f34e8c7d50e69b67ec6ca2de/images/failed.png -------------------------------------------------------------------------------- /images/fiveam.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/prove/5d71f02795b89e36f34e8c7d50e69b67ec6ca2de/images/fiveam.png -------------------------------------------------------------------------------- /images/list.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/prove/5d71f02795b89e36f34e8c7d50e69b67ec6ca2de/images/list.png -------------------------------------------------------------------------------- /images/passed.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/prove/5d71f02795b89e36f34e8c7d50e69b67ec6ca2de/images/passed.png -------------------------------------------------------------------------------- /images/tap.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/prove/5d71f02795b89e36f34e8c7d50e69b67ec6ca2de/images/tap.png -------------------------------------------------------------------------------- /prove-asdf.asd: -------------------------------------------------------------------------------- 1 | (defsystem "prove-asdf" 2 | :components ((:module "src" 3 | :components 4 | ((:file "asdf" :depends-on ("output")) 5 | (:file "output"))))) 6 | -------------------------------------------------------------------------------- /prove-test.asd: -------------------------------------------------------------------------------- 1 | (defsystem "prove-test" 2 | :author "Eitaro Fukamachi" 3 | :license "MIT" 4 | :depends-on (:split-sequence 5 | :alexandria 6 | :prove) 7 | :components ((:module "t" 8 | :serial t 9 | :components 10 | ((:file "utils") 11 | (:test-file "prove")))) 12 | :description "Test system for Prove." 13 | 14 | :defsystem-depends-on ("prove-asdf") 15 | :perform (test-op (o c) (symbol-call :prove-asdf :run-test-system c))) 16 | -------------------------------------------------------------------------------- /prove.asd: -------------------------------------------------------------------------------- 1 | (defsystem "prove" 2 | :version "1.0.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("cl-ppcre" 6 | "cl-ansi-text" 7 | "cl-colors" 8 | "alexandria" 9 | "uiop") 10 | :components ((:module "src" 11 | :components 12 | ((:file "prove" :depends-on ("output" "test" "suite" "asdf" "color")) 13 | (:file "test" :depends-on ("output" "report" "reporter" "suite")) 14 | (:file "report") 15 | (:file "reporter" :depends-on ("report" "output")) 16 | (:module "reporter-components" 17 | :pathname "reporter" 18 | :depends-on ("report" "reporter" "color") 19 | :components 20 | ((:file "tap") 21 | (:file "fiveam") 22 | (:file "list") 23 | (:file "dot" :depends-on ("list")))) 24 | (:file "suite" :depends-on ("output" "report" "reporter" "asdf")) 25 | (:file "asdf" :depends-on ("output" "color")) 26 | (:file "color") 27 | (:file "output"))))) 28 | -------------------------------------------------------------------------------- /roswell/run-prove.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | 7 | (unless (find-package :uiop) 8 | (ql:quickload :uiop :silent t)) 9 | 10 | (ql:quickload :prove :silent t) 11 | 12 | (when (uiop:getenv "COVERALLS") 13 | (ql:quickload '(:cl-coveralls :split-sequence) :silent t)) 14 | 15 | (defun print-error (format-string &rest format-args) 16 | (format *error-output* "~&[Error] ") 17 | (apply #'format *error-output* 18 | format-string format-args) 19 | (fresh-line *error-output*) 20 | (uiop:quit -1)) 21 | 22 | (defun main (&rest test-files) 23 | (let (reporter color) 24 | (when (or (string= (first test-files) "-r") 25 | (string= (first test-files) "--reporter")) 26 | (setf reporter (second test-files) 27 | test-files (cddr test-files))) 28 | (flet ((not-color-p (arg) (or (string= "-c" arg) 29 | (string= "--without-colors" arg)))) 30 | (setf color (not (loop :for a :in test-files :thereis (not-color-p a))) 31 | test-files (remove-if #'not-color-p test-files))) 32 | (labels ((run-tests () 33 | (not 34 | (some #'null 35 | (mapcar (lambda (test-file) 36 | (unless (probe-file test-file) 37 | (print-error "test file '~A' does not exist." test-file)) 38 | (let ((prove.output:*default-reporter* 39 | (or reporter 40 | prove.output:*default-reporter*))) 41 | (unless (string= (pathname-type (probe-file test-file)) "asd") 42 | (print-error "test file '~A' is not an asd file." test-file)) 43 | (let ((test-file (probe-file test-file)) 44 | (prove:*enable-colors* color)) 45 | (#+asdf3.3 asdf::with-asdf-session 46 | #-asdf3.3 asdf::with-asdf-cache () 47 | (asdf::load-asd test-file) 48 | (prove:run-test-system (asdf:find-system (pathname-name test-file))))))) 49 | test-files))))) 50 | (or #.(if (uiop:getenv "COVERALLS") 51 | `(,(intern (string :with-coveralls) :coveralls) 52 | (:exclude 53 | (,(intern (string :split-sequence) :split-sequence) 54 | #\: (or (uiop:getenv "COVERAGE_EXCLUDE") "") 55 | :remove-empty-subseqs t)) 56 | (run-tests)) 57 | '(run-tests)) 58 | (uiop:quit -1))))) 59 | -------------------------------------------------------------------------------- /src/asdf.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.asdf 3 | (:nicknames :prove-asdf) 4 | (:use :cl 5 | :asdf) 6 | (:import-from :prove.output 7 | :*test-result-output* 8 | :*default-reporter*) 9 | (:export :test-file 10 | :run-test-system 11 | :run 12 | 13 | :*last-suite-report*)) 14 | (in-package :prove.asdf) 15 | 16 | (defvar *last-suite-report* nil) 17 | 18 | (defvar *system-test-files* (make-hash-table)) 19 | 20 | (defclass test-file (asdf:cl-source-file) ()) 21 | 22 | (defmethod asdf:perform ((op asdf:compile-op) (c test-file)) 23 | ;; do nothing 24 | ) 25 | 26 | #+asdf3 27 | (defmethod asdf::compute-action-stamp :around (plan (o asdf:operation) (c test-file) &key just-done) 28 | (declare (ignore just-done)) 29 | (let ((*error-output* (make-broadcast-stream))) 30 | (call-next-method))) 31 | 32 | (defmethod asdf:perform ((op asdf:load-op) (c test-file)) 33 | (pushnew c (gethash (asdf:component-system c) *system-test-files*) 34 | :key #'asdf:component-pathname 35 | :test #'equal)) 36 | 37 | (defun run-test-system (system-designator) 38 | "Runs a testing ASDF system." 39 | #+quicklisp (ql:quickload (if (typep system-designator 'asdf:system) 40 | (asdf:component-name system-designator) 41 | system-designator)) 42 | #-quicklisp (asdf:load-system system-designator) 43 | (let ((passed-files '()) (failed-files '())) 44 | (restart-case 45 | (dolist (c (reverse 46 | (gethash (asdf:find-system system-designator) *system-test-files*))) 47 | (setf *last-suite-report* nil) 48 | (format *test-result-output* "~2&Running a test file '~A'~%" (asdf:component-pathname c)) 49 | (restart-case 50 | (progn 51 | (asdf:perform 'asdf:load-source-op c) 52 | (unless *last-suite-report* 53 | (warn "Test completed without 'finalize'd.")) 54 | (if (eql (getf *last-suite-report* :failed) 0) 55 | (push (asdf:component-pathname c) passed-files) 56 | (push (asdf:component-pathname c) failed-files))) 57 | (skip-test-file () 58 | :report "Skip this test file." 59 | (push (asdf:component-pathname c) failed-files)))) 60 | (skip-all-test-files () 61 | :report "Give up all test files." 62 | nil)) 63 | (setf passed-files (nreverse passed-files) 64 | failed-files (nreverse failed-files)) 65 | (format t "~2&Summary:~%") 66 | (if failed-files 67 | (format t " ~D file~:*~P failed.~{~% - ~A~} 68 | " 69 | (length failed-files) 70 | failed-files) 71 | (format t " All ~D file~:*~P passed.~%" 72 | (length passed-files))) 73 | (values (null failed-files) 74 | passed-files 75 | failed-files))) 76 | 77 | (defun test-files-in-directory (directory) 78 | (check-type directory pathname) 79 | (flet ((always-true (&rest args) 80 | (declare (ignore args)) 81 | T)) 82 | (let ((directories '())) 83 | (#+asdf3 uiop:collect-sub*directories 84 | #-asdf3 asdf::collect-sub*directories 85 | directory 86 | #'always-true 87 | #'always-true 88 | (lambda (dir) 89 | (push dir directories))) 90 | (mapcan (lambda (dir) 91 | (#+asdf3 uiop:directory-files 92 | #-asdf3 asdf::directory-files dir "*.lisp")) 93 | (nreverse directories))))) 94 | 95 | (defun run (object &key (reporter *default-reporter*)) 96 | "Runs a test. OBJECT can be one of a file pathname, a directory pathname or an ASDF system name. 97 | 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. 98 | 99 | Example: 100 | (prove:run :myapp-test) 101 | (prove:run #P\"myapp/tests/\") 102 | (prove:run #P\"myapp/tests/01-main.lisp\") 103 | " 104 | (check-type reporter keyword) 105 | (flet ((directory-pathname-p (path) 106 | (string= (file-namestring path) ""))) 107 | (let ((*default-reporter* reporter)) 108 | (cond 109 | ((and (stringp object) 110 | (asdf:find-system object nil)) 111 | (run-test-system object)) 112 | ((stringp object) 113 | (run (pathname object))) 114 | ((and (pathnamep object) 115 | (directory-pathname-p object)) 116 | (let ((all-passed-p T) (all-passed-files '()) (all-failed-files '())) 117 | (restart-case 118 | (dolist (file (test-files-in-directory object)) 119 | (multiple-value-bind (passedp passed-files failed-files) 120 | (run file) 121 | (setf all-passed-files (append all-passed-files passed-files)) 122 | (setf all-failed-files (append all-failed-files failed-files)) 123 | (unless passedp 124 | (setf all-passed-p nil)))) 125 | (skip-all-test-files () 126 | :report "Give up all test files." 127 | nil)) 128 | (values all-passed-p all-passed-files all-failed-files))) 129 | ((pathnamep object) 130 | (setf *last-suite-report* nil) 131 | (restart-case 132 | (progn 133 | (load object) 134 | (unless *last-suite-report* 135 | (warn "Test completed without 'finalize'd."))) 136 | (skip-test-file () 137 | :report "Skip this test file." 138 | nil)) 139 | (if (eql (getf *last-suite-report* :failed) 0) 140 | (values T (list object) '()) 141 | (values NIL '() (list object)))) 142 | (T (run-test-system object)))))) 143 | 144 | (import 'test-file :asdf) 145 | -------------------------------------------------------------------------------- /src/color.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.color 3 | (:use :cl) 4 | (:import-from :cl-ansi-text 5 | :make-color-string) 6 | (:import-from :cl-colors 7 | :+gray+ 8 | :+grey+) 9 | (:export :*enable-colors* 10 | :with-color)) 11 | (in-package :prove.color) 12 | 13 | (defvar *enable-colors* 14 | (not (equal (uiop:getenv "EMACS") "t")) 15 | "Flag whether colorize a test report. The default is T except on Emacs (SLIME).") 16 | 17 | (defmacro with-gray (stream &body body) 18 | `(progn 19 | (format ,stream (cl-ansi-text:make-color-string 90)) 20 | (unwind-protect (progn ,@body) 21 | (format ,stream (cl-ansi-text:make-color-string 0))))) 22 | 23 | (defmacro with-color ((color &rest args) &body body) 24 | (cond 25 | ((or (eq color :gray) 26 | (eq color :grey)) 27 | `(if *enable-colors* 28 | (with-gray ,(or (getf args :stream) t) ,@body) 29 | (progn ,@body))) 30 | (T `(if *enable-colors* 31 | (if (or (eq ,color :gray) 32 | (eq ,color :grey) 33 | (eq ,color cl-colors:+gray+) 34 | (eq ,color cl-colors:+grey+)) 35 | (with-gray ,(or (getf args :stream) t) ,@body) 36 | (cl-ansi-text:with-color (,color ,@args) ,@body)) 37 | (progn ,@body))))) 38 | -------------------------------------------------------------------------------- /src/output.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.output 3 | (:use :cl) 4 | (:export :*test-result-output* 5 | :test-result-output 6 | :*default-reporter*)) 7 | (in-package :prove.output) 8 | 9 | (defvar *test-result-output* (make-synonym-stream '*standard-output*)) 10 | 11 | ;; This should be in prove.reporter, 12 | ;; but it's here because this will also be used in prove-asdf. 13 | (defvar *default-reporter* :list) 14 | -------------------------------------------------------------------------------- /src/prove.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove 3 | (:nicknames :cl-test-more :test-more) 4 | (:use :cl) 5 | (:import-from :prove.output 6 | :*test-result-output* 7 | :*default-reporter*) 8 | (:import-from :prove.asdf 9 | :test-file 10 | :run-test-system 11 | :run) 12 | (:import-from :prove.test 13 | :*debug-on-error* 14 | :*default-test-function* 15 | :ok 16 | :is 17 | :isnt 18 | :is-values 19 | :is-print 20 | :is-condition 21 | :is-error 22 | :is-type 23 | :like 24 | :is-expand 25 | :diag 26 | :skip 27 | :pass 28 | :fail 29 | :subtest 30 | :deftest 31 | :run-test 32 | :run-test-package 33 | :run-test-all 34 | :remove-test 35 | :remove-test-all 36 | :*gensym-prefix*) 37 | (:import-from :prove.suite 38 | :*default-slow-threshold* 39 | :slow-threshold 40 | :plan 41 | :finalize 42 | :current-suite 43 | :*suite* 44 | :reset-suite 45 | :suite 46 | :package-suite) 47 | (:import-from :prove.color 48 | :*enable-colors*) 49 | (:export :*debug-on-error* 50 | :*test-result-output* 51 | :*default-test-function* 52 | :*default-reporter* 53 | :test-file 54 | :run-test-system 55 | :run 56 | :ok 57 | :is 58 | :isnt 59 | :is-values 60 | :is-print 61 | :is-condition 62 | :is-error 63 | :is-type 64 | :like 65 | :is-expand 66 | :diag 67 | :skip 68 | :pass 69 | :fail 70 | :subtest 71 | :deftest 72 | :run-test 73 | :run-test-package 74 | :run-test-all 75 | :remove-test 76 | :remove-test-all 77 | :plan 78 | :finalize 79 | :*gensym-prefix* 80 | :*default-slow-threshold* 81 | :slow-threshold 82 | :current-suite 83 | :*suite* 84 | :reset-suite 85 | :suite 86 | :package-suite 87 | :*enable-colors*)) 88 | -------------------------------------------------------------------------------- /src/report.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.report 3 | (:use :cl) 4 | (:export :report 5 | :test-report 6 | :normal-test-report 7 | :passed-test-report 8 | :failed-test-report 9 | :error-test-report 10 | :skipped-test-report 11 | :comment-report 12 | :composed-test-report 13 | 14 | :test-report-p 15 | :passed-report-p 16 | :failed-report-p 17 | :error-report-p 18 | :skipped-report-p 19 | 20 | :plan 21 | :children 22 | :description 23 | :notp 24 | :got 25 | :got-form 26 | :expected 27 | :report-expected-label 28 | :duration 29 | :slow-threshold 30 | :print-error-detail)) 31 | (in-package :prove.report) 32 | 33 | (defclass report () 34 | ((description :type (or null string) 35 | :initarg :description 36 | :initform nil))) 37 | 38 | (defclass comment-report (report) ()) 39 | 40 | (defclass test-report (report) 41 | ((duration :initarg :duration 42 | :initform nil) 43 | (slow-threshold :initarg :slow-threshold) 44 | (print-error-detail :type boolean 45 | :initarg :print-error-detail 46 | :initform t))) 47 | 48 | (defclass normal-test-report (test-report) 49 | ((test-function :type (or function symbol) 50 | :initarg :test-function) 51 | (notp :type boolean 52 | :initarg :notp 53 | :initform nil) 54 | (got :initarg :got 55 | :initform (error ":got is required")) 56 | (got-form :initarg :got-form 57 | :initform '#:unbound) 58 | (expected :initarg :expected 59 | :initform (error ":expected is required")) 60 | (report-expected-label :type (or null string) 61 | :initarg :report-expected-label 62 | :initform nil))) 63 | 64 | (defclass composed-test-report (test-report) 65 | ((plan :initarg :plan 66 | :initform nil) 67 | (children :initarg :children 68 | :initform (make-array 0 :adjustable t :fill-pointer 0)))) 69 | 70 | (defclass passed-test-report (normal-test-report) ()) 71 | (defclass failed-test-report (normal-test-report) ()) 72 | (defclass error-test-report (failed-test-report) ()) 73 | (defclass skipped-test-report (normal-test-report) ()) 74 | 75 | (defun test-report-p (report) 76 | (typep report 'test-report)) 77 | 78 | (defun passed-report-p (report) 79 | (typecase report 80 | (skipped-test-report nil) 81 | (passed-test-report t) 82 | (composed-test-report 83 | (every #'passed-report-p (slot-value report 'children))) 84 | (otherwise nil))) 85 | 86 | (defun failed-report-p (report) 87 | (typecase report 88 | (skipped-test-report nil) 89 | (failed-test-report t) 90 | (composed-test-report 91 | (some #'failed-report-p (slot-value report 'children))) 92 | (otherwise nil))) 93 | 94 | (defun error-report-p (report) 95 | (typep report 'error-test-report)) 96 | 97 | (defun skipped-report-p (report) 98 | (typecase report 99 | (skipped-test-report t) 100 | (composed-test-report 101 | (some #'skipped-report-p (slot-value report 'children))) 102 | (otherwise nil))) 103 | 104 | (defmethod print-object ((report normal-test-report) stream) 105 | (with-slots (got notp expected description) report 106 | (format stream 107 | "#<~A RESULT: ~S, GOT: ~S, ~:[~;NOT ~]EXPECTED: ~S~:[~;~:*, DESCRIPTION: ~A~]>" 108 | (type-of report) 109 | (passed-report-p report) 110 | got 111 | notp 112 | expected 113 | description))) 114 | -------------------------------------------------------------------------------- /src/reporter.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.reporter 3 | (:use :cl) 4 | (:import-from :prove.report 5 | :report 6 | :test-report 7 | :description) 8 | (:import-from :prove.output 9 | :*default-reporter*) 10 | (:export :*indent-level* 11 | :indent-space 12 | :format/indent 13 | :reporter 14 | :format-report 15 | :print-error-report 16 | :print-plan-report 17 | :print-finalize-report 18 | :with-additional-indent)) 19 | (in-package :prove.reporter) 20 | 21 | (defparameter *indent-level* 0 22 | "Level for nested test-cases output. 23 | Number of spaces, added for each indentation level 24 | is described in reporter's indent-space slot. 25 | 26 | Also, macro shift-indent could be used to slightly 27 | indent content inside the main indentation level. 28 | 29 | full-indent = indent-space * indent-level + additional-indent 30 | 31 | Here is an example of the output: 32 | 33 | 1| x Blah minor. 34 | 2| Next line of description: 35 | 3| 36 | 4| x Nested test. 37 | 5| Also has multiline description. 38 | 39 | In this example, indent-space is 4, that is why 40 | text on lines 1 and 4 have 4 spaces between the 'x' 41 | horizontally. 42 | 43 | Outputting the first line \" x \", reporter sets 44 | *additional-indent* to 4. That is why these additional 45 | 4 lines are prepended to the rest lines of the main 46 | test case description. 47 | 48 | When inner testcase runs, it increments *indent-level*, 49 | which shifts output to another 4 spaces (indent-space) 50 | to the right, simultaneously resetting *additional-indent* 51 | to zero. 52 | 53 | For nested test, reporter writes \" x \" and again, 54 | sets *additional-indent* to 4 and every other lines now 55 | shifted by 1 * 4 + 4 = 8 spaces. 56 | ") 57 | 58 | (defparameter *additional-indent* 0 59 | "Number of spaces to add to each line. see *indent-level* docstring for full description.") 60 | 61 | (defvar *debug-indentation* nil 62 | "If True, then indentation will have '=' and '-' symbols for main indentaion and additional, instead of spaces.") 63 | 64 | (defun indent (space &optional (count *indent-level*)) 65 | "Creates a string with a number of spaces to indent new line 66 | of a test report." 67 | (if *debug-indentation* 68 | (concatenate 'string 69 | (make-string (* count space) 70 | :initial-element #\=) 71 | (make-string *additional-indent* 72 | :initial-element #\-)) 73 | (make-string (+ (* count space) 74 | *additional-indent*) 75 | :initial-element #\space))) 76 | 77 | 78 | (defmacro with-additional-indent ((reporter stream control-string &rest format-arguments) &body body) 79 | (declare (ignorable reporter stream control-string)) 80 | (let* ((need-new-line (ppcre:scan "^~&" control-string)) 81 | (string (apply #'format nil control-string format-arguments)) 82 | (increment (length string))) 83 | `(with-slots (indent-space) reporter 84 | (let* ((first-line-indent (indent indent-space)) 85 | (*additional-indent* ,(if need-new-line 86 | increment 87 | `(+ *additional-indent* 88 | ,increment)))) 89 | (declare (ignorable first-line-indent)) 90 | ,(if need-new-line 91 | `(progn (fresh-line stream) 92 | (write-string first-line-indent ,stream) 93 | ;; because we just started a new line, we 94 | ;; should use format/indent to write string 95 | ;; taking into account a main indentation level 96 | (format/indent ,reporter ,stream ,string)) 97 | ;; otherwise, just output our prefix 98 | `(write-string ,string ,stream)) 99 | 100 | 101 | ,@body)))) 102 | 103 | 104 | 105 | (defun format/indent (reporter stream control-string &rest format-arguments) 106 | "Writes a text to given stream with indentation, dictated by 107 | *indent-level* and *additional-indent*. 108 | 109 | If first line start with ~&, then output will start from a fresh line. 110 | Otherwise, all lines except the first one are indented." 111 | 112 | (with-slots (indent-space) reporter 113 | (let ((output (apply #'format nil control-string format-arguments))) 114 | ;; if string starts with new line, then we have to add indentation 115 | ;; otherwise we think it is already written to the stream 116 | (when (ppcre:scan "^~&" control-string) 117 | (fresh-line stream) 118 | (format stream (indent indent-space))) 119 | 120 | ;; if this (?!$) is indended to not insert spaces 121 | ;; into empty lines, then (?m) should be inserted 122 | ;; before 123 | ;; TODO: make a pull-request 124 | (write-string (ppcre:regex-replace-all 125 | "(\\n)(?!$)" 126 | output 127 | (format nil "\\1~A" 128 | (indent indent-space))) 129 | stream)))) 130 | 131 | 132 | (defclass reporter () 133 | ((indent-space :initform 2))) 134 | 135 | (defun find-reporter (name) 136 | (make-instance 137 | (intern (format nil "~:@(~A~)-~A" name #.(string :reporter)) 138 | (intern (format nil "~A.~:@(~A~)" 139 | #.(string :prove.reporter) 140 | name) 141 | :keyword)))) 142 | 143 | (defgeneric format-report (stream reporter report &rest args) 144 | (:method (stream (reporter null) (report report) &rest args) 145 | (apply #'format-report 146 | stream 147 | (find-reporter *default-reporter*) 148 | report 149 | args)) 150 | (:method (stream (reporter reporter) (report report) &rest args) 151 | (declare (ignore args)) 152 | (format/indent reporter stream "~&~A~%" 153 | (slot-value report 'description)))) 154 | 155 | (defgeneric print-error-report (reporter report stream) 156 | (:method ((reporter reporter) (report report) stream) 157 | ;; Do nothing. 158 | ) 159 | (:method ((reporter null) (report test-report) stream) 160 | (print-error-report (find-reporter *default-reporter*) report stream))) 161 | 162 | (defgeneric print-plan-report (reporter num stream) 163 | (:method ((reporter null) num stream) 164 | (print-plan-report (find-reporter *default-reporter*) num stream)) 165 | (:method ((reporter t) num stream) 166 | (declare (ignore reporter num)) 167 | ;; Do nothing 168 | )) 169 | 170 | (defgeneric print-finalize-report (reporter plan reports stream) 171 | (:method ((reporter null) plan reports stream) 172 | (print-finalize-report (find-reporter *default-reporter*) 173 | plan 174 | reports 175 | stream))) 176 | -------------------------------------------------------------------------------- /src/reporter/dot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.reporter.dot 3 | (:use :cl 4 | :prove.report 5 | :prove.reporter 6 | :prove.reporter.list 7 | :prove.color)) 8 | (in-package :prove.reporter.dot) 9 | 10 | (defclass dot-reporter (list-reporter) ()) 11 | 12 | (defmethod format-report (stream (reporter dot-reporter) (report comment-report) &rest args) 13 | (declare (ignore args)) 14 | ;; Do nothing. This reporter doesn't support 'diag'. 15 | ) 16 | 17 | (defmethod format-report (stream (reporter dot-reporter) (report test-report) &rest args) 18 | (declare (ignore args)) 19 | (when (zerop *indent-level*) 20 | (if *enable-colors* 21 | (with-color ((cond 22 | ((failed-report-p report) :red) 23 | ((skipped-report-p report) :cyan) 24 | (T :gray)) :stream stream) 25 | (format stream (if (error-report-p report) 26 | "x" 27 | "."))) 28 | (write-char (if (failed-report-p report) #\f #\.) stream)))) 29 | 30 | (defmethod print-finalize-report :before ((reporter dot-reporter) plan reports stream) 31 | (declare (ignore plan reports)) 32 | (fresh-line stream)) 33 | 34 | (defmethod print-finalize-report :after ((reporter dot-reporter) plan reports stream) 35 | (let ((failed-reports (remove-if-not #'failed-report-p reports)) 36 | (list-reporter (make-instance 'list-reporter))) 37 | (when failed-reports 38 | (format stream "~2&") 39 | (map nil 40 | (lambda (report) 41 | (format-report stream list-reporter report)) 42 | failed-reports)))) 43 | -------------------------------------------------------------------------------- /src/reporter/fiveam.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.reporter.fiveam 3 | (:use :cl 4 | :prove.report 5 | :prove.reporter)) 6 | (in-package :prove.reporter.fiveam) 7 | 8 | (defclass fiveam-reporter (reporter) ()) 9 | 10 | (defmethod format-report (stream (reporter fiveam-reporter) (report comment-report) &rest args) 11 | (declare (ignore stream reporter report args)) 12 | ;; Do nothing. This reporter doesn't support 'diag'. 13 | ) 14 | 15 | (defmethod format-report (stream (reporter fiveam-reporter) (report test-report) &rest args) 16 | (declare (ignore args)) 17 | (when (zerop *indent-level*) 18 | (write-char (if (failed-report-p report) #\f #\.) stream))) 19 | 20 | (defmethod print-error-report ((reporter fiveam-reporter) (report failed-test-report) stream) 21 | (with-slots (description got got-form expected notp report-expected-label print-error-detail) report 22 | (cond 23 | (print-error-detail 24 | (format/indent reporter 25 | stream "~& ~:[(no description)~;~:*~A~]:~% ~S~:[~*~; => ~S~]~% is ~:[~;not ~]expected to ~:[be~;~:*~A~]~% ~S~%" 26 | description 27 | got-form 28 | (not (eq got got-form)) 29 | got 30 | notp 31 | report-expected-label 32 | expected)) 33 | (T (format/indent reporter stream "~& ~:[(no description)~;~:*~A~]: Failed~%" 34 | description))))) 35 | 36 | (defmethod print-error-report ((reporter fiveam-reporter) (report composed-test-report) stream) 37 | (with-slots (plan children description) report 38 | (format/indent reporter stream "~& ~:[(no description)~;~:*~A~]:~%" 39 | description) 40 | (let ((*indent-level* (1+ *indent-level*))) 41 | (print-finalize-report reporter plan children stream)))) 42 | 43 | (defmethod print-error-report ((reporter fiveam-reporter) (report comment-report) stream) 44 | (format/indent reporter stream "~& ~A~%" 45 | (slot-value report 'description))) 46 | 47 | (defmethod print-finalize-report ((reporter fiveam-reporter) plan reports stream) 48 | (let ((failed-count (count-if #'failed-report-p reports)) 49 | (passed-count (count-if #'passed-report-p reports)) 50 | (skipped-count (count-if #'skipped-report-p reports)) 51 | (count (count-if #'test-report-p reports))) 52 | (format/indent reporter stream 53 | "~& Did ~D checks.~:[~*~; (planned ~D tests)~]~%" 54 | count 55 | (not (eql plan count)) 56 | plan) 57 | (unless (zerop count) 58 | (format/indent reporter 59 | stream " Pass: ~D (~3D%)~%" passed-count (round (* (/ passed-count count) 100))) 60 | (unless (zerop skipped-count) 61 | (format/indent reporter 62 | stream " Skip: ~D (~3D%)~%" skipped-count (round (* (/ skipped-count count) 100)))) 63 | (format/indent reporter 64 | stream " Fail: ~D (~3D%)~%" failed-count (round (* (/ failed-count count) 100)))) 65 | (unless (zerop failed-count) 66 | (format/indent reporter 67 | stream "~2& Failure Details:~% --------------------------------~%") 68 | (loop for report across reports 69 | when (failed-report-p report) 70 | do (print-error-report reporter report stream) 71 | (format/indent reporter stream " --------------------------------~%"))))) 72 | -------------------------------------------------------------------------------- /src/reporter/list.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.reporter.list 3 | (:use :cl 4 | :prove.report 5 | :prove.reporter) 6 | (:import-from :prove.color 7 | :with-color) 8 | (:export :list-reporter 9 | :report-expected-line)) 10 | (in-package :prove.reporter.list) 11 | 12 | (defclass list-reporter (reporter) ()) 13 | 14 | (defmethod format-report (stream (reporter list-reporter) (report comment-report) &rest args) 15 | (declare (ignore args)) 16 | (with-additional-indent (reporter stream "~& ") 17 | (with-color (:white :stream stream) 18 | (format/indent reporter stream (slot-value report 'description))) 19 | (terpri stream))) 20 | 21 | 22 | (defun omit-long-value (value) 23 | (typecase value 24 | (string 25 | (if (< 500 (length value)) 26 | (format nil "\"~A ...\"" (subseq value 0 94)) 27 | (prin1-to-string value))) 28 | (otherwise 29 | (let ((value (prin1-to-string value))) 30 | (if (< 500 (length value)) 31 | (format nil "~A ..." (subseq value 0 96)) 32 | value))))) 33 | 34 | 35 | (defgeneric report-expected-line (report) 36 | (:documentation "Reports about failed or passed test. 37 | Should return a string with description of what have happened.") 38 | 39 | (:method ((report normal-test-report)) 40 | (with-slots (got got-form notp report-expected-label expected) report 41 | (escape-tildes 42 | (format nil "~A is ~:[~;not ~]expected to ~:[be~;~:*~A~] ~A~:[ (got ~S)~;~*~]" 43 | (omit-long-value (or got-form got)) 44 | notp 45 | report-expected-label 46 | (omit-long-value expected) 47 | (eq got got-form) 48 | got))))) 49 | 50 | 51 | (defun escape-tildes (text) 52 | (ppcre:regex-replace-all "~" text "~~")) 53 | 54 | 55 | (defun possible-report-description (report) 56 | (cond 57 | ((slot-value report 'description) 58 | (format nil "~A~:[~; (Skipped)~]" 59 | (escape-tildes (slot-value report 'description)) 60 | (skipped-report-p report))) 61 | (T (report-expected-line report)))) 62 | 63 | (defun print-duration (stream duration &optional slow-threshold) 64 | (let ((color (if slow-threshold 65 | (cond 66 | ((< slow-threshold duration) :red) 67 | ((< (/ slow-threshold 2) duration) :yellow)) 68 | :gray))) 69 | (when color 70 | (with-color (color :stream stream) 71 | (format stream "(~Dms)" duration))))) 72 | 73 | (defmethod format-report (stream (reporter list-reporter) (report normal-test-report) &rest args) 74 | (declare (ignore args)) 75 | (with-additional-indent (reporter stream "~& ") 76 | (with-color (:green :stream stream) 77 | (with-additional-indent (reporter stream "✓ ") 78 | (let ((description (possible-report-description report)) 79 | (duration (slot-value report 'duration))) 80 | (when description 81 | (with-color (:gray :stream stream) 82 | (format/indent reporter stream description))) 83 | 84 | (when duration 85 | (format stream " ") 86 | (print-duration stream duration (slot-value report 'slow-threshold)))) 87 | (terpri stream))))) 88 | 89 | (defmethod format-report (stream (reporter list-reporter) (report skipped-test-report) &rest args) 90 | (declare (ignore args)) 91 | (with-additional-indent (reporter stream "~& ") 92 | (with-color (:cyan :stream stream) 93 | (with-additional-indent (reporter stream "- ") 94 | (let ((description (possible-report-description report))) 95 | (when description 96 | (format/indent reporter stream description)))) 97 | (terpri stream)))) 98 | 99 | (defmethod format-report (stream (reporter list-reporter) (report failed-test-report) &rest args) 100 | (declare (ignore args)) 101 | (with-additional-indent (reporter stream "~& ") 102 | (with-color (:red :stream stream) 103 | (with-additional-indent (reporter stream "× ") 104 | (let ((description (possible-report-description report)) 105 | (duration (slot-value report 'duration))) 106 | (when description 107 | (format/indent reporter stream description)) 108 | (when duration 109 | (format stream " ") 110 | (print-duration stream duration (slot-value report 'slow-threshold)))) 111 | (when (slot-value report 'description) 112 | (format/indent reporter stream 113 | (concatenate 'string "~&" (report-expected-line report))))) 114 | (terpri stream)))) 115 | 116 | (defmethod format-report (stream (reporter list-reporter) (report error-test-report) &rest args) 117 | (declare (ignore args)) 118 | ;; format/indent 119 | (with-additional-indent (reporter stream "~& ") 120 | (with-color (:red :stream stream) 121 | (with-additional-indent (reporter stream "× ") 122 | (when (slot-value report 'description) 123 | (format/indent reporter stream "~A~%" (slot-value report 'description))) 124 | (format/indent reporter stream "Raised an error ~A (expected: ~S)" 125 | (slot-value report 'got) 126 | (slot-value report 'expected))))) 127 | (terpri stream)) 128 | 129 | (defmethod format-report (stream (reporter list-reporter) (report composed-test-report) &rest args) 130 | (declare (ignore args)) 131 | ;; Do nothing 132 | ) 133 | 134 | (defmethod print-plan-report ((reporter list-reporter) num stream) 135 | (when (numberp num) 136 | (format/indent reporter stream "~&1..~A~2%" num))) 137 | 138 | (defmethod print-finalize-report ((reporter list-reporter) plan reports stream) 139 | (let ((failed-count (count-if #'failed-report-p reports)) 140 | (skipped-count (count-if #'skipped-report-p reports)) 141 | (count (count-if #'test-report-p reports))) 142 | (format/indent reporter stream "~2&") 143 | (cond 144 | ((eq plan :unspecified) 145 | (with-color (:yellow :stream stream) 146 | (format/indent reporter stream 147 | "△ Tests were run but no plan was declared.~%"))) 148 | ((and plan 149 | (not (= count plan))) 150 | (with-color (:yellow :stream stream) 151 | (format/indent reporter stream 152 | "△ Looks like you planned ~D test~:*~P but ran ~A.~%" 153 | plan count)))) 154 | (if (< 0 failed-count) 155 | (with-color (:red :stream stream) 156 | (format/indent reporter stream 157 | "× ~D of ~D test~:*~P failed" 158 | failed-count count)) 159 | (with-color (:green :stream stream) 160 | (format/indent reporter stream 161 | "✓ ~D test~:*~P completed" count))) 162 | (format stream " ") 163 | (print-duration stream 164 | (reduce #'+ 165 | (remove-if-not #'test-report-p reports) 166 | :key (lambda (report) (or (slot-value report 'duration) 0)))) 167 | (terpri stream) 168 | (unless (zerop skipped-count) 169 | (with-color (:cyan :stream stream) 170 | (format/indent reporter stream "● ~D test~:*~P skipped" skipped-count)) 171 | (terpri stream)))) 172 | -------------------------------------------------------------------------------- /src/reporter/tap.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.reporter.tap 3 | (:use :cl 4 | :prove.report 5 | :prove.reporter)) 6 | (in-package :prove.reporter.tap) 7 | 8 | (defclass tap-reporter (reporter) 9 | ((indent-space :initform 4))) 10 | 11 | (defmethod format-report (stream (reporter tap-reporter) (report comment-report) &rest args) 12 | (declare (ignore args)) 13 | (format/indent reporter stream "~&# ~A~%" 14 | (slot-value report 'description))) 15 | 16 | (defmethod format-report (stream (reporter tap-reporter) (report test-report) &key count) 17 | (with-slots (description print-error-detail) report 18 | (format/indent reporter stream 19 | "~&~:[not ~;~]ok~:[~;~:* ~D~]~:[~;~:* - ~A~]~%" 20 | (or (passed-report-p report) 21 | (skipped-report-p report)) 22 | count 23 | description) 24 | (print-error-report reporter report stream))) 25 | 26 | (defmethod format-report (stream (reporter tap-reporter) (report skipped-test-report) &key count) 27 | (format/indent reporter stream 28 | "~&ok~:[~;~:* ~D~] - skip~:[~;~:* ~A~]~%" 29 | count 30 | (slot-value report 'description))) 31 | 32 | (defmethod print-error-report ((reporter tap-reporter) (report failed-test-report) stream) 33 | (with-slots (got got-form expected notp report-expected-label print-error-detail) report 34 | (when print-error-detail 35 | (format/indent reporter stream 36 | "~&# got: ~S~:[~*~; => ~S~]~%# ~:[~;not ~]expected~:[~;~:* to ~A~]: ~S~%" 37 | got-form 38 | (not (eq got got-form)) 39 | got 40 | notp 41 | report-expected-label 42 | expected)))) 43 | 44 | (defmethod print-plan-report ((reporter tap-reporter) num stream) 45 | (when (numberp num) 46 | (format-report stream 47 | reporter 48 | (make-instance 'report 49 | :description (format nil "1..~A" num))))) 50 | 51 | (defmethod print-finalize-report ((reporter tap-reporter) plan reports stream) 52 | (let ((failed-count (count-if #'failed-report-p reports)) 53 | (count (count-if #'test-report-p reports))) 54 | (cond 55 | ((eq plan :unspecified) 56 | (format/indent reporter stream 57 | "~&# Tests were run but no plan was declared.~%")) 58 | ((and plan 59 | (not (= count plan))) 60 | (format/indent reporter stream 61 | "~&# Looks like you planned ~D test~:*~P but ran ~A.~%" 62 | plan count))) 63 | (fresh-line stream) 64 | (if (< 0 failed-count) 65 | (format/indent reporter stream 66 | "# Looks like you failed ~D test~:*~P of ~A run." 67 | failed-count count) 68 | (format/indent reporter stream "# All ~D test~:*~P passed." 69 | count)) 70 | (terpri stream))) 71 | -------------------------------------------------------------------------------- /src/suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.suite 3 | (:use :cl) 4 | (:import-from :prove.output 5 | :*test-result-output*) 6 | (:import-from :prove.report 7 | :report 8 | :failed-report-p) 9 | (:import-from :prove.reporter 10 | :print-plan-report 11 | :print-finalize-report) 12 | (:import-from :prove.asdf 13 | :*last-suite-report*) 14 | (:export :*suite* 15 | 16 | :current-suite 17 | 18 | :suite 19 | :package-suite 20 | :suite-plan 21 | :test-count 22 | :failed 23 | :reports 24 | :slow-threshold 25 | :*default-slow-threshold* 26 | 27 | :add-report 28 | :plan 29 | :finalize)) 30 | (in-package :prove.suite) 31 | 32 | (defparameter *suite* nil) 33 | (defparameter *default-slow-threshold* 75) 34 | 35 | (defclass suite () 36 | ((plan :initarg :plan 37 | :initform :unspecified 38 | :accessor suite-plan) 39 | (slow-threshold :initarg :slow-threshold 40 | :initform *default-slow-threshold*) 41 | (test-count :initform 0 42 | :accessor test-count) 43 | (failed :initform 0 44 | :accessor failed) 45 | (reports :initform (make-array 0 :adjustable t :fill-pointer 0) 46 | :accessor reports))) 47 | 48 | (defun slow-threshold (&optional new-threshold) 49 | (if new-threshold 50 | (setf (slot-value (current-suite) 'slow-threshold) new-threshold) 51 | (slot-value (current-suite) 'slow-threshold))) 52 | 53 | (defclass package-suite (suite) ()) 54 | 55 | (defvar *defined-suites* (make-hash-table :test 'equal)) 56 | 57 | (defun find-package-suite (package-designator) 58 | (let ((package (typecase package-designator 59 | (package package-designator) 60 | (T (find-package package-designator))))) 61 | (or (gethash (package-name package) *defined-suites*) 62 | (setf (gethash (package-name package) *defined-suites*) 63 | (make-instance 'package-suite))))) 64 | 65 | (defun current-suite () 66 | (or *suite* 67 | (find-package-suite *package*))) 68 | 69 | (defun reset-suite (suite) 70 | (with-slots (test-count failed reports) suite 71 | (setf test-count 0) 72 | (setf failed 0) 73 | (setf reports (make-array 0 :adjustable t :fill-pointer 0)))) 74 | 75 | (defun add-report (report suite) 76 | (check-type report report) 77 | (when (failed-report-p report) 78 | (incf (slot-value suite 'failed))) 79 | (vector-push-extend report (slot-value suite 'reports))) 80 | 81 | (defun plan (num) 82 | (let ((suite (current-suite))) 83 | (setf (slot-value suite 'plan) num) 84 | (reset-suite suite)) 85 | (print-plan-report nil num *test-result-output*)) 86 | 87 | (defun finalize (&optional (suite (current-suite))) 88 | (with-slots (plan reports failed) suite 89 | (print-finalize-report nil plan reports *test-result-output*) 90 | (setf *last-suite-report* 91 | (list :plan plan :failed failed)) 92 | (zerop failed))) 93 | -------------------------------------------------------------------------------- /src/test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.test 3 | (:use :cl) 4 | (:import-from :prove.output 5 | :*test-result-output*) 6 | (:import-from :prove.report 7 | :test-report-p 8 | :passed-test-report 9 | :failed-test-report 10 | :error-test-report 11 | :skipped-test-report 12 | :comment-report 13 | :composed-test-report 14 | :failed-report-p 15 | :duration) 16 | (:import-from :prove.reporter 17 | :format-report 18 | :*indent-level* 19 | :*additional-indent*) 20 | (:import-from :prove.suite 21 | :suite 22 | :*suite* 23 | :suite-plan 24 | :test-count 25 | :failed 26 | :reports 27 | :slow-threshold 28 | :current-suite 29 | :finalize 30 | :add-report) 31 | (:import-from :alexandria 32 | :with-gensyms 33 | :once-only) 34 | (:export :*default-test-function* 35 | :*debug-on-error* 36 | 37 | :ok 38 | :is 39 | :isnt 40 | :is-values 41 | :is-print 42 | :is-condition 43 | :is-error 44 | :is-type 45 | :like 46 | :is-expand 47 | :diag 48 | :skip 49 | :pass 50 | :fail 51 | :subtest 52 | 53 | :*gensym-prefix* 54 | 55 | :deftest 56 | :run-test 57 | :run-test-package 58 | :run-test-all 59 | :remove-test 60 | :remove-test-all)) 61 | (in-package :prove.test) 62 | 63 | (defvar *debug-on-error* nil) 64 | (defvar *default-test-function* #'equal) 65 | 66 | (defun parse-description-and-test (args) 67 | (if (consp args) 68 | (case (length args) 69 | (1 (car args)) 70 | (2 (if (eq :test (car args)) 71 | (values nil (cadr args)) 72 | (car args))) 73 | (t (let ((k (member :test args))) 74 | (case (length k) 75 | ((0 1) (car args)) 76 | (2 (values (car args) (cadr k))) 77 | (t (values (nth 2 k) (cadr k))))))) 78 | args)) 79 | 80 | (defun test (got expected args 81 | &key notp 82 | duration 83 | (got-form nil got-form-supplied-p) 84 | (test-fn *default-test-function*) 85 | (passed-report-class 'passed-test-report) 86 | (failed-report-class 'failed-test-report) 87 | report-expected-label 88 | (print-error-detail t) 89 | (output t)) 90 | (multiple-value-bind (desc arg-test) 91 | (parse-description-and-test args) 92 | (let* ((test-function (or arg-test test-fn)) 93 | (result (funcall test-function got expected)) 94 | (result (if notp (not result) result)) 95 | (suite (current-suite)) 96 | (report (apply #'make-instance 97 | (if result 98 | passed-report-class 99 | failed-report-class) 100 | :duration duration 101 | :slow-threshold (slot-value suite 'slow-threshold) 102 | :test-function test-function 103 | :notp notp 104 | :got got 105 | :got-form (if got-form-supplied-p 106 | got-form 107 | got) 108 | :expected expected 109 | :description desc 110 | :print-error-detail print-error-detail 111 | (and report-expected-label 112 | (list :report-expected-label report-expected-label))))) 113 | (add-report report suite) 114 | (unless result 115 | (incf (failed suite))) 116 | (incf (test-count suite)) 117 | (when output 118 | (format-report *test-result-output* nil report :count (test-count suite))) 119 | (values result report)))) 120 | 121 | (defmacro with-duration (((duration result) form) &body body) 122 | (with-gensyms (start end) 123 | `(let* ((,start (get-internal-real-time)) 124 | (,result ,form) 125 | (,end (get-internal-real-time)) 126 | (,duration (- ,end ,start))) 127 | ,@body))) 128 | 129 | (defmacro with-catching-errors ((&key description expected) &body body) 130 | (with-gensyms (e suite report) 131 | `(if *debug-on-error* 132 | (progn ,@body) 133 | (handler-case (progn ,@body) 134 | (error (,e) 135 | (let ((,suite (current-suite)) 136 | (,report (make-instance 'error-test-report 137 | :got ,e 138 | :got-form ,e 139 | :expected ,expected 140 | :description ,description 141 | :duration nil))) 142 | (add-report ,report ,suite) 143 | (incf (failed ,suite)) 144 | (incf (test-count ,suite)) 145 | (format-report *test-result-output* nil ,report :count (test-count ,suite)))))))) 146 | 147 | (defmacro ok (test &optional desc) 148 | (with-gensyms (duration result) 149 | (once-only (test desc) 150 | `(with-catching-errors (:expected T :description ,desc) 151 | (with-duration ((,duration ,result) ,test) 152 | (test ,result t ,desc 153 | :duration ,duration 154 | :test-fn (lambda (x y) 155 | (eq (not (null x)) y)) 156 | :got-form ,test)))))) 157 | 158 | (defmacro is (got expected &rest args) 159 | (with-gensyms (duration result new-args desc) 160 | (once-only (expected) 161 | `(let* ((,new-args (list ,@args)) 162 | (,desc (parse-description-and-test ,new-args))) 163 | (with-catching-errors (:description ,desc :expected ,expected) 164 | (with-duration ((,duration ,result) ,got) 165 | (test ,result ,expected ,new-args 166 | :duration ,duration))))))) 167 | 168 | (defmacro isnt (got expected &rest args) 169 | (with-gensyms (duration result new-args desc) 170 | (once-only (expected) 171 | `(let* ((,new-args (list ,@args)) 172 | (,desc (parse-description-and-test ,new-args))) 173 | (with-catching-errors (:description ,desc :expected ,expected) 174 | (with-duration ((,duration ,result) ,got) 175 | (test ,result ,expected ,new-args 176 | :notp t 177 | :duration ,duration))))))) 178 | 179 | (defmacro is-values (got expected &rest args) 180 | `(is (multiple-value-list ,got) ,expected ,@args)) 181 | 182 | (defmacro is-print (got expected &optional desc) 183 | (with-gensyms (output duration duration-inner) 184 | (once-only (expected desc) 185 | `(with-catching-errors (:description ,desc :expected ,expected) 186 | (let* (,duration 187 | (,output (with-output-to-string (*standard-output*) 188 | (with-duration ((,duration-inner ,output) ,got) 189 | (declare (ignore ,output)) 190 | (setq ,duration ,duration-inner))))) 191 | (test ,output ,expected ,desc 192 | :duration ,duration 193 | :got-form ',got 194 | :test-fn #'string= 195 | :report-expected-label "output")))))) 196 | 197 | (defmacro is-condition (form condition &optional desc) 198 | (with-gensyms (error duration) 199 | `(with-duration ((,duration ,error) (handler-case ,form 200 | (condition (,error) ,error))) 201 | (test ,error 202 | ,(if (and (listp condition) (eq 'quote (car condition))) 203 | condition 204 | `(quote ,condition)) 205 | ,desc 206 | :duration ,duration 207 | :got-form ',form 208 | :test-fn #'typep 209 | :report-expected-label "raise a condition")))) 210 | 211 | ;;; alias is-error to is-condition 212 | (setf (macro-function 'is-error) (macro-function 'is-condition)) 213 | 214 | (defmacro is-type (got expected-type &optional desc) 215 | (with-gensyms (duration result) 216 | (once-only (desc expected-type) 217 | `(with-catching-errors (:description ,desc :expected ,expected-type) 218 | (with-duration ((,duration ,result) ,got) 219 | (test ,result ,expected-type ,desc 220 | :duration ,duration 221 | :got-form ',got 222 | :test-fn #'typep 223 | :report-expected-label "be a type of")))))) 224 | 225 | (defmacro like (got regex &optional desc) 226 | (with-gensyms (duration result) 227 | (once-only (regex desc) 228 | `(with-catching-errors (:description ,desc :expected ,regex) 229 | (with-duration ((,duration ,result) ,got) 230 | (test ,result ,regex ,desc 231 | :duration ,duration 232 | :test-fn (lambda (x y) (not (null (ppcre:scan y x)))) 233 | :report-expected-label "be like")))))) 234 | 235 | (defvar *gensym-prefix* "$") 236 | (defvar *gensym-alist* nil) 237 | 238 | (defun gensymp (val) 239 | (and (symbolp val) 240 | (string= (subseq (symbol-name val) 0 (length *gensym-prefix*)) *gensym-prefix*))) 241 | 242 | (defgeneric gensym-tree-equal (x y) 243 | (:method (x y) 244 | (if (and (gensymp y) (symbolp x)) 245 | (if (assoc y *gensym-alist*) 246 | (eq x (cdr (assoc y *gensym-alist*))) 247 | (unless (rassoc x *gensym-alist*) 248 | (setf *gensym-alist* `((,y . ,x) ,@*gensym-alist*)) 249 | t)) 250 | (equal x y))) 251 | (:method ((x cons) (y cons)) 252 | (loop for a in x for b in y 253 | always (gensym-tree-equal a b)))) 254 | 255 | (defmacro is-expand (got expected &optional desc) 256 | (with-gensyms (duration expanded) 257 | (once-only (desc) 258 | `(with-duration ((,duration ,expanded) (macroexpand-1 ',got)) 259 | (let (*gensym-alist*) 260 | (test ,expanded ',expected ,desc 261 | :duration ,duration 262 | :got-form ',got 263 | :report-expected-label "be expanded to" 264 | :test-fn #'gensym-tree-equal)))))) 265 | 266 | (defun diag (desc) 267 | (let ((report (make-instance 'comment-report 268 | :description desc))) 269 | (add-report report (current-suite)) 270 | (format-report *test-result-output* nil report))) 271 | 272 | (defun skip (how-many why &rest format-args) 273 | (check-type how-many integer) 274 | (dotimes (i how-many) 275 | (test t t (apply #'format nil why format-args) 276 | :passed-report-class 'skipped-test-report))) 277 | 278 | (defun pass (desc) 279 | (test t t desc)) 280 | 281 | (defun fail (desc) 282 | (test t nil desc 283 | :print-error-detail nil)) 284 | 285 | (defun %subtest (desc body-fn) 286 | (diag desc) 287 | (let ((report 288 | (let ((*suite* (make-instance 'suite)) 289 | (*indent-level* (1+ *indent-level*)) 290 | (*additional-indent* 0)) 291 | (if *debug-on-error* 292 | (funcall body-fn) 293 | (handler-case (funcall body-fn) 294 | (error (e) 295 | (let ((error-report 296 | (make-instance 'error-test-report 297 | :expected :non-error 298 | :got e 299 | :description (format nil "Aborted due to an error in subtest ~S" desc)))) 300 | (add-report error-report *suite*) 301 | (format-report *test-result-output* nil error-report :count (test-count *suite*)))))) 302 | (make-instance 'composed-test-report 303 | :duration (reduce #'+ 304 | (remove-if-not #'test-report-p (reports *suite*)) 305 | :key (lambda (report) (or (slot-value report 'duration) 0))) 306 | :plan (suite-plan *suite*) 307 | :description desc 308 | :children (reports *suite*)))) 309 | (suite (current-suite))) 310 | (add-report report suite) 311 | (incf (test-count suite)) 312 | (format-report *test-result-output* nil report :count (test-count suite)))) 313 | 314 | (defmacro subtest (desc &body body) 315 | `(%subtest ,desc (lambda () ,@body))) 316 | 317 | (defvar *package-tests* (make-hash-table)) 318 | 319 | (defmacro deftest (name &body test-forms) 320 | (let ((tests (gensym "TESTS")) 321 | (test (gensym "TEST")) 322 | (test-fn (gensym "TEST-FN"))) 323 | `(progn 324 | (unless (nth-value 1 (gethash *package* *package-tests*)) 325 | (setf (gethash *package* *package-tests*) '())) 326 | (let* ((,tests (gethash *package* *package-tests*)) 327 | (,test (assoc ',name ,tests :test #'string=)) 328 | (,test-fn (lambda () 329 | (subtest (princ-to-string ',name) 330 | ,@test-forms)))) 331 | (if ,test 332 | (rplacd ,test ,test-fn) 333 | (push (cons ',name ,test-fn) (gethash *package* *package-tests*))) 334 | ',name)))) 335 | 336 | (defun run-test (name) 337 | (let ((test (assoc name 338 | (gethash *package* *package-tests*) 339 | :test #'string=))) 340 | (unless test 341 | (error "Test not found: ~S" name)) 342 | (funcall (cdr test)))) 343 | 344 | (defun run-test-package (package-designator) 345 | (let ((*package* (typecase package-designator 346 | (package package-designator) 347 | (T (find-package package-designator))))) 348 | (loop for (name . test-fn) in (reverse (gethash *package* *package-tests*)) 349 | do (funcall test-fn)) 350 | (finalize))) 351 | 352 | (defun run-test-all () 353 | (maphash (lambda (package tests) 354 | (declare (ignore tests)) 355 | (run-test-package package)) 356 | *package-tests*)) 357 | 358 | (defun remove-test (name) 359 | (setf (gethash *package* *package-tests*) 360 | (delete name 361 | (gethash *package* *package-tests*) 362 | :key #'car 363 | :test #'string=))) 364 | 365 | (defun remove-test-all () 366 | (setf (gethash *package* *package-tests*) nil)) 367 | -------------------------------------------------------------------------------- /t/prove.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage t.prove 3 | (:use :cl 4 | :prove 5 | :prove.t.utils)) 6 | (in-package :t.prove) 7 | 8 | (setf *default-reporter* :list) 9 | 10 | 11 | (plan 22) 12 | 13 | (test-assertion "Successful OK" 14 | (ok t) 15 | "✓ T is expected to be T") 16 | 17 | 18 | (test-assertion "Failed ok without description" 19 | (ok nil) 20 | "× NIL is expected to be T") 21 | 22 | 23 | (test-assertion "Failed ok with description" 24 | (ok nil "This supposed to be failed") 25 | " 26 | × This supposed to be failed 27 | NIL is expected to be T") 28 | 29 | 30 | (test-assertion "Simple number equality check" 31 | (is 1 1) 32 | "✓ 1 is expected to be 1") 33 | 34 | 35 | (test-assertion "String and number shouldn't be equal" 36 | (is "1" 1) 37 | "× \"1\" is expected to be 1") 38 | 39 | 40 | (test-assertion "String and number are not equal and isnt assertion returns OK" 41 | (isnt "1" 1) 42 | "✓ \"1\" is not expected to be 1") 43 | 44 | 45 | (test-assertion "Subtest with diagnostic message" 46 | (subtest "Subtest" 47 | (diag "in subtest") 48 | (is #\a #\a) 49 | (like "truth" "^true")) 50 | " 51 | Subtest 52 | in subtest 53 | ✓ #\\a is expected to be #\\a 54 | × \"truth\" is expected to be like \"^true\"") 55 | 56 | 57 | (test-assertion "Check if (is-values ...) works propertly" 58 | (is-values (values 1 2 nil 3) 59 | '(1 2 nil 3)) 60 | "✓ (1 2 NIL 3) is expected to be (1 2 NIL 3)") 61 | 62 | 63 | (test-assertion "Standalone diagnostic message" 64 | (diag "comment") 65 | "comment") 66 | 67 | 68 | (test-assertion "Just a pass" 69 | (pass "pass") 70 | "✓ pass") 71 | 72 | 73 | (test-assertion "Fail" 74 | (fail "fail") 75 | " 76 | × fail 77 | T is expected to be NIL") 78 | 79 | 80 | (test-assertion "Pass with parameter" 81 | (pass "<~S>") 82 | "✓ <~S>") 83 | 84 | 85 | (test-assertion "Equality for strings with formatting" 86 | (is "<~S>" "<~S>") 87 | "✓ \"<~S>\" is expected to be \"<~S>\"") 88 | 89 | 90 | (test-assertion "\"Skip\" with reason as control-string with arguments should substitute arguments" 91 | (skip 1 "Because ~A" 42) 92 | "- Because 42 (Skipped)") 93 | 94 | 95 | (test-assertion "\"Skip\" without reason have default message \"skipping\"" 96 | (skip 1 "skipping") 97 | "- skipping (Skipped)") 98 | 99 | 100 | (test-assertion "Assert is-print compares form's output to standart-output" 101 | (is-print (princ "ABCDEFGH") 102 | "ABCDEFGHIJKLMNO") 103 | "× (PRINC \"ABCDEFGH\") is expected to output \"ABCDEFGHIJKLMNO\" (got \"ABCDEFGH\")") 104 | 105 | 106 | (test-assertion "Type assertion fails if type mismatch" 107 | (is-type 1 'string) 108 | "× 1 is expected to be a type of STRING") 109 | 110 | 111 | (test-assertion "Assertion \"is-error\" checks if condition of given type was thrown" 112 | (is-error (error "Raising an error") 'simple-error) 113 | "(?s)✓ \\(ERROR \"Raising an error\"\\) is expected to raise a condition SIMPLE-ERROR \\(got #<(a )?SIMPLE-ERROR.*>\\)") 114 | 115 | 116 | (define-condition my-condition () ()) 117 | 118 | (test-assertion "If condition type mismatch, \"is-error\" fails" 119 | (is-error (error 'my-condition) 'simple-error) 120 | "(?s)× \\(ERROR ('MY-CONDITION|\\(QUOTE MY-CONDITION\\))\\) is expected to raise a condition SIMPLE-ERROR \\(got #<(a T.PROVE::)?MY-CONDITION.*>\\)") 121 | 122 | 123 | (test-assertion 124 | "All lines of multiline description should be indented" 125 | (is 'blah 'blah 126 | "Blah with multiline 127 | description!") 128 | " 129 | ✓ Blah with multiline 130 | description!") 131 | 132 | 133 | (test-assertion 134 | "Multiline indentation should work for nested tests" 135 | (subtest "Outer testcase 136 | with multiline 137 | description." 138 | (is 'blah 'blah 139 | "Blah with multiline 140 | description!") 141 | 142 | (subtest "Inner testcase 143 | with multiline description." 144 | (is 'foo 'foo 145 | "Foo with multiline 146 | description!"))) 147 | " 148 | Outer testcase 149 | with multiline 150 | description. 151 | ✓ Blah with multiline 152 | description! 153 | Inner testcase 154 | with multiline description. 155 | ✓ Foo with multiline 156 | description!") 157 | 158 | 159 | (test-assertion "Check finalize's output without a plan" 160 | (finalize) 161 | " 162 | △ Tests were run but no plan was declared. 163 | ✓ 0 tests completed (0ms)") 164 | 165 | 166 | (finalize) 167 | -------------------------------------------------------------------------------- /t/utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage prove.t.utils 3 | (:use :cl) 4 | (:import-from :split-sequence 5 | :split-sequence) 6 | (:import-from :alexandria 7 | :with-gensyms) 8 | (:import-from :prove 9 | :like 10 | :subtest 11 | :is) 12 | (:export :test-assertion)) 13 | (in-package :prove.t.utils) 14 | 15 | 16 | (defun empty-line-p (line) 17 | "Checks if line of text is empty." 18 | (equal line "")) 19 | 20 | 21 | (defun get-indentation (line) 22 | "Returns numbers of leading spaces for the line." 23 | (loop 24 | :for char :across line 25 | :for num-spaces :upfrom 0 26 | :when (not (equal char #\Space)) 27 | :do (return num-spaces))) 28 | 29 | 30 | (defun left-remove-if (items predicate) 31 | "Returns list skipping leftmost items 32 | which match a predicate." 33 | (do () 34 | ((not (funcall predicate (car items))) items) 35 | (setf items (cdr items)))) 36 | 37 | (defun right-remove-if (items predicate) 38 | "Returns a new list, without rightmost items 39 | which match a predicate." 40 | (labels ((recur (items) 41 | (destructuring-bind (head . tail) items 42 | (if tail 43 | (let ((tail (recur tail))) 44 | (if tail 45 | (cons head tail) 46 | (unless (funcall predicate head) 47 | (list head)))) 48 | (if (funcall predicate head) 49 | nil 50 | (list head)))))) 51 | (recur items))) 52 | 53 | 54 | (defun deindent (text) 55 | "Removes empty new lines at the begining and at the end of the text, 56 | and removes common number of whitespaces from rest of the lines." 57 | (let* ((all-lines (split-sequence 58 | #\Newline 59 | text)) 60 | ;; remove empty lines at beginning 61 | (left-trimmed (left-remove-if 62 | all-lines 63 | #'empty-line-p)) 64 | ;; and at the end 65 | (lines (right-remove-if 66 | left-trimmed 67 | #'empty-line-p)) 68 | 69 | ;; calculate common indentation 70 | (min-indent (apply #'min (mapcar #'get-indentation lines))) 71 | 72 | ;; remove common indentation from lines 73 | (new-lines (loop :for line :in lines 74 | :collect (subseq line min-indent)))) 75 | 76 | ;; now join lines together and separate them with new-lines 77 | (values (format nil "~{~a~^~%~}" new-lines) 78 | min-indent))) 79 | 80 | 81 | (defmacro test-assertion (title body expected 82 | &aux (method (if (search ".*" expected) 83 | 'like 84 | 'is))) 85 | "Tests that assertion result in prove's output 86 | matches given regular expression. 87 | 88 | Body evaluated and it's result is matched agains expected string, 89 | using prove:like. Dangling spaces and newlines are trimmed from 90 | the result before trying to match." 91 | 92 | (with-gensyms (result trimmed-result deindented-expected) 93 | `(subtest ,title 94 | (let* ((,result 95 | ;; All output during the test, should be captured 96 | ;; to test against give regex 97 | (with-output-to-string 98 | (prove.output:*test-result-output*) 99 | 100 | (let ( ;; Colors whould be turned off to 101 | ;; prevent Prove's reporter return 102 | ;; string with terminal sequences. 103 | ;; This way it will be easier to compare 104 | ;; results with usual strings 105 | (prove.color:*enable-colors* nil) 106 | ;; We need to overide current suite, to prevent 107 | ;; tested assert-that macro from modifying real testsuite. 108 | ;; Otherwise it can increment failed or success tests count 109 | ;; and prove will output wrong data. 110 | (prove.suite:*suite* (make-instance 'prove.suite:suite)) 111 | (prove.reporter::*debug-indentation* nil)) 112 | ,body))) 113 | 114 | (,trimmed-result (string-trim '(#\Space #\Newline) 115 | (deindent ,result))) 116 | (,deindented-expected (deindent ,expected))) 117 | (,method ,trimmed-result 118 | ,deindented-expected))))) 119 | --------------------------------------------------------------------------------