├── README.md ├── checkl-docs.asd ├── checkl-test.asd ├── checkl.asd ├── checkl.lisp ├── doc ├── .gitignore ├── generate.lisp ├── intro.md └── simple.css ├── formalize.lisp ├── package.lisp └── t ├── package.lisp ├── test-values └── test.lisp /README.md: -------------------------------------------------------------------------------- 1 | # CheckL 2 | 3 | Why write programs in Common Lisp but tests like Java? 4 | 5 | My workflow for writing Common Lisp tends to be like this: 6 | 7 | * Write a bit of lisp, perhaps a function, class, or structure 8 | * Write a snippet in a scratch buffer to test 9 | * Fix if necessary and repeat 10 | 11 | Testing is already inherent in this process, all we need is a little 12 | bit of Common Lisp magic to take advantage of it. Thus, CheckL: 13 | 14 | ```lisp 15 | (defun foo () 16 | (+ 1 1)) 17 | 18 | (check () (foo)) ;; => 2 19 | 20 | (defun foo () 21 | (+ 1 2)) 22 | 23 | (check () (foo)) 24 | 25 | | 26 | v 27 | 28 | Result 0 has changed: 3 29 | Previous result: 2 30 | [Condition of type CHECKL::RESULT-ERROR] 31 | 32 | Restarts: 33 | 0: [USE-NEW-VALUE] The new value is correct, use it from now on. 34 | 1: [SKIP-TEST] Skip this, leaving the old value, but continue testing 35 | 2: [RETRY] Retry SLIME interactive evaluation request. 36 | 3: [*ABORT] Return to SLIME's top level. 37 | 4: [TERMINATE-THREAD] Terminate this thread (#) 38 | ``` 39 | 40 | [See the full documentation for more details!](http://rpav.github.com/CheckL) 41 | -------------------------------------------------------------------------------- /checkl-docs.asd: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel :load-toplevel :execute) 2 | (asdf:load-system :cl-gendoc)) 3 | 4 | (defsystem :checkl-docs 5 | :depends-on (:checkl :cl-gendoc) 6 | 7 | :serial t 8 | :pathname "doc" 9 | 10 | :components 11 | ((:file "generate"))) 12 | 13 | (gendoc:define-gendoc-load-op :checkl-docs :checkl.docs 'generate) 14 | -------------------------------------------------------------------------------- /checkl-test.asd: -------------------------------------------------------------------------------- 1 | (cl:eval-when (:load-toplevel :execute) 2 | (asdf:load-system :fiveam) 3 | (asdf:load-system :checkl)) 4 | 5 | (defsystem :checkl-test 6 | :description "CheckL: Testing testing testing" 7 | :version "1.0" 8 | :author "Ryan Pavlik " 9 | :license "LLGPL, BSD" 10 | 11 | :depends-on (:fiveam :checkl) 12 | :serial t 13 | :pathname "t" 14 | 15 | :components ((:file "package") 16 | (checkl:tests "test") 17 | (checkl:test-values "test-values" 18 | :package :checkl-tests))) 19 | 20 | (checkl:define-test-op :checkl-test) 21 | -------------------------------------------------------------------------------- /checkl.asd: -------------------------------------------------------------------------------- 1 | (defsystem :checkl 2 | :description "CheckL: Dynamic testing for Common Lisp" 3 | :version "1.0" 4 | :author "Ryan Pavlik " 5 | :license "LLGPL, BSD" 6 | 7 | :depends-on (:marshal) 8 | :serial t 9 | 10 | :components ((:file "package") 11 | (:file "checkl") 12 | 13 | #+5am 14 | (:file "formalize"))) 15 | 16 | (defmethod perform ((o test-op) (c (eql (find-system :checkl)))) 17 | (operate 'asdf:load-op :checkl-test) 18 | (operate 'asdf:test-op :checkl-test)) 19 | -------------------------------------------------------------------------------- /checkl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :checkl) 2 | 3 | (defstruct package-tests 4 | (results (make-hash-table :test 'equalp)) 5 | (categories (make-hash-table :test 'equalp)) 6 | (lambdas (make-hash-table :test 'equalp)) 7 | (default-checkl-store nil)) 8 | 9 | (defvar *all-tests* (make-hash-table)) 10 | (defvar *definitions-only* nil) 11 | 12 | (define-condition result-error (error) 13 | ((result-index :initarg :result-index :reader result-error-index :initform nil) 14 | (result-value :initarg :result-value :reader result-error-value :initform nil) 15 | (last-value :initarg :last-value :reader result-error-last :initform nil)) 16 | (:report (lambda (c s) 17 | (format s "Result ~A has changed: ~A~%Previous result: ~A" 18 | (result-error-index c) 19 | (result-error-value c) 20 | (result-error-last c))))) 21 | 22 | (defgeneric result-equalp (o1 o2) 23 | (:documentation "Generic function to compare test results `O1` to 24 | `O2`. Defaults to `EQUALP`.")) 25 | 26 | (defmethod result-equalp (o1 o2) 27 | (equalp o1 o2)) 28 | 29 | (defgeneric result-translate (result) 30 | (:documentation "RESULT-TRANSLATE is called on RESULT before calling 31 | RESULT-EQUALP and before storing RESULT. This defaults to RESULT, but 32 | may be useful for converting more complex objects into simpler 33 | objects. For sequences and structures, COPY-SEQ and COPY-STRUCTURE 34 | are called. For STANDARD-OBJECT instances, (MS:UNMARSHAL (MS:MARSHAL 35 | OBJECT)) is called.")) 36 | 37 | (defmethod result-translate (result) result) 38 | 39 | (defmethod result-translate ((result sequence)) 40 | (copy-seq result)) 41 | 42 | (defmethod result-translate ((result structure-object)) 43 | (copy-structure result)) 44 | 45 | (defmethod result-translate ((result standard-object)) 46 | (ms:unmarshal (ms:marshal result))) 47 | 48 | (defun current-tests () 49 | (or (gethash *package* *all-tests*) 50 | (setf (gethash *package* *all-tests*) 51 | (make-package-tests)))) 52 | 53 | (defun ensure-test (test-name test-category test-body function) 54 | (let* ((tests (current-tests)) 55 | (results (package-tests-results tests)) 56 | (categories (package-tests-categories tests)) 57 | (lambdas (package-tests-lambdas tests))) 58 | (when (and test-name (gethash test-body results)) 59 | (setf (gethash test-name results) 60 | (gethash test-body results)) 61 | (remhash test-body results) 62 | 63 | (when test-category 64 | (map 'nil (lambda (x) 65 | (if (equalp x test-body) test-name x)) 66 | (gethash test-category categories)))) 67 | 68 | (when test-category 69 | (let ((name (or test-name test-body))) 70 | (pushnew name (gethash test-category categories) 71 | :test 'equalp))) 72 | 73 | (setf (gethash (or test-name test-body) lambdas) 74 | function))) 75 | 76 | (defun verify-result (name result) 77 | (let* ((results (package-tests-results (current-tests))) 78 | (last-result (gethash name results)) 79 | (index-base 0) 80 | (cur-result result) 81 | result-index result-value error-p) 82 | (loop 83 | (restart-case 84 | (loop for val in cur-result 85 | for prev in last-result 86 | for i from 0 87 | do (unless (result-equalp val prev) 88 | (setf result-index i) 89 | (setf result-value val) 90 | (error (make-condition 'result-error 91 | :result-index (+ i index-base) 92 | :result-value val 93 | :last-value prev))) 94 | finally 95 | (unless error-p 96 | (setf (gethash name results) result)) 97 | (return-from verify-result result)) 98 | (use-new-value () 99 | :report "The new value is correct, use it from now on." 100 | :test 101 | #-(or allegro ccl clisp) (lambda (c) (typep c 'result-error)) 102 | #+(or allegro ccl clisp) (lambda (c) (or (null c) (typep c 'result-error))) 103 | (incf index-base (1+ result-index)) 104 | (setf (nth result-index last-result) result-value) 105 | (setf cur-result (nthcdr (1+ result-index) cur-result)) 106 | (setf last-result (nthcdr (1+ result-index) last-result))) 107 | (skip-test () 108 | :report "Skip this, leaving the old value, but continue testing" 109 | :test 110 | #-(or allegro ccl clisp) (lambda (c) (typep c 'result-error)) 111 | #+(or allegro ccl clisp) (lambda (c) (or (null c) (typep c 'result-error))) 112 | (incf index-base (1+ result-index)) 113 | (setf cur-result (nthcdr (1+ result-index) cur-result)) 114 | (setf last-result (nthcdr (1+ result-index) last-result)) 115 | (setf error-p t)))))) 116 | 117 | (defmacro check ((&key name (category :default) (output-p nil)) &body body) 118 | "=> test-results 119 | 120 | Run `BODY`. Check resulting values against the last run using 121 | `CHECKL:RESULT-EQUALP`, or store them if this is the first run. 122 | Sameness of the test is determined by comparing the body with 123 | `EQUALP`, or by `NAME`. 124 | 125 | `NAME` may be specified to name a test. If the test exists but is 126 | anonymous (i.e., `NAME` has not been specified), specifying `NAME` 127 | will name the test and it will no longer be anonymous. 128 | 129 | `CATEGORY` may be specified for running groups of tests. 130 | 131 | If `OUTPUT-P` is `t`, the results will be printed to 132 | `*standard-output*` as well as returned. This may be helpful if the 133 | results are too long to see in your emacs minibuffer." 134 | (let ((fun (gensym)) 135 | (result (gensym)) 136 | (namesym (gensym)) 137 | (catsym (gensym)) 138 | (bodysym (gensym))) 139 | `(let* ((,namesym ,name) 140 | (,catsym ,category) 141 | (,bodysym ',body) 142 | (,fun (lambda () ,@body)) 143 | (,result (unless *definitions-only* 144 | (multiple-value-list (funcall ,fun))))) 145 | (ensure-test ,namesym ,catsym ,bodysym ,fun) 146 | (unless *definitions-only* 147 | (let ((result-list (verify-result (or ,namesym ,bodysym) ,result))) 148 | ,(when output-p 149 | `(loop for result in result-list do 150 | (pprint result))) 151 | (values-list result-list)))))) 152 | 153 | (defun run (&rest names) 154 | "=> test-results 155 | 156 | Run tests named `NAMES`, collecting their results." 157 | (let ((lambdas (package-tests-lambdas (current-tests)))) 158 | (loop for name in names 159 | as fn = (gethash name lambdas) 160 | collect (verify-result name (multiple-value-list (funcall fn))) 161 | into results 162 | finally (return (values-list results))))) 163 | 164 | (defun run-all (&optional (category :default) &rest categories) 165 | "=> test-results 166 | 167 | Run all tests, optionally specifying categories." 168 | (push category categories) 169 | (let ((current-categories (package-tests-categories (current-tests)))) 170 | (loop for cat in categories 171 | appending (gethash cat current-categories) into names 172 | finally (return (apply #'run names))))) 173 | 174 | (defun checkl-store (&optional filespec) 175 | "Store package test results to `FILESPEC`" 176 | (let ((filespec (or filespec (package-tests-default-checkl-store (current-tests)))) 177 | (results (package-tests-results (current-tests)))) 178 | (unless (> (hash-table-count results) 0) 179 | (warn "Not writing blank test results to ~A! CHECKL-LOAD, or write some tests." filespec)) 180 | (with-open-file (stream filespec :direction :output :if-exists :supersede) 181 | (let ((*print-readably* t) 182 | (*print-circle* t)) 183 | (write (ms:marshal results) :stream stream))) 184 | (values))) 185 | 186 | (defun checkl-load (&optional filespec) 187 | "Load package test results from `FILESPEC`" 188 | (let* ((tests (current-tests)) 189 | (filespec (or filespec (package-tests-default-checkl-store tests)))) 190 | (with-open-file (stream filespec) 191 | (setf (package-tests-results tests) (ms:unmarshal (read stream)))))) 192 | 193 | (defmacro do-categories ((var tests) &body body) 194 | `(map 'nil 195 | (lambda (,var) ,@body) 196 | (loop for k being the hash-keys of (package-tests-categories ,tests) 197 | collect k))) 198 | 199 | (defun clear (&rest names) 200 | "Clear the test results from the tests `NAMES`. For clearing anonymous 201 | test results, see `CLEAR-ANONYMOUS`." 202 | (let ((tests (current-tests))) 203 | (loop for name in names do 204 | (remhash name (package-tests-results tests)) 205 | (remhash name (package-tests-lambdas tests)) 206 | (do-categories (c tests) 207 | (setf (gethash c (package-tests-categories tests)) 208 | (delete name (gethash c (package-tests-categories tests)))))))) 209 | 210 | (defun clear-anonymous () 211 | "Clear anonymous test results. For clearing named tests, see `CLEAR`." 212 | (let ((tests (current-tests))) 213 | (loop for name being the hash-keys of (package-tests-results tests) do 214 | (when (not (symbolp name)) 215 | (remhash name (package-tests-results tests)) 216 | (remhash name (package-tests-lambdas tests)) 217 | (do-categories (c tests) 218 | (setf (gethash c (package-tests-categories tests)) 219 | (delete name (gethash c (package-tests-categories tests))))))))) 220 | 221 | (defmacro check-output (&body body) 222 | "Use this within a `CHECK` block. Rebind `*standard-output*` and 223 | `*error-output*` and return a `CHECK`-able result." 224 | (let ((so (gensym)) (se (gensym))) 225 | `(let* ((,so (make-string-output-stream)) 226 | (,se (make-string-output-stream)) 227 | (*standard-output* ,so) 228 | (*error-output* ,se)) 229 | ,@body 230 | (list (get-output-stream-string ,so) 231 | (get-output-stream-string ,se))))) 232 | 233 | (defmacro results (&rest values) 234 | "=> VALUES 235 | 236 | This will evaluate each subform in order and call RESULT-TRANSLATE on 237 | the result. This is especially useful if subforms repeatedly modify 238 | and return the object, e.g. `(results (incf *x*) (incf *x*))`. 239 | 240 | If multiple values are returned, each value is mapped via 241 | RESULT-TRANSLATE and the result is returned as a list of the 242 | translated values." 243 | `(values 244 | ,@(mapcar (lambda (x) 245 | (let ((vlist (gensym))) 246 | `(let ((,vlist (multiple-value-list ,x))) 247 | (if (cdr ,vlist) 248 | (mapcar #'checkl:result-translate ,vlist) 249 | (checkl:result-translate (car ,vlist)))))) 250 | values))) 251 | 252 | (eval-when (:compile-toplevel :load-toplevel :execute) 253 | (defclass test-values (asdf:static-file) 254 | ((package :accessor test-values-package :initarg :package)) 255 | (:documentation "An ASDF component for loading CheckL test values.")) 256 | 257 | (defclass tests (asdf:cl-source-file) () 258 | (:documentation "Load a file with CHECK or CHECK-FORMAL tests.")) 259 | 260 | (defmethod asdf:perform ((op asdf:load-op) (c tests)) 261 | (let ((*definitions-only* t)) 262 | (call-next-method))) 263 | 264 | (defmethod asdf:perform ((op asdf:load-op) (c test-values)) 265 | (let ((*package* (find-package (test-values-package c)))) 266 | (let ((pathname (asdf:component-pathname c)) 267 | (tests (current-tests))) 268 | (setf (package-tests-default-checkl-store tests) pathname) 269 | (if (probe-file pathname) 270 | (checkl-load pathname) 271 | (warn "CheckL test values not loaded: ~A" pathname)))))) 272 | -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | *.html -------------------------------------------------------------------------------- /doc/generate.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :checkl.docs 2 | (:use #:cl #:gendoc) 3 | (:export #:generate)) 4 | 5 | (in-package :checkl.docs) 6 | 7 | (defun generate () 8 | (gendoc (:output-system :checkl-docs 9 | :output-filename "index.html" 10 | :css "simple.css") 11 | (:mdf "intro.md") 12 | (:apiref :checkl))) 13 | -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | # CheckL 2 | 3 | Why write programs in Common Lisp but tests like Java? 4 | 5 | My workflow for writing Common Lisp tends to be like this: 6 | 7 | * Write a bit of lisp, perhaps a function, class, or structure 8 | * Write a snippet in a scratch buffer to test 9 | * Fix if necessary and repeat 10 | 11 | Testing is already inherent in this process, all we need is a little 12 | bit of Common Lisp magic to take advantage of it. Thus, CheckL: 13 | 14 | ```lisp 15 | (defun foo () 16 | (+ 1 1)) 17 | 18 | (check () (foo)) ;; => 2 19 | 20 | (defun foo () 21 | (+ 1 2)) 22 | 23 | (check () (foo)) 24 | 25 | ; | 26 | ; v 27 | ; 28 | ; Result 0 has changed: 3 29 | ; Previous result: 2 30 | ; [Condition of type CHECKL::RESULT-ERROR] 31 | ; 32 | ; Restarts: 33 | ; 0: [USE-NEW-VALUE] The new value is correct, use it from now on. 34 | ; 1: [SKIP-TEST] Skip this, leaving the old value, but continue testing 35 | ; 2: [RETRY] Retry SLIME interactive evaluation request. 36 | ; 3: [*ABORT] Return to SLIME's top level. 37 | ; 4: [TERMINATE-THREAD] Terminate this thread (#) 38 | ``` 39 | 40 | # Usage 41 | 42 | ## Tests 43 | 44 | Presumably you already write code to test. Possibly you even write 45 | something like this, evaluating it and manually checking the result: 46 | 47 | ```lisp 48 | (progn 49 | (function-1 ...) 50 | (function-2 ...)) 51 | ``` 52 | 53 | With CheckL, you don't really have to change much. Your `PROGN` 54 | becomes a `CHECK ()` and you run it. CheckL notifies you if something 55 | changes! 56 | 57 | Results are compared with `CHECKL:RESULT-EQUALP`. This defaults to 58 | `CL:EQUALP`. Defining it for other things may be useful. 59 | 60 | For very long values, it may be helpful to print them: 61 | 62 | ```lisp 63 | (check (:output-p t) (some-very-long-result)) => ... 64 | ``` 65 | 66 | If you make changes to the test, it becomes another test: 67 | 68 | ```lisp 69 | (defun foo () (+ 1 1)) 70 | (check () (foo)) ;; => 2 71 | (check () (1- (foo))) ;; => 1 72 | ``` 73 | 74 | However, if you name it before you change it, it'll always compare 75 | against the same list: 76 | 77 | ```lisp 78 | (check () (foo)) ;; => 2 79 | 80 | (defun foo () (+ 1 3)) 81 | 82 | (check (:name :two) (foo)) ;; => Error! 83 | ``` 84 | 85 | In this case, the old "anonymous" test (actually identified by the 86 | body of the test) is now named `:two`. Making changes to the test 87 | will alter the same test, now named `:two`, and compare against prior 88 | results. 89 | 90 | Finally, you might want to check more than one thing in a single 91 | `CHECK`. You can do this with `RESULTS` (which is similar but not 92 | identical to `VALUES`; see below): 93 | 94 | ```lisp 95 | (defun foo () (+ 1 1) 96 | (defun bar () (- 1 1)) 97 | 98 | (check (:name :two) 99 | (results (foo) (bar))) ;; => 2, 0 100 | 101 | (defun bar () (foo)) 102 | 103 | (check (:name :two) 104 | (results (foo) (bar))) ;; => Error! 105 | ``` 106 | 107 | Or, if you want to run one or more tests: 108 | 109 | ```lisp 110 | (run :two ...) 111 | ``` 112 | 113 | ## Results 114 | 115 | `RESULTS` is much like `VALUES`; in fact, you can use `VALUES` instead 116 | of `RESULTS`. However, `RESULTS` calls `RESULT-TRANSLATE` on each 117 | form as it occurs. By default, this copies structures and sequences, 118 | and marshals/unmarshals standard-objects. 119 | 120 | With `VALUES`, the following will likely not be what you want: 121 | 122 | ```lisp 123 | (defstruct thing (x 0)) 124 | 125 | (defun incr-thing (thing) 126 | (incf (thing-x thing)) 127 | thing) 128 | 129 | (check (:name :incr-thing) 130 | (let ((thing (make-thing))) 131 | (values 132 | thing 133 | (incr-thing thing) 134 | (incr-thing thing)))) 135 | 136 | ;; => #S(.. 2), #S(.. 2), #S(.. 2) 137 | ``` 138 | 139 | However, with `RESULTS`, we get a copy each time: 140 | 141 | ```lisp 142 | (check (:name :incr-thing) 143 | (let ((thing (make-thing))) 144 | (results 145 | thing 146 | (incr-thing thing) 147 | (incr-thing thing)))) 148 | 149 | ;; => #S(.. 0), #S(.. 1), #S(.. 2) 150 | ``` 151 | 152 | Additionally, it can be very useful to override `RESULT-TRANSLATE`, 153 | especially for complex objects: 154 | 155 | ```lisp 156 | (defmethod checkl:result-translate ((thing thing)) 157 | (thing-x thing)) 158 | 159 | (run :incr-thing) ;; => 0, 1, 2 160 | ``` 161 | 162 | This can be useful for checking selected values of deeply-nested 163 | structures and objects. 164 | 165 | ## standard-object 166 | 167 | Another option for standard-object instances is to implement 168 | `ms:class-persistant-slots` (sic). `RESULT-TRANSLATE` calls 169 | `marshal`/`unmarshal` on objects by default, which makes a copy, 170 | if this method is defined. 171 | 172 | This method must merely return a list of slot names, and is trivial to 173 | implement. [See the documentation for 174 | `cl-marshal`](https://github.com/wlbr/cl-marshal) for more details. 175 | 176 | ## Categories 177 | 178 | So you've been writing a bunch of little tests and want to run them 179 | all and see if anything has changed: 180 | 181 | ```lisp 182 | (run-all) 183 | ``` 184 | 185 | Easy! And you haven't had to specifically declare it so in three 186 | places. However maybe you want a bit more structure and split up your 187 | tests when you run them all. Thus categories: 188 | 189 | ```lisp 190 | (check (:name :foo :category :some-category) ...) 191 | 192 | (run-all :some-category ...) 193 | ``` 194 | 195 | The default category is perhaps unsurprisingly called `:default`. 196 | That's pretty much all there is to categories. 197 | 198 | ## Remembering results 199 | 200 | Since we're not *manually* defining the result, it would be 201 | unfortunate if we *happened* to quit our lisp while our code still had 202 | a bug, and then weren't sure what it was. Easy enough: 203 | 204 | ```lisp 205 | (checkl-store "some-file") 206 | ;;; - later - 207 | (checkl-load "some-file") 208 | ``` 209 | 210 | This uses `cl-marshal` and `WRITE` to write values to the file 211 | (overwriting it entirely). `*PRINT-READABLY*` is forced to `t`, but 212 | you can otherwise customize the output as per `WRITE`. 213 | 214 | Along with revision control, it should be easy to keep track of test 215 | results and make modifications. 216 | 217 | ## Formalizing 218 | 219 | This is not meant to be a complete replacement for test suites such as 220 | FiveAM, but more of a "deformalization". 221 | 222 | But once you've worked on a bit of code and have your buffer cluttered 223 | with `(check (...) ...)` forms, you probably don't want to rewrite 224 | them all as FiveAM constructs. It'd be nice if you could just sortof 225 | integrate them all with minimal effort, like this: 226 | 227 | ```lisp 228 | ;; 5am doesn't have a find-suite, so you have to do this: 229 | (defsuite :default) 230 | 231 | (check-formal (:name :two) (foo)) 232 | ``` 233 | 234 | Well, assuming you had FiveAM loaded before you loaded CheckL, this is 235 | exactly what you do. (I didn't want FiveAM to be a strict 236 | dependency.) Now you can do one of these, and they still do what they 237 | should: 238 | 239 | ```lisp 240 | (5am:run! :default) ;; => Pretty dots, one per VALUE 241 | (run-all :default) ;; => 2 242 | ``` 243 | 244 | We've gone from *very* informal testing to having things in FiveAM 245 | with minimal effort! 246 | 247 | Note that you can *still* eval the `CHECK-FORMAL` block in your buffer 248 | and it behaves just like a `CHECK` block, returning its values and 249 | signaling a condition if they change. 250 | 251 | ## ASDF 252 | 253 | Wouldn't it be nice if ASDF loaded your saved CheckL values, and let 254 | you call your newly-created FiveAM tests with minimal effort? Of 255 | course! 256 | 257 | ```lisp 258 | (cl:eval-when (:load-toplevel :execute) 259 | (asdf:load-system :fiveam) 260 | (asdf:load-system :checkl)) 261 | 262 | (defsystem :my-system 263 | :description "A brand new system" 264 | ...) 265 | 266 | (defsystem :my-system-tests 267 | :description "A system that tests" 268 | 269 | :depends-on (:fiveam :checkl) 270 | :serial t 271 | :pathname "t" 272 | 273 | :components ((:file "package") 274 | (checkl:tests "some-test") 275 | (checkl:test-values "test-values" 276 | :package :my-system-tests))) 277 | 278 | (checkl:define-test-op :my-system :my-system-test) 279 | (checkl:define-test-op :my-system-test) 280 | ``` 281 | 282 | That's all! No long `PERFORM` definitions. Just make sure to have 283 | the `EVAL-WHEN` at the top. Now you can do this: 284 | 285 | ```lisp 286 | (asdf:load-system :my-system) 287 | (asdf:test-system :my-system) ;; => (5am:run! :default) 288 | ``` 289 | 290 | Things of note: 291 | 292 | * New ASDF component: `CHECK:TESTS` loads a file with `CHECK-FORMAL` 293 | tests, but does *not* run them. 294 | 295 | * New ASDF component: `CHECK:TEST-VALUES` loads a file with test 296 | values. It also sets the path to be the *default* for test values, 297 | so you can simply do `(checkl-store)` or `(checkl-load)`. 298 | 299 | * `define-test-op SYSTEM &optional OTHER-SYSTEM`: This sets up the 300 | `ASDF:PERFORM` method for system to either run tests, or load 301 | another system and call `TEST-OP` on *it*. If you're doing the 302 | latter, you need both definitions. 303 | 304 | # Etc 305 | 306 | I've been using this a bit and have added some conveniences. There 307 | could certainly be more. Suggestions welcome, theoretical or 308 | otherwise. 309 | -------------------------------------------------------------------------------- /doc/simple.css: -------------------------------------------------------------------------------- 1 | .apiref-row { 2 | padding-bottom: 1em; 3 | display: block; 4 | float: none; 5 | } 6 | 7 | .apiref-spec { 8 | display: inline; 9 | font-family: monospace; 10 | font-weight: bold; 11 | } 12 | 13 | .apiref-lambda { 14 | display: inline; 15 | font-family: monospace; 16 | font-weight: bold; 17 | font-style: italic; 18 | } 19 | 20 | .apiref-result { 21 | display: block; 22 | font-family: monospace; 23 | font-style: italic; 24 | margin-left: 20px; 25 | } 26 | 27 | .apiref-doc { 28 | display: block; 29 | float: none; 30 | margin-left: 30px; 31 | } 32 | 33 | .codeblock { 34 | display: block; 35 | background: lightgrey; 36 | border: 1px solid black; 37 | padding: 10px; 38 | margin: 20px 5px 20px 5px; 39 | } 40 | 41 | /* From coloring-css.lisp in colorize */ 42 | .symbol { color : #770055; background-color : transparent; border: 0px; margin: 0px;} 43 | a.symbol:link { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 44 | a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 45 | a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 46 | a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } 47 | .special { color : #FF5000; background-color : inherit; } 48 | .keyword { color : #770000; background-color : inherit; } 49 | .comment { color : #007777; background-color : inherit; } 50 | .string { color : #777777; background-color : inherit; } 51 | .character { color : #0055AA; background-color : inherit; } 52 | .syntaxerror { color : #FF0000; background-color : inherit; } 53 | span.paren1:hover { color : inherit; background-color : #BAFFFF; } 54 | span.paren2:hover { color : inherit; background-color : #FFCACA; } 55 | span.paren3:hover { color : inherit; background-color : #FFFFBA; } 56 | span.paren4:hover { color : inherit; background-color : #CACAFF; } 57 | span.paren5:hover { color : inherit; background-color : #CAFFCA; } 58 | span.paren6:hover { color : inherit; background-color : #FFBAFF; } 59 | -------------------------------------------------------------------------------- /formalize.lisp: -------------------------------------------------------------------------------- 1 | (in-package :checkl) 2 | 3 | (defmacro check-formal ((&key name (category :default) depends-on) 4 | &body body) 5 | (unless (and name (symbolp name)) 6 | (error "NAME must be a non-NIL symbol for formal tests.")) 7 | (let ((fun (gensym)) 8 | (catsym (gensym)) 9 | (bodysym (gensym))) 10 | `(let* ((,catsym ,category) 11 | (,bodysym ',body) 12 | (,fun (lambda () ,@body))) 13 | (ensure-test ,name ,catsym ,bodysym ,fun) 14 | (5am:test (,name ,@(if depends-on `(:depends-on ,depends-on)) 15 | :suite ,category) 16 | (let* ((result (multiple-value-list (progn ,@body))) 17 | (tests (current-tests)) 18 | (last-result (gethash ,name (package-tests-results tests)))) 19 | (loop for val in result 20 | as prev in last-result 21 | do (5am:is (result-equalp last-result result))))) 22 | (unless *definitions-only* 23 | (values-list (run ,name)))))) 24 | 25 | (eval-when (:compile-toplevel :load-toplevel :execute) 26 | (defmacro define-test-op (system-name &optional other-system-name) 27 | (if other-system-name 28 | `(defmethod asdf:perform ((o asdf:test-op) (c (eql (asdf:find-system ',system-name)))) 29 | (asdf:operate 'asdf:load-op ',other-system-name) 30 | (asdf:operate 'asdf:test-op ',other-system-name)) 31 | `(defmethod asdf:perform ((o asdf:test-op) (c (eql (asdf:find-system ',system-name)))) 32 | (let ((5am:*test-dribble* *error-output*)) 33 | (5am:run! :default)))))) 34 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :checkl 2 | (:use :cl) 3 | (:export check run run-all checkl-store checkl-load 4 | check-formal test-values tests define-test-op 5 | result-equalp result-translate results 6 | clear clear-anonymous check-output)) 7 | -------------------------------------------------------------------------------- /t/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :checkl-tests 2 | (:use :cl :checkl)) 3 | 4 | -------------------------------------------------------------------------------- /t/test-values: -------------------------------------------------------------------------------- 1 | (:pcode 1 (:hash-table 1 16 1.5 1.0 equalp nil (:two (:list 2 2 2)))) -------------------------------------------------------------------------------- /t/test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :checkl-tests) 2 | 3 | (5am:def-suite :default) 4 | 5 | (defvar *x* 1) 6 | 7 | (checkl:check-formal (:name :two) 8 | (values 9 | (+ 1 1) 10 | (+ *x* 1))) 11 | --------------------------------------------------------------------------------