Vim window logic, slimv
This commit is contained in:
Ian Keane
parent
babcc9e44b
commit
515847d07e
791 changed files with 51552 additions and 86 deletions
|
|
@ -0,0 +1,144 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.asdf
|
||||
(:nicknames :prove-asdf)
|
||||
(:use :cl
|
||||
:asdf)
|
||||
(:import-from :prove.output
|
||||
:*test-result-output*
|
||||
:*default-reporter*)
|
||||
(:export :test-file
|
||||
:run-test-system
|
||||
:run
|
||||
|
||||
:*last-suite-report*))
|
||||
(in-package :prove.asdf)
|
||||
|
||||
(defvar *last-suite-report* nil)
|
||||
|
||||
(defvar *system-test-files* (make-hash-table))
|
||||
|
||||
(defclass test-file (asdf:cl-source-file) ())
|
||||
|
||||
(defmethod asdf:perform ((op asdf:compile-op) (c test-file))
|
||||
;; do nothing
|
||||
)
|
||||
|
||||
#+asdf3
|
||||
(defmethod asdf::compute-action-stamp :around (plan (o asdf:operation) (c test-file) &key just-done)
|
||||
(declare (ignore just-done))
|
||||
(let ((*error-output* (make-broadcast-stream)))
|
||||
(call-next-method)))
|
||||
|
||||
(defmethod asdf:perform ((op asdf:load-op) (c test-file))
|
||||
(pushnew c (gethash (asdf:component-system c) *system-test-files*)
|
||||
:key #'asdf:component-pathname
|
||||
:test #'equal))
|
||||
|
||||
(defun run-test-system (system-designator)
|
||||
"Runs a testing ASDF system."
|
||||
#+quicklisp (ql:quickload (if (typep system-designator 'asdf:system)
|
||||
(asdf:component-name system-designator)
|
||||
system-designator))
|
||||
#-quicklisp (asdf:load-system system-designator)
|
||||
(let ((passed-files '()) (failed-files '()))
|
||||
(restart-case
|
||||
(dolist (c (reverse
|
||||
(gethash (asdf:find-system system-designator) *system-test-files*)))
|
||||
(setf *last-suite-report* nil)
|
||||
(format *test-result-output* "~2&Running a test file '~A'~%" (asdf:component-pathname c))
|
||||
(restart-case
|
||||
(progn
|
||||
(asdf:perform 'asdf:load-source-op c)
|
||||
(unless *last-suite-report*
|
||||
(warn "Test completed without 'finalize'd."))
|
||||
(if (eql (getf *last-suite-report* :failed) 0)
|
||||
(push (asdf:component-pathname c) passed-files)
|
||||
(push (asdf:component-pathname c) failed-files)))
|
||||
(skip-test-file ()
|
||||
:report "Skip this test file."
|
||||
(push (asdf:component-pathname c) failed-files))))
|
||||
(skip-all-test-files ()
|
||||
:report "Give up all test files."
|
||||
nil))
|
||||
(setf passed-files (nreverse passed-files)
|
||||
failed-files (nreverse failed-files))
|
||||
(format t "~2&Summary:~%")
|
||||
(if failed-files
|
||||
(format t " ~D file~:*~P failed.~{~% - ~A~}
|
||||
"
|
||||
(length failed-files)
|
||||
failed-files)
|
||||
(format t " All ~D file~:*~P passed.~%"
|
||||
(length passed-files)))
|
||||
(values (null failed-files)
|
||||
passed-files
|
||||
failed-files)))
|
||||
|
||||
(defun test-files-in-directory (directory)
|
||||
(check-type directory pathname)
|
||||
(flet ((always-true (&rest args)
|
||||
(declare (ignore args))
|
||||
T))
|
||||
(let ((directories '()))
|
||||
(#+asdf3 uiop:collect-sub*directories
|
||||
#-asdf3 asdf::collect-sub*directories
|
||||
directory
|
||||
#'always-true
|
||||
#'always-true
|
||||
(lambda (dir)
|
||||
(push dir directories)))
|
||||
(mapcan (lambda (dir)
|
||||
(#+asdf3 uiop:directory-files
|
||||
#-asdf3 asdf::directory-files dir "*.lisp"))
|
||||
(nreverse directories)))))
|
||||
|
||||
(defun run (object &key (reporter *default-reporter*))
|
||||
"Runs a test. OBJECT can be one of a file pathname, a directory pathname or an ASDF system name.
|
||||
Returns 3 multiple-values, a flag if the tests passed as T or NIL, passed test files as a list and failed test files also as a list.
|
||||
|
||||
Example:
|
||||
(prove:run :myapp-test)
|
||||
(prove:run #P\"myapp/tests/\")
|
||||
(prove:run #P\"myapp/tests/01-main.lisp\")
|
||||
"
|
||||
(check-type reporter keyword)
|
||||
(flet ((directory-pathname-p (path)
|
||||
(string= (file-namestring path) "")))
|
||||
(let ((*default-reporter* reporter))
|
||||
(cond
|
||||
((and (stringp object)
|
||||
(asdf:find-system object nil))
|
||||
(run-test-system object))
|
||||
((stringp object)
|
||||
(run (pathname object)))
|
||||
((and (pathnamep object)
|
||||
(directory-pathname-p object))
|
||||
(let ((all-passed-p T) (all-passed-files '()) (all-failed-files '()))
|
||||
(restart-case
|
||||
(dolist (file (test-files-in-directory object))
|
||||
(multiple-value-bind (passedp passed-files failed-files)
|
||||
(run file)
|
||||
(setf all-passed-files (append all-passed-files passed-files))
|
||||
(setf all-failed-files (append all-failed-files failed-files))
|
||||
(unless passedp
|
||||
(setf all-passed-p nil))))
|
||||
(skip-all-test-files ()
|
||||
:report "Give up all test files."
|
||||
nil))
|
||||
(values all-passed-p all-passed-files all-failed-files)))
|
||||
((pathnamep object)
|
||||
(setf *last-suite-report* nil)
|
||||
(restart-case
|
||||
(progn
|
||||
(load object)
|
||||
(unless *last-suite-report*
|
||||
(warn "Test completed without 'finalize'd.")))
|
||||
(skip-test-file ()
|
||||
:report "Skip this test file."
|
||||
nil))
|
||||
(if (eql (getf *last-suite-report* :failed) 0)
|
||||
(values T (list object) '())
|
||||
(values NIL '() (list object))))
|
||||
(T (run-test-system object))))))
|
||||
|
||||
(import 'test-file :asdf)
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.color
|
||||
(:use :cl)
|
||||
(:import-from :cl-ansi-text
|
||||
:generate-color-string)
|
||||
(:import-from :cl-colors
|
||||
:+gray+
|
||||
:+grey+)
|
||||
(:export :*enable-colors*
|
||||
:with-color))
|
||||
(in-package :prove.color)
|
||||
|
||||
(defvar *enable-colors*
|
||||
(not (equal (uiop:getenv "EMACS") "t"))
|
||||
"Flag whether colorize a test report. The default is T except on Emacs (SLIME).")
|
||||
|
||||
(defmacro with-gray (stream &body body)
|
||||
`(progn
|
||||
(format ,stream (cl-ansi-text::generate-color-string 90))
|
||||
(unwind-protect (progn ,@body)
|
||||
(format ,stream (cl-ansi-text::generate-color-string 0)))))
|
||||
|
||||
(defmacro with-color ((color &rest args) &body body)
|
||||
(cond
|
||||
((or (eq color :gray)
|
||||
(eq color :grey))
|
||||
`(if *enable-colors*
|
||||
(with-gray ,(or (getf args :stream) t) ,@body)
|
||||
(progn ,@body)))
|
||||
(T `(if *enable-colors*
|
||||
(if (or (eq ,color :gray)
|
||||
(eq ,color :grey)
|
||||
(eq ,color cl-colors:+gray+)
|
||||
(eq ,color cl-colors:+grey+))
|
||||
(with-gray ,(or (getf args :stream) t) ,@body)
|
||||
(cl-ansi-text:with-color (,color ,@args) ,@body))
|
||||
(progn ,@body)))))
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.output
|
||||
(:use :cl)
|
||||
(:export :*test-result-output*
|
||||
:test-result-output
|
||||
:*default-reporter*))
|
||||
(in-package :prove.output)
|
||||
|
||||
(defvar *test-result-output* (make-synonym-stream '*standard-output*))
|
||||
|
||||
;; This should be in prove.reporter,
|
||||
;; but it's here because this will also be used in prove-asdf.
|
||||
(defvar *default-reporter* :list)
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove
|
||||
(:nicknames :cl-test-more :test-more)
|
||||
(:use :cl)
|
||||
(:import-from :prove.output
|
||||
:*test-result-output*
|
||||
:*default-reporter*)
|
||||
(:import-from :prove.asdf
|
||||
:test-file
|
||||
:run-test-system
|
||||
:run)
|
||||
(:import-from :prove.test
|
||||
:*debug-on-error*
|
||||
:*default-test-function*
|
||||
:ok
|
||||
:is
|
||||
:isnt
|
||||
:is-values
|
||||
:is-print
|
||||
:is-condition
|
||||
:is-error
|
||||
:is-type
|
||||
:like
|
||||
:is-expand
|
||||
:diag
|
||||
:skip
|
||||
:pass
|
||||
:fail
|
||||
:subtest
|
||||
:deftest
|
||||
:run-test
|
||||
:run-test-package
|
||||
:run-test-all
|
||||
:remove-test
|
||||
:remove-test-all
|
||||
:*gensym-prefix*)
|
||||
(:import-from :prove.suite
|
||||
:*default-slow-threshold*
|
||||
:slow-threshold
|
||||
:plan
|
||||
:finalize
|
||||
:current-suite
|
||||
:*suite*
|
||||
:reset-suite
|
||||
:suite
|
||||
:package-suite)
|
||||
(:import-from :prove.color
|
||||
:*enable-colors*)
|
||||
(:export :*debug-on-error*
|
||||
:*test-result-output*
|
||||
:*default-test-function*
|
||||
:*default-reporter*
|
||||
:test-file
|
||||
:run-test-system
|
||||
:run
|
||||
:ok
|
||||
:is
|
||||
:isnt
|
||||
:is-values
|
||||
:is-print
|
||||
:is-condition
|
||||
:is-error
|
||||
:is-type
|
||||
:like
|
||||
:is-expand
|
||||
:diag
|
||||
:skip
|
||||
:pass
|
||||
:fail
|
||||
:subtest
|
||||
:deftest
|
||||
:run-test
|
||||
:run-test-package
|
||||
:run-test-all
|
||||
:remove-test
|
||||
:remove-test-all
|
||||
:plan
|
||||
:finalize
|
||||
:*gensym-prefix*
|
||||
:*default-slow-threshold*
|
||||
:slow-threshold
|
||||
:current-suite
|
||||
:*suite*
|
||||
:reset-suite
|
||||
:suite
|
||||
:package-suite
|
||||
:*enable-colors*))
|
||||
|
|
@ -0,0 +1,113 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.report
|
||||
(:use :cl)
|
||||
(:export :report
|
||||
:test-report
|
||||
:normal-test-report
|
||||
:passed-test-report
|
||||
:failed-test-report
|
||||
:error-test-report
|
||||
:skipped-test-report
|
||||
:comment-report
|
||||
:composed-test-report
|
||||
|
||||
:test-report-p
|
||||
:passed-report-p
|
||||
:failed-report-p
|
||||
:error-report-p
|
||||
:skipped-report-p
|
||||
|
||||
:plan
|
||||
:children
|
||||
:description
|
||||
:notp
|
||||
:got
|
||||
:got-form
|
||||
:expected
|
||||
:report-expected-label
|
||||
:duration
|
||||
:slow-threshold
|
||||
:print-error-detail))
|
||||
(in-package :prove.report)
|
||||
|
||||
(defclass report ()
|
||||
((description :type (or null string)
|
||||
:initarg :description
|
||||
:initform nil)))
|
||||
|
||||
(defclass comment-report (report) ())
|
||||
|
||||
(defclass test-report (report)
|
||||
((duration :initarg :duration
|
||||
:initform nil)
|
||||
(slow-threshold :initarg :slow-threshold)
|
||||
(print-error-detail :type boolean
|
||||
:initarg :print-error-detail
|
||||
:initform t)))
|
||||
|
||||
(defclass normal-test-report (test-report)
|
||||
((test-function :type (or function symbol)
|
||||
:initarg :test-function)
|
||||
(notp :type boolean
|
||||
:initarg :notp
|
||||
:initform nil)
|
||||
(got :initarg :got
|
||||
:initform (error ":got is required"))
|
||||
(got-form :initarg :got-form
|
||||
:initform '#:unbound)
|
||||
(expected :initarg :expected
|
||||
:initform (error ":expected is required"))
|
||||
(report-expected-label :type (or null string)
|
||||
:initarg :report-expected-label
|
||||
:initform nil)))
|
||||
|
||||
(defclass composed-test-report (test-report)
|
||||
((plan :initarg :plan
|
||||
:initform nil)
|
||||
(children :initarg :children
|
||||
:initform (make-array 0 :adjustable t :fill-pointer 0))))
|
||||
|
||||
(defclass passed-test-report (normal-test-report) ())
|
||||
(defclass failed-test-report (normal-test-report) ())
|
||||
(defclass error-test-report (failed-test-report) ())
|
||||
(defclass skipped-test-report (normal-test-report) ())
|
||||
|
||||
(defun test-report-p (report)
|
||||
(typep report 'test-report))
|
||||
|
||||
(defun passed-report-p (report)
|
||||
(typecase report
|
||||
(skipped-test-report nil)
|
||||
(passed-test-report t)
|
||||
(composed-test-report
|
||||
(every #'passed-report-p (slot-value report 'children)))
|
||||
(otherwise nil)))
|
||||
|
||||
(defun failed-report-p (report)
|
||||
(typecase report
|
||||
(skipped-test-report nil)
|
||||
(failed-test-report t)
|
||||
(composed-test-report
|
||||
(some #'failed-report-p (slot-value report 'children)))
|
||||
(otherwise nil)))
|
||||
|
||||
(defun error-report-p (report)
|
||||
(typep report 'error-test-report))
|
||||
|
||||
(defun skipped-report-p (report)
|
||||
(typecase report
|
||||
(skipped-test-report t)
|
||||
(composed-test-report
|
||||
(some #'skipped-report-p (slot-value report 'children)))
|
||||
(otherwise nil)))
|
||||
|
||||
(defmethod print-object ((report normal-test-report) stream)
|
||||
(with-slots (got notp expected description) report
|
||||
(format stream
|
||||
"#<~A RESULT: ~S, GOT: ~S, ~:[~;NOT ~]EXPECTED: ~S~:[~;~:*, DESCRIPTION: ~A~]>"
|
||||
(type-of report)
|
||||
(passed-report-p report)
|
||||
got
|
||||
notp
|
||||
expected
|
||||
description)))
|
||||
|
|
@ -0,0 +1,175 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter
|
||||
(:use :cl)
|
||||
(:import-from :prove.report
|
||||
:report
|
||||
:test-report
|
||||
:description)
|
||||
(:import-from :prove.output
|
||||
:*default-reporter*)
|
||||
(:export :*indent-level*
|
||||
:indent-space
|
||||
:format/indent
|
||||
:reporter
|
||||
:format-report
|
||||
:print-error-report
|
||||
:print-plan-report
|
||||
:print-finalize-report
|
||||
:with-additional-indent))
|
||||
(in-package :prove.reporter)
|
||||
|
||||
(defparameter *indent-level* 0
|
||||
"Level for nested test-cases output.
|
||||
Number of spaces, added for each indentation level
|
||||
is described in reporter's indent-space slot.
|
||||
|
||||
Also, macro shift-indent could be used to slightly
|
||||
indent content inside the main indentation level.
|
||||
|
||||
full-indent = indent-space * indent-level + additional-indent
|
||||
|
||||
Here is an example of the output:
|
||||
|
||||
1| x Blah minor.
|
||||
2| Next line of description:
|
||||
3|
|
||||
4| x Nested test.
|
||||
5| Also has multiline description.
|
||||
|
||||
In this example, indent-space is 4, that is why
|
||||
text on lines 1 and 4 have 4 spaces between the 'x'
|
||||
horizontally.
|
||||
|
||||
Outputting the first line \" x \", reporter sets
|
||||
*additional-indent* to 4. That is why these additional
|
||||
4 lines are prepended to the rest lines of the main
|
||||
test case description.
|
||||
|
||||
When inner testcase runs, it increments *indent-level*,
|
||||
which shifts output to another 4 spaces (indent-space)
|
||||
to the right, simultaneously resetting *additional-indent*
|
||||
to zero.
|
||||
|
||||
For nested test, reporter writes \" x \" and again,
|
||||
sets *additional-indent* to 4 and every other lines now
|
||||
shifted by 1 * 4 + 4 = 8 spaces.
|
||||
")
|
||||
|
||||
(defparameter *additional-indent* 0
|
||||
"Number of spaces to add to each line. see *indent-level* docstring for full description.")
|
||||
|
||||
(defvar *debug-indentation* nil
|
||||
"If True, then indentation will have '=' and '-' symbols for main indentaion and additional, instead of spaces.")
|
||||
|
||||
(defun indent (space &optional (count *indent-level*))
|
||||
"Creates a string with a number of spaces to indent new line
|
||||
of a test report."
|
||||
(if *debug-indentation*
|
||||
(concatenate 'string
|
||||
(make-string (* count space)
|
||||
:initial-element #\=)
|
||||
(make-string *additional-indent*
|
||||
:initial-element #\-))
|
||||
(make-string (+ (* count space)
|
||||
*additional-indent*)
|
||||
:initial-element #\space)))
|
||||
|
||||
|
||||
(defmacro with-additional-indent ((reporter stream control-string &rest format-arguments) &body body)
|
||||
(declare (ignorable reporter stream control-string))
|
||||
(let* ((need-new-line (ppcre:scan "^~&" control-string))
|
||||
(string (apply #'format nil control-string format-arguments))
|
||||
(increment (length string)))
|
||||
`(with-slots (indent-space) reporter
|
||||
(let* ((first-line-indent (indent indent-space))
|
||||
(*additional-indent* ,(if need-new-line
|
||||
increment
|
||||
`(+ *additional-indent*
|
||||
,increment))))
|
||||
(declare (ignorable first-line-indent))
|
||||
,(if need-new-line
|
||||
`(progn (fresh-line stream)
|
||||
(write-string first-line-indent ,stream)
|
||||
;; because we just started a new line, we
|
||||
;; should use format/indent to write string
|
||||
;; taking into account a main indentation level
|
||||
(format/indent ,reporter ,stream ,string))
|
||||
;; otherwise, just output our prefix
|
||||
`(write-string ,string ,stream))
|
||||
|
||||
|
||||
,@body))))
|
||||
|
||||
|
||||
|
||||
(defun format/indent (reporter stream control-string &rest format-arguments)
|
||||
"Writes a text to given stream with indentation, dictated by
|
||||
*indent-level* and *additional-indent*.
|
||||
|
||||
If first line start with ~&, then output will start from a fresh line.
|
||||
Otherwise, all lines except the first one are indented."
|
||||
|
||||
(with-slots (indent-space) reporter
|
||||
(let ((output (apply #'format nil control-string format-arguments)))
|
||||
;; if string starts with new line, then we have to add indentation
|
||||
;; otherwise we think it is already written to the stream
|
||||
(when (ppcre:scan "^~&" control-string)
|
||||
(fresh-line stream)
|
||||
(format stream (indent indent-space)))
|
||||
|
||||
;; if this (?!$) is indended to not insert spaces
|
||||
;; into empty lines, then (?m) should be inserted
|
||||
;; before
|
||||
;; TODO: make a pull-request
|
||||
(write-string (ppcre:regex-replace-all
|
||||
"(\\n)(?!$)"
|
||||
output
|
||||
(format nil "\\1~A"
|
||||
(indent indent-space)))
|
||||
stream))))
|
||||
|
||||
|
||||
(defclass reporter ()
|
||||
((indent-space :initform 2)))
|
||||
|
||||
(defun find-reporter (name)
|
||||
(make-instance
|
||||
(intern (format nil "~:@(~A~)-~A" name #.(string :reporter))
|
||||
(intern (format nil "~A.~:@(~A~)"
|
||||
#.(string :prove.reporter)
|
||||
name)
|
||||
:keyword))))
|
||||
|
||||
(defgeneric format-report (stream reporter report &rest args)
|
||||
(:method (stream (reporter null) (report report) &rest args)
|
||||
(apply #'format-report
|
||||
stream
|
||||
(find-reporter *default-reporter*)
|
||||
report
|
||||
args))
|
||||
(:method (stream (reporter reporter) (report report) &rest args)
|
||||
(declare (ignore args))
|
||||
(format/indent reporter stream "~&~A~%"
|
||||
(slot-value report 'description))))
|
||||
|
||||
(defgeneric print-error-report (reporter report stream)
|
||||
(:method ((reporter reporter) (report report) stream)
|
||||
;; Do nothing.
|
||||
)
|
||||
(:method ((reporter null) (report test-report) stream)
|
||||
(print-error-report (find-reporter *default-reporter*) report stream)))
|
||||
|
||||
(defgeneric print-plan-report (reporter num stream)
|
||||
(:method ((reporter null) num stream)
|
||||
(print-plan-report (find-reporter *default-reporter*) num stream))
|
||||
(:method ((reporter t) num stream)
|
||||
(declare (ignore reporter num))
|
||||
;; Do nothing
|
||||
))
|
||||
|
||||
(defgeneric print-finalize-report (reporter plan reports stream)
|
||||
(:method ((reporter null) plan reports stream)
|
||||
(print-finalize-report (find-reporter *default-reporter*)
|
||||
plan
|
||||
reports
|
||||
stream)))
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter.dot
|
||||
(:use :cl
|
||||
:prove.report
|
||||
:prove.reporter
|
||||
:prove.reporter.list
|
||||
:prove.color))
|
||||
(in-package :prove.reporter.dot)
|
||||
|
||||
(defclass dot-reporter (list-reporter) ())
|
||||
|
||||
(defmethod format-report (stream (reporter dot-reporter) (report comment-report) &rest args)
|
||||
(declare (ignore args))
|
||||
;; Do nothing. This reporter doesn't support 'diag'.
|
||||
)
|
||||
|
||||
(defmethod format-report (stream (reporter dot-reporter) (report test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(when (zerop *indent-level*)
|
||||
(if *enable-colors*
|
||||
(with-color ((cond
|
||||
((failed-report-p report) :red)
|
||||
((skipped-report-p report) :cyan)
|
||||
(T :gray)) :stream stream)
|
||||
(format stream (if (error-report-p report)
|
||||
"x"
|
||||
".")))
|
||||
(write-char (if (failed-report-p report) #\f #\.) stream))))
|
||||
|
||||
(defmethod print-finalize-report :before ((reporter dot-reporter) plan reports stream)
|
||||
(declare (ignore plan reports))
|
||||
(fresh-line stream))
|
||||
|
||||
(defmethod print-finalize-report :after ((reporter dot-reporter) plan reports stream)
|
||||
(let ((failed-reports (remove-if-not #'failed-report-p reports))
|
||||
(list-reporter (make-instance 'list-reporter)))
|
||||
(when failed-reports
|
||||
(format stream "~2&")
|
||||
(map nil
|
||||
(lambda (report)
|
||||
(format-report stream list-reporter report))
|
||||
failed-reports))))
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter.fiveam
|
||||
(:use :cl
|
||||
:prove.report
|
||||
:prove.reporter))
|
||||
(in-package :prove.reporter.fiveam)
|
||||
|
||||
(defclass fiveam-reporter (reporter) ())
|
||||
|
||||
(defmethod format-report (stream (reporter fiveam-reporter) (report comment-report) &rest args)
|
||||
(declare (ignore stream reporter report args))
|
||||
;; Do nothing. This reporter doesn't support 'diag'.
|
||||
)
|
||||
|
||||
(defmethod format-report (stream (reporter fiveam-reporter) (report test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(when (zerop *indent-level*)
|
||||
(write-char (if (failed-report-p report) #\f #\.) stream)))
|
||||
|
||||
(defmethod print-error-report ((reporter fiveam-reporter) (report failed-test-report) stream)
|
||||
(with-slots (description got got-form expected notp report-expected-label print-error-detail) report
|
||||
(cond
|
||||
(print-error-detail
|
||||
(format/indent reporter
|
||||
stream "~& ~:[(no description)~;~:*~A~]:~% ~S~:[~*~; => ~S~]~% is ~:[~;not ~]expected to ~:[be~;~:*~A~]~% ~S~%"
|
||||
description
|
||||
got-form
|
||||
(not (eq got got-form))
|
||||
got
|
||||
notp
|
||||
report-expected-label
|
||||
expected))
|
||||
(T (format/indent reporter stream "~& ~:[(no description)~;~:*~A~]: Failed~%"
|
||||
description)))))
|
||||
|
||||
(defmethod print-error-report ((reporter fiveam-reporter) (report composed-test-report) stream)
|
||||
(with-slots (plan children description) report
|
||||
(format/indent reporter stream "~& ~:[(no description)~;~:*~A~]:~%"
|
||||
description)
|
||||
(let ((*indent-level* (1+ *indent-level*)))
|
||||
(print-finalize-report reporter plan children stream))))
|
||||
|
||||
(defmethod print-error-report ((reporter fiveam-reporter) (report comment-report) stream)
|
||||
(format/indent reporter stream "~& ~A~%"
|
||||
(slot-value report 'description)))
|
||||
|
||||
(defmethod print-finalize-report ((reporter fiveam-reporter) plan reports stream)
|
||||
(let ((failed-count (count-if #'failed-report-p reports))
|
||||
(passed-count (count-if #'passed-report-p reports))
|
||||
(skipped-count (count-if #'skipped-report-p reports))
|
||||
(count (count-if #'test-report-p reports)))
|
||||
(format/indent reporter stream
|
||||
"~& Did ~D checks.~:[~*~; (planned ~D tests)~]~%"
|
||||
count
|
||||
(not (eql plan count))
|
||||
plan)
|
||||
(unless (zerop count)
|
||||
(format/indent reporter
|
||||
stream " Pass: ~D (~3D%)~%" passed-count (round (* (/ passed-count count) 100)))
|
||||
(unless (zerop skipped-count)
|
||||
(format/indent reporter
|
||||
stream " Skip: ~D (~3D%)~%" skipped-count (round (* (/ skipped-count count) 100))))
|
||||
(format/indent reporter
|
||||
stream " Fail: ~D (~3D%)~%" failed-count (round (* (/ failed-count count) 100))))
|
||||
(unless (zerop failed-count)
|
||||
(format/indent reporter
|
||||
stream "~2& Failure Details:~% --------------------------------~%")
|
||||
(loop for report across reports
|
||||
when (failed-report-p report)
|
||||
do (print-error-report reporter report stream)
|
||||
(format/indent reporter stream " --------------------------------~%")))))
|
||||
|
|
@ -0,0 +1,171 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter.list
|
||||
(:use :cl
|
||||
:prove.report
|
||||
:prove.reporter)
|
||||
(:import-from :prove.color
|
||||
:with-color)
|
||||
(:export :list-reporter
|
||||
:report-expected-line))
|
||||
(in-package :prove.reporter.list)
|
||||
|
||||
(defclass list-reporter (reporter) ())
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report comment-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:white :stream stream)
|
||||
(format/indent reporter stream (slot-value report 'description)))
|
||||
(terpri stream)))
|
||||
|
||||
|
||||
(defun omit-long-value (value)
|
||||
(typecase value
|
||||
(string
|
||||
(if (< 500 (length value))
|
||||
(format nil "\"~A ...\"" (subseq value 0 94))
|
||||
(prin1-to-string value)))
|
||||
(otherwise
|
||||
(let ((value (prin1-to-string value)))
|
||||
(if (< 500 (length value))
|
||||
(format nil "~A ..." (subseq value 0 96))
|
||||
value)))))
|
||||
|
||||
|
||||
(defgeneric report-expected-line (report)
|
||||
(:documentation "Reports about failed or passed test.
|
||||
Should return a string with description of what have happened.")
|
||||
|
||||
(:method ((report normal-test-report))
|
||||
(with-slots (got got-form notp report-expected-label expected) report
|
||||
(escape-tildes
|
||||
(format nil "~A is ~:[~;not ~]expected to ~:[be~;~:*~A~] ~A~:[ (got ~S)~;~*~]"
|
||||
(omit-long-value (or got-form got))
|
||||
notp
|
||||
report-expected-label
|
||||
(omit-long-value expected)
|
||||
(eq got got-form)
|
||||
got)))))
|
||||
|
||||
|
||||
(defun escape-tildes (text)
|
||||
(ppcre:regex-replace-all "~" text "~~"))
|
||||
|
||||
|
||||
(defun possible-report-description (report)
|
||||
(cond
|
||||
((slot-value report 'description)
|
||||
(format nil "~A~:[~; (Skipped)~]"
|
||||
(escape-tildes (slot-value report 'description))
|
||||
(skipped-report-p report)))
|
||||
(T (report-expected-line report))))
|
||||
|
||||
(defun print-duration (stream duration &optional slow-threshold)
|
||||
(let ((color (if slow-threshold
|
||||
(cond
|
||||
((< slow-threshold duration) :red)
|
||||
((< (/ slow-threshold 2) duration) :yellow))
|
||||
:gray)))
|
||||
(when color
|
||||
(with-color (color :stream stream)
|
||||
(format stream "(~Dms)" duration)))))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report normal-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:green :stream stream)
|
||||
(with-additional-indent (reporter stream "✓ ")
|
||||
(let ((description (possible-report-description report))
|
||||
(duration (slot-value report 'duration)))
|
||||
(when description
|
||||
(with-color (:gray :stream stream)
|
||||
(format/indent reporter stream description)))
|
||||
|
||||
(when duration
|
||||
(format stream " ")
|
||||
(print-duration stream duration (slot-value report 'slow-threshold))))
|
||||
(terpri stream)))))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report skipped-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:cyan :stream stream)
|
||||
(with-additional-indent (reporter stream "- ")
|
||||
(let ((description (possible-report-description report)))
|
||||
(when description
|
||||
(format/indent reporter stream description))))
|
||||
(terpri stream))))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report failed-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:red :stream stream)
|
||||
(with-additional-indent (reporter stream "× ")
|
||||
(let ((description (possible-report-description report))
|
||||
(duration (slot-value report 'duration)))
|
||||
(when description
|
||||
(format/indent reporter stream description))
|
||||
(when duration
|
||||
(format stream " ")
|
||||
(print-duration stream duration (slot-value report 'slow-threshold))))
|
||||
(when (slot-value report 'description)
|
||||
(format/indent reporter stream
|
||||
(concatenate 'string "~&" (report-expected-line report)))))
|
||||
(terpri stream))))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report error-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
;; format/indent
|
||||
(with-additional-indent (reporter stream "~& ")
|
||||
(with-color (:red :stream stream)
|
||||
(with-additional-indent (reporter stream "× ")
|
||||
(when (slot-value report 'description)
|
||||
(format/indent reporter stream "~A~%" (slot-value report 'description)))
|
||||
(format/indent reporter stream "Raised an error ~A (expected: ~S)"
|
||||
(slot-value report 'got)
|
||||
(slot-value report 'expected)))))
|
||||
(terpri stream))
|
||||
|
||||
(defmethod format-report (stream (reporter list-reporter) (report composed-test-report) &rest args)
|
||||
(declare (ignore args))
|
||||
;; Do nothing
|
||||
)
|
||||
|
||||
(defmethod print-plan-report ((reporter list-reporter) num stream)
|
||||
(when (numberp num)
|
||||
(format/indent reporter stream "~&1..~A~2%" num)))
|
||||
|
||||
(defmethod print-finalize-report ((reporter list-reporter) plan reports stream)
|
||||
(let ((failed-count (count-if #'failed-report-p reports))
|
||||
(skipped-count (count-if #'skipped-report-p reports))
|
||||
(count (count-if #'test-report-p reports)))
|
||||
(format/indent reporter stream "~2&")
|
||||
(cond
|
||||
((eq plan :unspecified)
|
||||
(with-color (:yellow :stream stream)
|
||||
(format/indent reporter stream
|
||||
"△ Tests were run but no plan was declared.~%")))
|
||||
((and plan
|
||||
(not (= count plan)))
|
||||
(with-color (:yellow :stream stream)
|
||||
(format/indent reporter stream
|
||||
"△ Looks like you planned ~D test~:*~P but ran ~A.~%"
|
||||
plan count))))
|
||||
(if (< 0 failed-count)
|
||||
(with-color (:red :stream stream)
|
||||
(format/indent reporter stream
|
||||
"× ~D of ~D test~:*~P failed"
|
||||
failed-count count))
|
||||
(with-color (:green :stream stream)
|
||||
(format/indent reporter stream
|
||||
"✓ ~D test~:*~P completed" count)))
|
||||
(format stream " ")
|
||||
(print-duration stream
|
||||
(reduce #'+
|
||||
(remove-if-not #'test-report-p reports)
|
||||
:key (lambda (report) (or (slot-value report 'duration) 0))))
|
||||
(terpri stream)
|
||||
(unless (zerop skipped-count)
|
||||
(with-color (:cyan :stream stream)
|
||||
(format/indent reporter stream "● ~D test~:*~P skipped" skipped-count))
|
||||
(terpri stream))))
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.reporter.tap
|
||||
(:use :cl
|
||||
:prove.report
|
||||
:prove.reporter))
|
||||
(in-package :prove.reporter.tap)
|
||||
|
||||
(defclass tap-reporter (reporter)
|
||||
((indent-space :initform 4)))
|
||||
|
||||
(defmethod format-report (stream (reporter tap-reporter) (report comment-report) &rest args)
|
||||
(declare (ignore args))
|
||||
(format/indent reporter stream "~&# ~A~%"
|
||||
(slot-value report 'description)))
|
||||
|
||||
(defmethod format-report (stream (reporter tap-reporter) (report test-report) &key count)
|
||||
(with-slots (description print-error-detail) report
|
||||
(format/indent reporter stream
|
||||
"~&~:[not ~;~]ok~:[~;~:* ~D~]~:[~;~:* - ~A~]~%"
|
||||
(or (passed-report-p report)
|
||||
(skipped-report-p report))
|
||||
count
|
||||
description)
|
||||
(print-error-report reporter report stream)))
|
||||
|
||||
(defmethod format-report (stream (reporter tap-reporter) (report skipped-test-report) &key count)
|
||||
(format/indent reporter stream
|
||||
"~&ok~:[~;~:* ~D~] - skip~:[~;~:* ~A~]~%"
|
||||
count
|
||||
(slot-value report 'description)))
|
||||
|
||||
(defmethod print-error-report ((reporter tap-reporter) (report failed-test-report) stream)
|
||||
(with-slots (got got-form expected notp report-expected-label print-error-detail) report
|
||||
(when print-error-detail
|
||||
(format/indent reporter stream
|
||||
"~&# got: ~S~:[~*~; => ~S~]~%# ~:[~;not ~]expected~:[~;~:* to ~A~]: ~S~%"
|
||||
got-form
|
||||
(not (eq got got-form))
|
||||
got
|
||||
notp
|
||||
report-expected-label
|
||||
expected))))
|
||||
|
||||
(defmethod print-plan-report ((reporter tap-reporter) num stream)
|
||||
(when (numberp num)
|
||||
(format-report stream
|
||||
reporter
|
||||
(make-instance 'report
|
||||
:description (format nil "1..~A" num)))))
|
||||
|
||||
(defmethod print-finalize-report ((reporter tap-reporter) plan reports stream)
|
||||
(let ((failed-count (count-if #'failed-report-p reports))
|
||||
(count (count-if #'test-report-p reports)))
|
||||
(cond
|
||||
((eq plan :unspecified)
|
||||
(format/indent reporter stream
|
||||
"~&# Tests were run but no plan was declared.~%"))
|
||||
((and plan
|
||||
(not (= count plan)))
|
||||
(format/indent reporter stream
|
||||
"~&# Looks like you planned ~D test~:*~P but ran ~A.~%"
|
||||
plan count)))
|
||||
(fresh-line stream)
|
||||
(if (< 0 failed-count)
|
||||
(format/indent reporter stream
|
||||
"# Looks like you failed ~D test~:*~P of ~A run."
|
||||
failed-count count)
|
||||
(format/indent reporter stream "# All ~D test~:*~P passed."
|
||||
count))
|
||||
(terpri stream)))
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.suite
|
||||
(:use :cl)
|
||||
(:import-from :prove.output
|
||||
:*test-result-output*)
|
||||
(:import-from :prove.report
|
||||
:report
|
||||
:failed-report-p)
|
||||
(:import-from :prove.reporter
|
||||
:print-plan-report
|
||||
:print-finalize-report)
|
||||
(:import-from :prove.asdf
|
||||
:*last-suite-report*)
|
||||
(:export :*suite*
|
||||
|
||||
:current-suite
|
||||
|
||||
:suite
|
||||
:package-suite
|
||||
:suite-plan
|
||||
:test-count
|
||||
:failed
|
||||
:reports
|
||||
:slow-threshold
|
||||
:*default-slow-threshold*
|
||||
|
||||
:add-report
|
||||
:plan
|
||||
:finalize))
|
||||
(in-package :prove.suite)
|
||||
|
||||
(defparameter *suite* nil)
|
||||
(defparameter *default-slow-threshold* 75)
|
||||
|
||||
(defclass suite ()
|
||||
((plan :initarg :plan
|
||||
:initform :unspecified
|
||||
:accessor suite-plan)
|
||||
(slow-threshold :initarg :slow-threshold
|
||||
:initform *default-slow-threshold*)
|
||||
(test-count :initform 0
|
||||
:accessor test-count)
|
||||
(failed :initform 0
|
||||
:accessor failed)
|
||||
(reports :initform (make-array 0 :adjustable t :fill-pointer 0)
|
||||
:accessor reports)))
|
||||
|
||||
(defun slow-threshold (&optional new-threshold)
|
||||
(if new-threshold
|
||||
(setf (slot-value (current-suite) 'slow-threshold) new-threshold)
|
||||
(slot-value (current-suite) 'slow-threshold)))
|
||||
|
||||
(defclass package-suite (suite) ())
|
||||
|
||||
(defvar *defined-suites* (make-hash-table :test 'equal))
|
||||
|
||||
(defun find-package-suite (package-designator)
|
||||
(let ((package (typecase package-designator
|
||||
(package package-designator)
|
||||
(T (find-package package-designator)))))
|
||||
(or (gethash (package-name package) *defined-suites*)
|
||||
(setf (gethash (package-name package) *defined-suites*)
|
||||
(make-instance 'package-suite)))))
|
||||
|
||||
(defun current-suite ()
|
||||
(or *suite*
|
||||
(find-package-suite *package*)))
|
||||
|
||||
(defun reset-suite (suite)
|
||||
(with-slots (test-count failed reports) suite
|
||||
(setf test-count 0)
|
||||
(setf failed 0)
|
||||
(setf reports (make-array 0 :adjustable t :fill-pointer 0))))
|
||||
|
||||
(defun add-report (report suite)
|
||||
(check-type report report)
|
||||
(when (failed-report-p report)
|
||||
(incf (slot-value suite 'failed)))
|
||||
(vector-push-extend report (slot-value suite 'reports)))
|
||||
|
||||
(defun plan (num)
|
||||
(let ((suite (current-suite)))
|
||||
(setf (slot-value suite 'plan) num)
|
||||
(reset-suite suite))
|
||||
(print-plan-report nil num *test-result-output*))
|
||||
|
||||
(defun finalize (&optional (suite (current-suite)))
|
||||
(with-slots (plan reports failed) suite
|
||||
(print-finalize-report nil plan reports *test-result-output*)
|
||||
(setf *last-suite-report*
|
||||
(list :plan plan :failed failed))
|
||||
(zerop failed)))
|
||||
|
|
@ -0,0 +1,366 @@
|
|||
(in-package :cl-user)
|
||||
(defpackage prove.test
|
||||
(:use :cl)
|
||||
(:import-from :prove.output
|
||||
:*test-result-output*)
|
||||
(:import-from :prove.report
|
||||
:test-report-p
|
||||
:passed-test-report
|
||||
:failed-test-report
|
||||
:error-test-report
|
||||
:skipped-test-report
|
||||
:comment-report
|
||||
:composed-test-report
|
||||
:failed-report-p
|
||||
:duration)
|
||||
(:import-from :prove.reporter
|
||||
:format-report
|
||||
:*indent-level*
|
||||
:*additional-indent*)
|
||||
(:import-from :prove.suite
|
||||
:suite
|
||||
:*suite*
|
||||
:suite-plan
|
||||
:test-count
|
||||
:failed
|
||||
:reports
|
||||
:slow-threshold
|
||||
:current-suite
|
||||
:finalize
|
||||
:add-report)
|
||||
(:import-from :alexandria
|
||||
:with-gensyms
|
||||
:once-only)
|
||||
(:export :*default-test-function*
|
||||
:*debug-on-error*
|
||||
|
||||
:ok
|
||||
:is
|
||||
:isnt
|
||||
:is-values
|
||||
:is-print
|
||||
:is-condition
|
||||
:is-error
|
||||
:is-type
|
||||
:like
|
||||
:is-expand
|
||||
:diag
|
||||
:skip
|
||||
:pass
|
||||
:fail
|
||||
:subtest
|
||||
|
||||
:*gensym-prefix*
|
||||
|
||||
:deftest
|
||||
:run-test
|
||||
:run-test-package
|
||||
:run-test-all
|
||||
:remove-test
|
||||
:remove-test-all))
|
||||
(in-package :prove.test)
|
||||
|
||||
(defvar *debug-on-error* nil)
|
||||
(defvar *default-test-function* #'equal)
|
||||
|
||||
(defun parse-description-and-test (args)
|
||||
(if (consp args)
|
||||
(case (length args)
|
||||
(1 (car args))
|
||||
(2 (if (eq :test (car args))
|
||||
(values nil (cadr args))
|
||||
(car args)))
|
||||
(t (let ((k (member :test args)))
|
||||
(case (length k)
|
||||
((0 1) (car args))
|
||||
(2 (values (car args) (cadr k)))
|
||||
(t (values (nth 2 k) (cadr k)))))))
|
||||
args))
|
||||
|
||||
(defun test (got expected args
|
||||
&key notp
|
||||
duration
|
||||
(got-form nil got-form-supplied-p)
|
||||
(test-fn *default-test-function*)
|
||||
(passed-report-class 'passed-test-report)
|
||||
(failed-report-class 'failed-test-report)
|
||||
report-expected-label
|
||||
(print-error-detail t)
|
||||
(output t))
|
||||
(multiple-value-bind (desc arg-test)
|
||||
(parse-description-and-test args)
|
||||
(let* ((test-function (or arg-test test-fn))
|
||||
(result (funcall test-function got expected))
|
||||
(result (if notp (not result) result))
|
||||
(suite (current-suite))
|
||||
(report (apply #'make-instance
|
||||
(if result
|
||||
passed-report-class
|
||||
failed-report-class)
|
||||
:duration duration
|
||||
:slow-threshold (slot-value suite 'slow-threshold)
|
||||
:test-function test-function
|
||||
:notp notp
|
||||
:got got
|
||||
:got-form (if got-form-supplied-p
|
||||
got-form
|
||||
got)
|
||||
:expected expected
|
||||
:description desc
|
||||
:print-error-detail print-error-detail
|
||||
(and report-expected-label
|
||||
(list :report-expected-label report-expected-label)))))
|
||||
(add-report report suite)
|
||||
(unless result
|
||||
(incf (failed suite)))
|
||||
(incf (test-count suite))
|
||||
(when output
|
||||
(format-report *test-result-output* nil report :count (test-count suite)))
|
||||
(values result report))))
|
||||
|
||||
(defmacro with-duration (((duration result) form) &body body)
|
||||
(with-gensyms (start end)
|
||||
`(let* ((,start (get-internal-real-time))
|
||||
(,result ,form)
|
||||
(,end (get-internal-real-time))
|
||||
(,duration (- ,end ,start)))
|
||||
,@body)))
|
||||
|
||||
(defmacro with-catching-errors ((&key description expected) &body body)
|
||||
(with-gensyms (e suite report)
|
||||
`(if *debug-on-error*
|
||||
(progn ,@body)
|
||||
(handler-case (progn ,@body)
|
||||
(error (,e)
|
||||
(let ((,suite (current-suite))
|
||||
(,report (make-instance 'error-test-report
|
||||
:got ,e
|
||||
:got-form ,e
|
||||
:expected ,expected
|
||||
:description ,description
|
||||
:duration nil)))
|
||||
(add-report ,report ,suite)
|
||||
(incf (failed ,suite))
|
||||
(incf (test-count ,suite))
|
||||
(format-report *test-result-output* nil ,report :count (test-count ,suite))))))))
|
||||
|
||||
(defmacro ok (test &optional desc)
|
||||
(with-gensyms (duration result)
|
||||
(once-only (test desc)
|
||||
`(with-catching-errors (:expected T :description ,desc)
|
||||
(with-duration ((,duration ,result) ,test)
|
||||
(test ,result t ,desc
|
||||
:duration ,duration
|
||||
:test-fn (lambda (x y)
|
||||
(eq (not (null x)) y))
|
||||
:got-form ,test))))))
|
||||
|
||||
(defmacro is (got expected &rest args)
|
||||
(with-gensyms (duration result new-args desc)
|
||||
(once-only (expected)
|
||||
`(let* ((,new-args (list ,@args))
|
||||
(,desc (parse-description-and-test ,new-args)))
|
||||
(with-catching-errors (:description ,desc :expected ,expected)
|
||||
(with-duration ((,duration ,result) ,got)
|
||||
(test ,result ,expected ,new-args
|
||||
:duration ,duration)))))))
|
||||
|
||||
(defmacro isnt (got expected &rest args)
|
||||
(with-gensyms (duration result new-args desc)
|
||||
(once-only (expected)
|
||||
`(let* ((,new-args (list ,@args))
|
||||
(,desc (parse-description-and-test ,new-args)))
|
||||
(with-catching-errors (:description ,desc :expected ,expected)
|
||||
(with-duration ((,duration ,result) ,got)
|
||||
(test ,result ,expected ,new-args
|
||||
:notp t
|
||||
:duration ,duration)))))))
|
||||
|
||||
(defmacro is-values (got expected &rest args)
|
||||
`(is (multiple-value-list ,got) ,expected ,@args))
|
||||
|
||||
(defmacro is-print (got expected &optional desc)
|
||||
(with-gensyms (output duration duration-inner)
|
||||
(once-only (expected desc)
|
||||
`(with-catching-errors (:description ,desc :expected ,expected)
|
||||
(let* (,duration
|
||||
(,output (with-output-to-string (*standard-output*)
|
||||
(with-duration ((,duration-inner ,output) ,got)
|
||||
(declare (ignore ,output))
|
||||
(setq ,duration ,duration-inner)))))
|
||||
(test ,output ,expected ,desc
|
||||
:duration ,duration
|
||||
:got-form ',got
|
||||
:test-fn #'string=
|
||||
:report-expected-label "output"))))))
|
||||
|
||||
(defmacro is-condition (form condition &optional desc)
|
||||
(with-gensyms (error duration)
|
||||
`(with-duration ((,duration ,error) (handler-case ,form
|
||||
(condition (,error) ,error)))
|
||||
(test ,error
|
||||
,(if (and (listp condition) (eq 'quote (car condition)))
|
||||
condition
|
||||
`(quote ,condition))
|
||||
,desc
|
||||
:duration ,duration
|
||||
:got-form ',form
|
||||
:test-fn #'typep
|
||||
:report-expected-label "raise a condition"))))
|
||||
|
||||
;;; alias is-error to is-condition
|
||||
(setf (macro-function 'is-error) (macro-function 'is-condition))
|
||||
|
||||
(defmacro is-type (got expected-type &optional desc)
|
||||
(with-gensyms (duration result)
|
||||
(once-only (desc expected-type)
|
||||
`(with-catching-errors (:description ,desc :expected ,expected-type)
|
||||
(with-duration ((,duration ,result) ,got)
|
||||
(test ,result ,expected-type ,desc
|
||||
:duration ,duration
|
||||
:got-form ',got
|
||||
:test-fn #'typep
|
||||
:report-expected-label "be a type of"))))))
|
||||
|
||||
(defmacro like (got regex &optional desc)
|
||||
(with-gensyms (duration result)
|
||||
(once-only (regex desc)
|
||||
`(with-catching-errors (:description ,desc :expected ,regex)
|
||||
(with-duration ((,duration ,result) ,got)
|
||||
(test ,result ,regex ,desc
|
||||
:duration ,duration
|
||||
:test-fn (lambda (x y) (not (null (ppcre:scan y x))))
|
||||
:report-expected-label "be like"))))))
|
||||
|
||||
(defvar *gensym-prefix* "$")
|
||||
(defvar *gensym-alist* nil)
|
||||
|
||||
(defun gensymp (val)
|
||||
(and (symbolp val)
|
||||
(string= (subseq (symbol-name val) 0 (length *gensym-prefix*)) *gensym-prefix*)))
|
||||
|
||||
(defgeneric gensym-tree-equal (x y)
|
||||
(:method (x y)
|
||||
(if (and (gensymp y) (symbolp x))
|
||||
(if (assoc y *gensym-alist*)
|
||||
(eq x (cdr (assoc y *gensym-alist*)))
|
||||
(unless (rassoc x *gensym-alist*)
|
||||
(setf *gensym-alist* `((,y . ,x) ,@*gensym-alist*))
|
||||
t))
|
||||
(equal x y)))
|
||||
(:method ((x cons) (y cons))
|
||||
(loop for a in x for b in y
|
||||
always (gensym-tree-equal a b))))
|
||||
|
||||
(defmacro is-expand (got expected &optional desc)
|
||||
(with-gensyms (duration expanded)
|
||||
(once-only (desc)
|
||||
`(with-duration ((,duration ,expanded) (macroexpand-1 ',got))
|
||||
(let (*gensym-alist*)
|
||||
(test ,expanded ',expected ,desc
|
||||
:duration ,duration
|
||||
:got-form ',got
|
||||
:report-expected-label "be expanded to"
|
||||
:test-fn #'gensym-tree-equal))))))
|
||||
|
||||
(defun diag (desc)
|
||||
(let ((report (make-instance 'comment-report
|
||||
:description desc)))
|
||||
(add-report report (current-suite))
|
||||
(format-report *test-result-output* nil report)))
|
||||
|
||||
(defun skip (how-many why &rest format-args)
|
||||
(check-type how-many integer)
|
||||
(dotimes (i how-many)
|
||||
(test t t (apply #'format nil why format-args)
|
||||
:passed-report-class 'skipped-test-report)))
|
||||
|
||||
(defun pass (desc)
|
||||
(test t t desc))
|
||||
|
||||
(defun fail (desc)
|
||||
(test t nil desc
|
||||
:print-error-detail nil))
|
||||
|
||||
(defun %subtest (desc body-fn)
|
||||
(diag desc)
|
||||
(let ((report
|
||||
(let ((*suite* (make-instance 'suite))
|
||||
(*indent-level* (1+ *indent-level*))
|
||||
(*additional-indent* 0))
|
||||
(if *debug-on-error*
|
||||
(funcall body-fn)
|
||||
(handler-case (funcall body-fn)
|
||||
(error (e)
|
||||
(let ((error-report
|
||||
(make-instance 'error-test-report
|
||||
:expected :non-error
|
||||
:got e
|
||||
:description (format nil "Aborted due to an error in subtest ~S" desc))))
|
||||
(add-report error-report *suite*)
|
||||
(format-report *test-result-output* nil error-report :count (test-count *suite*))))))
|
||||
(make-instance 'composed-test-report
|
||||
:duration (reduce #'+
|
||||
(remove-if-not #'test-report-p (reports *suite*))
|
||||
:key (lambda (report) (or (slot-value report 'duration) 0)))
|
||||
:plan (suite-plan *suite*)
|
||||
:description desc
|
||||
:children (reports *suite*))))
|
||||
(suite (current-suite)))
|
||||
(add-report report suite)
|
||||
(incf (test-count suite))
|
||||
(format-report *test-result-output* nil report :count (test-count suite))))
|
||||
|
||||
(defmacro subtest (desc &body body)
|
||||
`(%subtest ,desc (lambda () ,@body)))
|
||||
|
||||
(defvar *package-tests* (make-hash-table))
|
||||
|
||||
(defmacro deftest (name &body test-forms)
|
||||
(let ((tests (gensym "TESTS"))
|
||||
(test (gensym "TEST"))
|
||||
(test-fn (gensym "TEST-FN")))
|
||||
`(progn
|
||||
(unless (nth-value 1 (gethash *package* *package-tests*))
|
||||
(setf (gethash *package* *package-tests*) '()))
|
||||
(let* ((,tests (gethash *package* *package-tests*))
|
||||
(,test (assoc ',name ,tests :test #'string=))
|
||||
(,test-fn (lambda ()
|
||||
(subtest (princ-to-string ',name)
|
||||
,@test-forms))))
|
||||
(if ,test
|
||||
(rplacd ,test ,test-fn)
|
||||
(push (cons ',name ,test-fn) (gethash *package* *package-tests*)))
|
||||
',name))))
|
||||
|
||||
(defun run-test (name)
|
||||
(let ((test (assoc name
|
||||
(gethash *package* *package-tests*)
|
||||
:test #'string=)))
|
||||
(unless test
|
||||
(error "Test not found: ~S" name))
|
||||
(funcall (cdr test))))
|
||||
|
||||
(defun run-test-package (package-designator)
|
||||
(let ((*package* (typecase package-designator
|
||||
(package package-designator)
|
||||
(T (find-package package-designator)))))
|
||||
(loop for (name . test-fn) in (reverse (gethash *package* *package-tests*))
|
||||
do (funcall test-fn))
|
||||
(finalize)))
|
||||
|
||||
(defun run-test-all ()
|
||||
(maphash (lambda (package tests)
|
||||
(declare (ignore tests))
|
||||
(run-test-package package))
|
||||
*package-tests*))
|
||||
|
||||
(defun remove-test (name)
|
||||
(setf (gethash *package* *package-tests*)
|
||||
(delete name
|
||||
(gethash *package* *package-tests*)
|
||||
:key #'car
|
||||
:test #'string=)))
|
||||
|
||||
(defun remove-test-all ()
|
||||
(setf (gethash *package* *package-tests*) nil))
|
||||
Loading…
Add table
Add a link
Reference in a new issue