lisp-unit.lisp

   1 ;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 #|
   4 Copyright (c) 2004-2005 Christopher K. Riesbeck
   5
   6 Permission is hereby granted, free of charge, to any person obtaining
   7 a copy of this software and associated documentation files (the "Software"),
   8 to deal in the Software without restriction, including without limitation
   9 the rights to use, copy, modify, merge, publish, distribute, sublicense,
  10 and/or sell copies of the Software, and to permit persons to whom the
  11 Software is furnished to do so, subject to the following conditions:
  12
  13 The above copyright notice and this permission notice shall be included
  14 in all copies or substantial portions of the Software.
  15
  16 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
  17 OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  18 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  19 THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
  20 OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
  21 ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  22 OTHER DEALINGS IN THE SOFTWARE.
  23
  24
  25 How to use
  26 ----------
  27
  28 1. Read the documentation at:
  29    https://github.com/OdonataResearchLLC/lisp-unit/wiki
  30
  31 2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
  32 examples. If you want, start your test file with (REMOVE-TESTS :ALL)
  33 to clear any previously defined tests.
  34
  35 3. Load this file.
  36
  37 4. (use-package :lisp-unit)
  38
  39 5. Load your code file and your file of tests.
  40
  41 6. Test your code with (RUN-TESTS '(test-name1 test-name2 ...)) or
  42 simply (RUN-TESTS :ALL) to run all defined tests.
  43
  44 A summary of how many tests passed and failed will be printed.
  45
  46 NOTE: Nothing is compiled until RUN-TESTS is expanded. Redefining
  47 functions or even macros does not require reloading any tests.
  48
  49 |#
  50
  51 ;;; Packages
  52
  53 (in-package :cl-user)
  54
  55 (defpackage :lisp-unit
  56   (:use :common-lisp)
  57   ;; Print parameters
  58   (:export :*print-summary*
  59            :*print-failures*
  60            :*print-errors*)
  61   ;; Forms for assertions
  62   (:export :assert-eq
  63            :assert-eql
  64            :assert-equal
  65            :assert-equalp
  66            :assert-equality
  67            :assert-prints
  68            :assert-expands
  69            :assert-true
  70            :assert-false
  71            :assert-error)
  72   ;; Functions for managing tests
  73   (:export :define-test
  74            :list-tests
  75            :test-code
  76            :test-documentation
  77            :remove-tests
  78            :run-tests
  79            :use-debugger)
  80   ;; Functions for managing tags
  81   (:export :list-tags
  82            :tagged-tests
  83            :remove-tags
  84            :run-tags)
  85   ;; Functions for reporting test results
  86   (:export :test-names
  87            :failed-tests
  88            :error-tests
  89            :missing-tests
  90            :summarize-results)
  91   ;; Utility predicates
  92   (:export :logically-equal :set-equal))
  93
  94 (in-package :lisp-unit)
  95
  96 ;;; Global counters
  97
  98 (defparameter *pass* ()
  99   "The passed assertion results.")
 100
 101 (defparameter *fail* ()
 102   "The failed assertion results.")
 103
 104 ;;; Global options
 105
 106 (defparameter *print-summary* nil
 107   "Print a summary of the pass, fail, and error count if non-nil.")
 108
 109 (defparameter *print-failures* nil
 110   "Print failure messages if non-NIL.")
 111
 112 (defparameter *print-errors* nil
 113   "Print error messages if non-NIL.")
 114
 115 (defparameter *use-debugger* nil
 116   "If not NIL, enter the debugger when an error is encountered in an
 117 assertion.")
 118
 119 (defun use-debugger-p (condition)
 120   "Debug or ignore errors."
 121   (cond
 122    ((eq :ask *use-debugger*)
 123     (y-or-n-p "~A -- debug?" condition))
 124    (*use-debugger*)))
 125
 126 ;;; Failure control strings
 127
 128 (defgeneric print-failure (result)
 129   (:documentation
 130    "Report the results of the failed assertion."))
 131
 132 (defmethod print-failure :around (result)
 133   "Failure header and footer output."
 134   (format t "~& | Failed Form: ~S" (form result))
 135   (call-next-method)
 136   (when (extras result)
 137     (format t "~{~& | ~S => ~S~}~%"
 138             (funcall (extras result))))
 139   (format t "~& |~%")
 140   (class-name result))
 141
 142 (defmethod print-failure (result)
 143   (format t "~& | Expected ~{~S~^; ~} " (expected result))
 144   (format t "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result)))
 145
 146 (defmethod print-failure ((result error-result))
 147   (format t "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
 148           (expected result))
 149   (format t " ~{~S~^; ~}" (actual result)))
 150
 151 (defmethod print-failure ((result macro-result))
 152   (format t "~& | Should have expanded to ~{~S~^; ~} "
 153           (expected result))
 154   (format t "~<~%~:;but saw ~{~S~^; ~}~>" (actual result)))
 155
 156 (defmethod print-failure ((result output-result))
 157   (format t "~& | Should have printed ~{~S~^; ~} "
 158           (expected result))
 159   (format t "~<~%~:;but saw ~{~S~^; ~}~>"
 160           (actual result)))
 161
 162 (defgeneric print-error (condition)
 163   (:documentation
 164    "Print the error condition."))
 165
 166 (defmethod print-error (condition)
 167   "Print the error condition."
 168   (let ((*print-escape* nil))
 169     (format t "~& | Execution error:~% | ~W" condition)
 170     (format t "~& |~%")))
 171
 172 (defun print-summary (name pass fail &optional exerr)
 173   "Print a summary of the test results."
 174   (format t "~&~A: ~S assertions passed, ~S failed"
 175           name (length pass) (length fail))
 176   (format t "~@[, ~S execution errors~].~2%" exerr))
 177
 178 ;;; Global unit test database
 179
 180 (defparameter *test-db* (make-hash-table :test #'eq)
 181   "The unit test database is simply a hash table.")
 182
 183 (defun package-table (package &optional create)
 184   (cond
 185    ((gethash (find-package package) *test-db*))
 186    (create
 187     (setf (gethash package *test-db*) (make-hash-table)))
 188    (t (warn "No tests defined for package: ~S" package))))
 189
 190 ;;; Global tags database
 191
 192 (defparameter *tag-db* (make-hash-table :test #'eq)
 193   "The tag database is simply a hash table.")
 194
 195 (defun package-tags (package &optional create)
 196   "Return the tags DB for the package."
 197   (cond
 198    ((gethash (find-package package) *tag-db*))
 199    (create
 200     (setf (gethash package *tag-db*) (make-hash-table)))
 201    (t (warn "No tags defined for package: ~S" package))))
 202
 203 (defclass unit-test ()
 204   ((doc
 205     :type string
 206     :initarg :doc
 207     :reader doc)
 208    (code
 209     :type list
 210     :initarg :code
 211     :reader code))
 212   (:default-initargs :doc "" :code ())
 213   (:documentation
 214    "Organize the unit test documentation and code."))
 215
 216 ;;; NOTE: Shamelessly taken from PG's analyze-body
 217 (defun parse-body (body &optional doc tag)
 218   "Separate the components of the body."
 219   (let ((item (first body)))
 220     (cond
 221      ((and (listp item) (eq :tag (first item)))
 222       (parse-body (rest body) doc (nconc (rest item) tag)))
 223      ((and (stringp item) (not doc) (rest body))
 224       (if tag
 225           (values doc tag (rest body))
 226           (parse-body (rest body) doc tag)))
 227      (t (values doc tag body)))))
 228
 229 (defmacro define-test (name &body body)
 230   "Store the test in the test database."
 231   (multiple-value-bind (doc tag code) (parse-body body)
 232     `(let ((doc (or ,doc (string ',name))))
 233        (setf
 234         ;; Unit test
 235         (gethash ',name (package-table *package* t))
 236         (make-instance 'unit-test :doc doc :code ',code))
 237        ;; Tags
 238        (loop for tag in ',tag do
 239              (pushnew
 240               ',name (gethash tag (package-tags *package* t))))
 241        ;; Return the name of the test
 242        ',name)))
 243
 244 ;;; Manage tests
 245
 246 (defun list-tests (&optional (package *package*))
 247   "Return a list of the tests in package."
 248   (let ((table (package-table package)))
 249     (when table
 250       (loop for test-name being each hash-key in table
 251             collect test-name))))
 252
 253 (defun test-documentation (name &optional (package *package*))
 254   "Return the documentation for the test."
 255   (let ((unit-test (gethash name (package-table package))))
 256     (if (null unit-test)
 257         (warn "No code defined for test ~A in package ~S."
 258               name package)
 259         (doc unit-test))))
 260
 261 (defun test-code (name &optional (package *package*))
 262   "Returns the code stored for the test name."
 263   (let ((unit-test (gethash name (package-table package))))
 264     (if (null unit-test)
 265         (warn "No code defined for test ~A in package ~S."
 266               name package)
 267         (code unit-test))))
 268
 269 (defun remove-tests (names &optional (package *package*))
 270   "Remove individual tests or entire sets."
 271   (if (eq :all names)
 272       (if (null package)
 273           (clrhash *test-db*)
 274           (progn
 275             (remhash (find-package package) *test-db*)
 276             (remhash (find-package package) *tag-db*)))
 277       (let ((table (package-table package)))
 278         (unless (null table)
 279           ;; Remove tests
 280           (loop for name in names
 281                 always (remhash name table)
 282                 collect name into removed
 283                 finally (return removed))
 284           ;; Remove tests from tags
 285           (loop with tags = (package-tags package)
 286                 for tag being each hash-key in tags
 287                 using (hash-value tagged-tests)
 288                 do
 289                 (setf
 290                  (gethash tag tags)
 291                  (set-difference tagged-tests names)))))))
 292
 293 ;;; Manage tags
 294
 295 (defun %tests-from-all-tags (&optional (package *package*))
 296   "Return all of the tests that have been tagged."
 297   (loop for tests being each hash-value in (package-tags package)
 298         nconc (copy-list tests) into all-tests
 299         finally (return (delete-duplicates all-tests))))
 300
 301 (defun %tests-from-tags (tags &optional (package *package*))
 302   "Return the tests associated with the tags."
 303   (loop with table = (package-tags package)
 304         for tag in tags
 305         as tests = (gethash tag table)
 306         nconc (copy-list tests) into all-tests
 307         finally (return (delete-duplicates all-tests))))
 308
 309 (defun list-tags (&optional (package *package*))
 310   "Return a list of the tags in package."
 311   (let ((tags (package-tags package)))
 312     (when tags
 313       (loop for tag being each hash-key in tags collect tag))))
 314
 315 (defun tagged-tests (tags &optional (package *package*))
 316   "Run the tests associated with the specified tags in package."
 317   (if (eq :all tags)
 318       (%tests-from-all-tags package)
 319       (%tests-from-tags tags package)))
 320
 321 (defun remove-tags (tags &optional (package *package*))
 322   "Remove individual tags or entire sets."
 323   (if (eq :all tags)
 324       (if (null package)
 325           (clrhash *tag-db*)
 326           (remhash (find-package package) *tag-db*))
 327       (let ((table (package-tags package)))
 328         (unless (null table)
 329           (loop for tag in tags
 330                 always (remhash tag table)
 331                 collect tag into removed
 332                 finally (return removed))))))
 333
 334 ;;; Assert macros
 335
 336 (defmacro assert-eq (expected form &rest extras)
 337   "Assert whether expected and form are EQ."
 338   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq))
 339
 340 (defmacro assert-eql (expected form &rest extras)
 341   "Assert whether expected and form are EQL."
 342   `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql))
 343
 344 (defmacro assert-equal (expected form &rest extras)
 345   "Assert whether expected and form are EQUAL."
 346   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal))
 347
 348 (defmacro assert-equalp (expected form &rest extras)
 349   "Assert whether expected and form are EQUALP."
 350   `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp))
 351
 352 (defmacro assert-error (condition form &rest extras)
 353   "Assert whether form signals condition."
 354   `(expand-assert :error ,form (expand-error-form ,form)
 355                   ,condition ,extras))
 356
 357 (defmacro assert-expands (expansion form &rest extras)
 358   "Assert whether form expands to expansion."
 359   `(expand-assert :macro ,form
 360                   (expand-macro-form ,form nil)
 361                   ,expansion ,extras))
 362
 363 (defmacro assert-false (form &rest extras)
 364   "Assert whether the form is false."
 365   `(expand-assert :result ,form ,form nil ,extras))
 366
 367 (defmacro assert-equality (test expected form &rest extras)
 368   "Assert whether expected and form are equal according to test."
 369   `(expand-assert :equal ,form ,form ,expected ,extras :test ,test))
 370
 371 (defmacro assert-prints (output form &rest extras)
 372   "Assert whether printing the form generates the output."
 373   `(expand-assert :output ,form (expand-output-form ,form)
 374                   ,output ,extras))
 375
 376 (defmacro assert-true (form &rest extras)
 377   "Assert whether the form is true."
 378   `(expand-assert :result ,form ,form t ,extras))
 379
 380 (defmacro expand-assert (type form body expected extras &key (test '#'eql))
 381   "Expand the assertion to the internal format."
 382   `(internal-assert ,type ',form
 383                     (lambda () ,body)
 384                     (lambda () ,expected)
 385                     (expand-extras ,extras)
 386                     ,test))
 387
 388 (defmacro expand-error-form (form)
 389   "Wrap the error assertion in HANDLER-CASE."
 390   `(handler-case ,form
 391      (condition (error) error)))
 392
 393 (defmacro expand-output-form (form)
 394   "Capture the output of the form in a string."
 395   (let ((out (gensym)))
 396     `(let* ((,out (make-string-output-stream))
 397             (*standard-output*
 398              (make-broadcast-stream *standard-output* ,out)))
 399        ,form
 400        (get-output-stream-string ,out))))
 401
 402 (defmacro expand-macro-form (form env)
 403   "Expand the macro form once."
 404   `(macroexpand-1 ',form ,env))
 405
 406 (defmacro expand-extras (extras)
 407   "Expand extra forms."
 408   `(lambda ()
 409      (list ,@(mapcan (lambda (form) (list `',form form)) extras))))
 410
 411 (defclass assert-result ()
 412   ((form
 413     :initarg :form
 414     :reader form)
 415    (actual
 416     :type list
 417     :initarg :actual
 418     :reader actual)
 419    (expected
 420     :type list
 421     :initarg :expected
 422     :reader expected)
 423    (extras
 424     :type list
 425     :initarg :extras
 426     :reader extras)
 427    (test
 428     :type function
 429     :initarg :test
 430     :reader test)
 431    (passed
 432     :type boolean
 433     :reader passed))
 434   (:documentation
 435    "Result of the assertion."))
 436
 437 (defmethod initialize-instance :after ((self assert-result)
 438                                        &rest initargs)
 439   "Evaluate the actual and expected forms"
 440   (with-slots (actual expected) self
 441     (setf
 442      actual (multiple-value-list (funcall actual))
 443      expected (multiple-value-list (funcall expected)))))
 444
 445 (defclass equal-result (assert-result)
 446   ()
 447   (:documentation
 448    "Result of an equal assertion type."))
 449
 450 (defmethod initialize-instance :after ((self equal-result)
 451                                        &rest initargs)
 452   "Return the result of the equality assertion."
 453   (with-slots (actual expected test passed) self
 454     (setf
 455      passed
 456      (and
 457       (<= (length expected) (length actual))
 458       (every test expected actual)))))
 459
 460 (defclass error-result (assert-result)
 461   ()
 462   (:documentation
 463    "Result of an error assertion type."))
 464
 465 (defmethod initialize-instance :after ((self error-result)
 466                                        &rest initargs)
 467   "Evaluate the result."
 468   (with-slots (actual expected passed) self
 469     (setf
 470      passed
 471      (or
 472       (eql (car actual) (car expected))
 473       (typep (car actual) (car expected))))))
 474
 475 (defclass macro-result (assert-result)
 476   ()
 477   (:documentation
 478    "Result of a macro assertion type."))
 479
 480 (defmethod initialize-instance :after ((self macro-result)
 481                                        &rest initargs)
 482   "Return the result of the macro expansion."
 483   (with-slots (actual expected passed) self
 484     (setf passed (equal (car actual) (car expected)))))
 485
 486 (defclass boolean-result (assert-result)
 487   ()
 488   (:documentation
 489    "Result of a result assertion type."))
 490
 491 (defmethod initialize-instance :after ((self boolean-result)
 492                                        &rest initargs)
 493   "Return the result of the assertion."
 494   (with-slots (actual expected passed) self
 495     (setf passed (logically-equal (car actual) (car expected)))))
 496
 497 (defclass output-result (assert-result)
 498   ()
 499   (:documentation
 500    "Result of an output assertion type."))
 501
 502 (defmethod initialize-instance :after ((self output-result)
 503                                        &rest initargs)
 504   "Return the result of the printed output."
 505   (with-slots (actual expected passed) self
 506     (setf
 507      passed
 508      (string=
 509       (string-trim '(#\newline #\return #\space) (car actual))
 510       (car expected)))))
 511
 512 (defun assert-class (type)
 513   "Return the class name for the assertion type."
 514   (ecase type
 515     (:equal 'equal-result)
 516     (:error 'error-result)
 517     (:macro 'macro-result)
 518     (:result 'boolean-result)
 519     (:output 'output-result)))
 520
 521 (defun internal-assert
 522        (type form code-thunk expected-thunk extras test)
 523   "Perform the assertion and record the results."
 524   (let ((result
 525          (make-instance (assert-class type)
 526                         :form form
 527                         :actual code-thunk
 528                         :expected expected-thunk
 529                         :extras extras
 530                         :test test)))
 531     (if (passed result)
 532         (push result *pass*)
 533         (push result *fail*))
 534     ;; Return the result
 535     (passed result)))
 536
 537 ;;; Results
 538
 539 (defclass test-results-db ()
 540   ((database
 541     :type hash-table
 542     :initform (make-hash-table :test #'eq)
 543     :reader database)
 544    (pass
 545     :type fixnum
 546     :initform 0
 547     :accessor pass)
 548    (fail
 549     :type fixnum
 550     :initform 0
 551     :accessor fail)
 552    (exerr
 553     :type fixnum
 554     :initform 0
 555     :accessor exerr)
 556    (failed-tests
 557     :type list
 558     :initform ()
 559     :accessor failed-tests)
 560    (error-tests
 561     :type list
 562     :initform ()
 563     :accessor error-tests)
 564    (missing-tests
 565     :type list
 566     :initform ()
 567     :accessor missing-tests))
 568   (:documentation
 569    "Store the results of the tests for further evaluation."))
 570
 571 (defmethod print-object ((object test-results-db) stream)
 572   "Print the summary counts with the object."
 573   (let ((pass (pass object))
 574         (fail (fail object))
 575         (exerr (exerr object)))
 576     (format
 577      stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
 578      (class-name (class-of object))
 579      (+ pass fail) pass fail exerr)))
 580
 581 (defun test-names (test-results-db)
 582   "Return a list of the test names in the database."
 583   (loop for name being each hash-key in (database test-results-db)
 584         collect name))
 585
 586 (defun record-result (test-name code results)
 587   "Run the test code and record the result."
 588   (let ((result (run-test-thunk code)))
 589     ;; Store the result
 590     (setf (gethash test-name (database results)) result)
 591     ;; Count passed tests
 592     (when (pass result)
 593       (incf (pass results) (length (pass result))))
 594     ;; Count failed tests and record the name
 595     (when (fail result)
 596       (incf (fail results) (length (fail result)))
 597       (push test-name (failed-tests results)))
 598     ;; Count errors and record the name
 599     (when (exerr result)
 600       (incf (exerr results))
 601       (push test-name (error-tests results)))))
 602
 603 (defun summarize-results (results)
 604   "Print a summary of all results."
 605   (let ((pass (pass results))
 606         (fail (fail results)))
 607     (format t "~&Unit Test Summary~%")
 608     (format t " | ~D assertions total~%" (+ pass fail))
 609     (format t " | ~D passed~%" pass)
 610     (format t " | ~D failed~%" fail)
 611     (format t " | ~D execution errors~%" (exerr results))
 612     (format t " | ~D missing tests~2%"
 613             (length (missing-tests results)))))
 614
 615 ;;; Run the tests
 616
 617 (defclass test-result ()
 618   ((pass
 619     :type list
 620     :initarg :pass
 621     :reader pass)
 622    (fail
 623     :type list
 624     :initarg :fail
 625     :reader fail)
 626    (exerr
 627     :type condition
 628     :initarg :exerr
 629     :reader exerr))
 630   (:default-initargs :exerr nil)
 631   (:documentation
 632    "Store the results of the unit test."))
 633
 634 (defun run-code (code)
 635   "Run the code to test the assertions."
 636   (funcall (coerce `(lambda () ,@code) 'function)))
 637
 638 (defun run-test-thunk (code)
 639   (let ((*pass* ())
 640         (*fail* ()))
 641     (handler-bind
 642         ((error
 643           (lambda (condition)
 644             (if (use-debugger-p condition)
 645                 condition
 646                 (return-from run-test-thunk
 647                   (make-instance
 648                    'test-result
 649                    :pass *pass*
 650                    :fail *fail*
 651                    :exerr condition))))))
 652       (run-code code))
 653     ;; Return the result count
 654     (make-instance 'test-result
 655                    :pass *pass*
 656                    :fail *fail*)))
 657
 658 (defun %run-all-thunks (&optional (package *package*))
 659   "Run all of the test thunks in the package."
 660   (loop
 661    with results = (make-instance 'test-results-db)
 662    for test-name being each hash-key in (package-table package)
 663    using (hash-value unit-test)
 664    if unit-test do
 665    (record-result test-name (code unit-test) results)
 666    else do
 667    (push test-name (missing-tests results))
 668    ;; Summarize and return the test results
 669    finally
 670    (summarize-results results)
 671    (return results)))
 672
 673 (defun %run-thunks (test-names &optional (package *package*))
 674   "Run the list of test thunks in the package."
 675   (loop
 676    with table = (package-table package)
 677    and results = (make-instance 'test-results)
 678    for test-name in test-names
 679    as unit-test = (gethash test-name table)
 680    if unit-test do
 681    (record-result test-name (code unit-test) results)
 682    else do
 683    (push test-name (missing-tests results))
 684    finally
 685    (summarize-results results)
 686    (return results)))
 687
 688 (defun run-tests (test-names &optional (package *package*))
 689   "Run the specified tests in package."
 690   (if (eq :all test-names)
 691       (%run-all-thunks package)
 692       (%run-thunks test-names package)))
 693
 694 (defun run-tags (tags &optional (package *package*))
 695   "Run the tests associated with the specified tags in package."
 696   (%run-thunks (tagged-tests tags package) package))
 697
 698 ;;; Useful equality predicates for tests
 699
 700 ;;; (LOGICALLY-EQUAL x y) => true or false
 701 ;;;   Return true if x and y both false or both true
 702 (defun logically-equal (x y)
 703   (eql (not x) (not y)))
 704
 705 ;;; (SET-EQUAL l1 l2 :test) => true or false
 706 ;;;   Return true if every element of l1 is an element of l2
 707 ;;;   and vice versa.
 708 (defun set-equal (l1 l2 &key (test #'equal))
 709   (and (listp l1)
 710        (listp l2)
 711        (subsetp l1 l2 :test test)
 712        (subsetp l2 l1 :test test)))
 713
 714 (pushnew :lisp-unit common-lisp:*features*)