diff options
| author | 2025-11-01 22:29:42 -0400 | |
|---|---|---|
| committer | 2025-11-01 22:29:42 -0400 | |
| commit | 44e4fd1e1f914e5b307435769c8909da8a72aafb (patch) | |
| tree | 0c5e707c836f646229462adb08314ac8988e2d14 | |
| parent | add expect-to-fail (diff) | |
Big rewrite:
1. Rename to "cuprate".
2. Remove mutexes.
3. Move rewriters to other library.
4. Move the DTO out of the `test-info` parameter. They are now separate
parameters, with the expectation that the DTO will not change over
time. This significantly reduces the complexity of the code.
5. Use SRFI-146 for Chicken.
| -rw-r--r-- | README.md | 58 | ||||
| -rw-r--r-- | conspire.egg | 12 | ||||
| -rw-r--r-- | cuprate.egg | 15 | ||||
| -rw-r--r-- | lib/conspire.sld | 84 | ||||
| -rw-r--r-- | lib/cuprate.scm (renamed from lib/conspire.scm) | 276 | ||||
| -rw-r--r-- | lib/cuprate.sld | 59 | ||||
| -rw-r--r-- | lib/cuprate/rewriters.chicken.sld | 35 | ||||
| -rw-r--r-- | lib/cuprate/rewriters.foment.sld | 32 | ||||
| -rw-r--r-- | lib/cuprate/rewriters.r7rs.sld | 24 | ||||
| -rw-r--r-- | lib/rewriters.chicken.scm | 48 | ||||
| -rw-r--r-- | lib/rewriters.foment.scm | 45 | ||||
| -rw-r--r-- | lib/rewriters.r7rs.scm | 37 | ||||
| -rw-r--r-- | lib/threads.r7rs-srfi-18.scm | 31 | ||||
| -rw-r--r-- | lib/threads.single-threaded-r7rs.scm | 32 | ||||
| -rw-r--r-- | tests/impl.scm | 476 | ||||
| -rw-r--r-- | tests/run.scm | 28 |
16 files changed, 515 insertions, 777 deletions
@@ -1,8 +1,8 @@ -# Conspire +# Cuprate TODO: pretty printing -Conspire is an experiment in providing a portable R6RS/R7RS testing +Cuprate is an experiment in providing a portable R6RS/R7RS testing library. It uses purely functional data structures in a mutable parameter object, allowing for procedural programming inside of a dynamic extent to not affect the rest of the test system. @@ -11,22 +11,26 @@ to not affect the rest of the test system. ### `test-info` procedures - `test-info` + test-info + test-info? + test-dto -What SRFI-64 would call the "test runner" is in Conspire the `test-info`, -which contains a pure SRFI-225 dictionary with an associated DTO. The +What SRFI-64 would call the "test runner" is in Cuprate the `test-info`, +which contains test-info record containing a pure SRFI-225 dictionary. The dictionary must map at least symbols to values (including procedures). Whenever a test group or a test is entered, a new dynamic extent is entered with a new test-info object. Destructive updates to the new test info are not reflected in the test info of the call. -The `test-info` is a parameter and can be modified with the `parameterize` -form. The inputs to `test-info` must be one of: +When `test-info` is parameterized with a value satisfying `test-info?`, +then that test-info is used in the dynamic extent of the invocation of +`parameterize`. Otherwise, a new record is allocated, and the value passed +to `parameterize` is inserted into that record. This new record does not +share state with any other test-info. -* `copy`: Return an unchanged copy of the `test-info` -* `replace dict [dto]`: In the new dynamic extent, the dictionary is - replaced with `dict`, optionally with new dto `dto`. +The dictionary inside the `test-info` parameter must be a dictionary +according to the DTO in `test-dto`. The value in `test-dto` must be a DTO. test-set! test-update! @@ -47,15 +51,14 @@ is equivalent to `(dict-set! dto dict key value)`. (modify-test-info! proc) -Evaluates `(proc dto dict)`, where `dto` is the current `test-info` DTO -and `dict` is the current `test-info` dict. The procedure must return -a dict satisfying the same DTO. This dictionary is set as the current -`test-info` dictionary within the dynamic extent. +Evaluates `(proc dict)`, where `dict` is the current `test-info` dict. The +procedure must return a dict satisfying the same DTO. This dictionary +is set as the current `test-info` dictionary within the dynamic extent. (inspect-test-info proc) -Evaluates `(proc dto dict)`, where `dto` is the current `test-info` DTO -and `dict` is the current `test-info` dict, and returns the result. +Evaluates `(proc dict)`, where `dict` is the current `test-info` dict, +and returns the result. ### `test-info` Standard Procedure Keys @@ -70,15 +73,15 @@ false, then the test is skipped. A procedure of zero arguments. Called in the dynamic extent of a test. Used to set up parts of a test. - after-test (default-after-test dto dict) + after-test (default-after-test dict) -A procedure of two arguments (the DTO and dictionary of the test). Called +A procedure of one argument (the dictionary of the test). Called in the dynamic extent of the caller. Used to report information about the test, and to merge desired information into the calling test info. - report-test (default-report-test dto dict) + report-test (default-report-test dict) -A procedure of two arguments (the DTO and dictionary of the test). Used by +A procedure of one argument (the dictionary of the test). Used by `default-after-test` to report the result of the test to the user. group-begin (default-group-begin name) @@ -86,11 +89,11 @@ A procedure of two arguments (the DTO and dictionary of the test). Used by A procedure of one argument (the name of the group). Called in the dynamic extent of the group. Used to set up common information for a whole group. - group-end (default-group-end dto dict) + group-end (default-group-end dict) -A procedure of two arguments (the DTO and the dictionary of the -test). Called in the dynamic extent containing the group. Used to report -information about the group and merge it with the containing test info. +A procedure of one (the dictionary of the test). Called in the dynamic +extent containing the group. Used to report information about the group +and merge it with the containing test info. ### `test-info` Standard Keys @@ -181,16 +184,11 @@ This library requires `make-parameter` and `parameterize` to work like in R7RS. Most R6RS implementations should support dynamic parameters out of the box. -Multi-threaded implementations must export an SRFI-18 compatible -interface for mutexes. Single threaded implementations can use the -`compat.single-threaded.sld` (`compat.single-threaded.sls` for R6RS) -implementations. - ## Instructions Per Implementation ### CHICKEN -Just run `chicken-install conspire`. +Just run `chicken-install cuprate`. ### Foment diff --git a/conspire.egg b/conspire.egg deleted file mode 100644 index 53792af..0000000 --- a/conspire.egg +++ /dev/null @@ -1,12 +0,0 @@ -((author "Peter McGoron") - (version "0.1.0") - (synopsis "A modern testing suite") - (category "test") - (license "MIT") - (dependencies "r7rs" "srfi-18" "srfi-225") - (components (extension conspire - (source "lib/conspire.sld") - (source-dependencies "lib/conspire.scm" - "lib/r7rs-srfi-18.scm" - "lib/rewriters.chicken.scm") - (csc-options "-R" "r7rs" "-X" "r7rs")))) diff --git a/cuprate.egg b/cuprate.egg new file mode 100644 index 0000000..90c7d09 --- /dev/null +++ b/cuprate.egg @@ -0,0 +1,15 @@ +((author "Peter McGoron") + (version "0.2.0") + (synopsis "A portable testing suite") + (category "test") + (license "BSD 0-clause") + (dependencies "r7rs" "srfi-128" "srfi-146" "srfi-225") + (components (extension cuprate + (source "lib/cuprate.sld") + (source-dependencies "lib/cuprate.scm") + (component-dependencies cuprate.rewriters) + (csc-options "-R" "r7rs" "-X" "r7rs")) + (extension cuprate.rewriters + (source "lib/cuprate/rewriters.chicken.sld") + (csc-options "-R" "r7rs" "-X" "r7rs")) + ))) diff --git a/lib/conspire.sld b/lib/conspire.sld deleted file mode 100644 index 0b50d94..0000000 --- a/lib/conspire.sld +++ /dev/null @@ -1,84 +0,0 @@ -#| Copyright © 2025 Peter McGoron - | - | Permission is hereby granted, free of charge, to any person obtaining - | a copy of this software and associated documentation files (the - | “Software”), to deal in the Software without restriction, including - | without limitation the rights to use, copy, modify, merge, publish, - | distribute, sublicense, and/or sell copies of the Software, and to - | permit persons to whom the Software is furnished to do so, subject to - | the following conditions: - | - | The above copyright notice and this permission notice shall be included - | in all copies or substantial portions of the Software. - | - | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, - | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN - | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, - | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR - | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR - | THE USE OR OTHER DEALINGS IN THE SOFTWARE. - |# - -(define-library (conspire) - (import (scheme base) (scheme write) (scheme process-context) (srfi 225)) - (export conspire-error? conspire-error-message conspire-error-irritants - ;; test info - test-info test-info? modify-test-info! inspect-test-info - ;; test accessors and setters - test-set! test-update! test-update/default! test-delete! - test-contains? test-ref test-ref/default test-set - test-update/default - call-as-test call-as-group - ;; Default test procedures - setup-name! display-report - default-skip-test? default-before-test! default-setup-test! - default-when-test-skipped default-after-test default-report-test - default-on-exception - default-setup-group! default-before-group! - default-after-group default-report-group - default-test-info-dict default-test-info-dto - ;; SRFI-64 style assertions - test-application test-assert - test-equal test-eqv test-eq test-approximate - call-as-test-error test-error expect-to-fail - test-skip-all - test-group - with-test-group-cleanup - test-exit) - (begin - (define-record-type <conspire-error> - (make-conspire-error message irritants) - conspire-error? - (message conspire-error-message) - (irritants conspire-error-irritants)) - (define (raise-conspire-error message . irritants) - (raise (make-conspire-error message irritants)))) - ;; Library information for test-info object - (cond-expand - (chicken (import (srfi 18) (only (chicken pretty-print) - pretty-print)) - (include "threads.r7rs-srfi-18.scm") - (include-library-declarations "rewriters.chicken.scm")) - (foment (import (srfi 18) (srfi 166)) - (include "threads.r7rs-srfi-18.scm") - (include-library-declarations "rewriters.foment.scm") - (begin (define (pretty-print obj) - (show #t (pretty obj)) - (newline)))) - (chibi (import (srfi 18) (srfi 166)) - (include "threads.r7rs-srfi-18.scm") - (include-library-declarations "rewriters.r7rs.scm") - (begin (define (pretty-print obj) - (show #t (pretty obj))))) - (gauche (import (gauche threads) (scheme show)) - (include "threads.r7rs-srfi-18.scm") - (include-library-declarations "rewriters.r7rs.scm") - (begin (define (pretty-print obj) - (show #t (pretty obj))))) - (else (include "threads.r7rs-single-threaded.scm") - (include-library-declarations "rewriters.r7rs.scm") - (begin (define (pretty-print x) - (write x) - (newline))))) - (include "conspire.scm"))
\ No newline at end of file diff --git a/lib/conspire.scm b/lib/cuprate.scm index 130218f..deb84e1 100644 --- a/lib/conspire.scm +++ b/lib/cuprate.scm @@ -1,68 +1,37 @@ -#| Copyright © 2025 Peter McGoron - | - | Permission is hereby granted, free of charge, to any person obtaining - | a copy of this software and associated documentation files (the - | “Software”), to deal in the Software without restriction, including - | without limitation the rights to use, copy, modify, merge, publish, - | distribute, sublicense, and/or sell copies of the Software, and to - | permit persons to whom the Software is furnished to do so, subject to - | the following conditions: - | - | The above copyright notice and this permission notice shall be included - | in all copies or substantial portions of the Software. - | - | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, - | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN - | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, - | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR - | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR - | THE USE OR OTHER DEALINGS IN THE SOFTWARE. - |# - ;;; ;;;;;;;;;;;;;;;;;;; ;;; Manipulating the test info ;;; ;;;;;;;;;;;;;;;;;;; (define (modify-test-info! proc) - (let ((mutex (test-info-mutex (test-info)))) - (dynamic-wind - (lambda () (mutex-lock! mutex)) - (lambda () - (set-test-info-dict! (test-info) - (proc (test-info-dto (test-info)) - (test-info-dict (test-info))))) - (lambda () (mutex-unlock! mutex))))) + (set-test-info! (test-info) (inspect-test-info proc))) (define (inspect-test-info proc) - (let ((mutex (test-info-mutex (test-info)))) - (mutex-lock! mutex) - (let-values (((dto dict) (values (test-info-dto (test-info)) - (test-info-dict (test-info))))) - (mutex-unlock! mutex) - (proc dto dict)))) + (proc (test-info-dict))) (define-syntax define-destructive-test-info-procedure (syntax-rules () ((_ (name args ...) proc) (define (name args ...) - (modify-test-info! (lambda (dto dictionary) - (proc dto dictionary args ...))))) + (modify-test-info! (lambda (dictionary) + (proc (test-dto) dictionary args ...))))) ((_ (name . args) proc) (define (name . other-args) - (modify-test-info! (lambda (dto dictionary) - (apply proc dto dictionary other-args))))))) + (modify-test-info! (lambda (dictionary) + (apply proc (test-dto) + dictionary other-args))))))) (define-syntax define-inspecting-test-info-procedure (syntax-rules () ((_ (name args ...) proc) (define (name args ...) - (inspect-test-info (lambda (dto dictionary) - (proc dto dictionary args ...))))) + (inspect-test-info (lambda (dictionary) + (proc (test-dto) + dictionary args ...))))) ((_ (name . args) proc) (define (name . other-args) - (inspect-test-info (lambda (dto dictionary) - (apply proc dto dictionary other-args))))))) + (inspect-test-info (lambda (dictionary) + (apply proc (test-dto) + dictionary other-args))))))) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Mutating operations on the test info @@ -93,35 +62,32 @@ ;;; ;;;;;;;;;;;;;;;;;;;;;;;; (define (call-as-test name thunk) + (define (exec) + ((test-ref 'before-test!) name) + (parameterize ((test-info (test-info-dict))) + ((test-ref 'setup-test!) name) + (call/cc + (lambda (%return) + (define (return) (%return #f)) + (with-exception-handler (lambda (ex) + ((test-ref 'on-exception) ex return) + (raise ex)) + thunk))) + #;((test-ref 'cleanup-test!) name) + (test-info-dict))) (if ((test-ref 'skip-test?) name) ((test-ref 'when-test-skipped) name) - (let ((thunk - (lambda () - (call/cc - (lambda (return) - (define handle - (let ((on-exception (test-ref 'on-exception)) - (return (lambda () (return #f)))) - (lambda (exn) (on-exception exn return)))) - ((test-ref 'setup-test!) name) - (with-exception-handler handle thunk))) - (inspect-test-info values)))) - ((test-ref 'before-test!) name) - (call-with-values (lambda () - (parameterize ((test-info '(box))) - (thunk))) - (test-ref 'after-test))))) + ((test-ref 'after-test) (exec)))) (define (call-as-group name thunk) - (let ((inside (lambda () - ((test-ref 'setup-group!) name) - (thunk) - (inspect-test-info values)))) + ;; TODO: Skipping groups. + (define (exec) ((test-ref 'before-group!) name) - (call-with-values (lambda () - (parameterize ((test-info '(box))) - (inside))) - (test-ref 'after-group)))) + (parameterize ((test-info (test-info-dict))) + ((test-ref 'setup-group!) name) + (thunk) + (test-info-dict))) + ((test-ref 'after-group) (exec))) (define (setup-name! name) (test-set! 'name name) @@ -153,46 +119,50 @@ "test") "\n"))) -(define (default-after-test previous-dto previous-test-info) +(define (default-after-test previous-test-info) (test-update/default! 'tests (lambda (x) (+ x 1)) 0) - (let ((success? (dict-ref/default previous-dto + (let ((success? (dict-ref/default (test-dto) previous-test-info 'success? #f))) (test-update/default! (if success? 'passed 'failed) (lambda (x) (+ 1 x)) 0) - ((test-ref 'report-test) previous-dto previous-test-info))) + ((test-ref 'report-test) previous-test-info))) -(define (display-report previous-dto previous-dict) - (let ((never-print-dto (dict-ref previous-dto previous-dict +(define (display-report previous-dict) + (let ((never-print-dto (dict-ref (test-dto) + previous-dict 'never-print-dto)) - (never-print (dict-ref previous-dto previous-dict + (never-print (dict-ref (test-dto) + previous-dict 'never-print))) - (dict-for-each previous-dto + (dict-for-each (test-dto) (lambda (key value) (unless (dict-contains? never-print-dto never-print key) (pretty-print - (list (test-rewrite key) - (test-rewrite value))))) + (list (rewrite key) + (rewrite value))))) previous-dict))) -(define (default-report-test previous-dto previous-test-info) +(define (default-report-test previous-test-info) (let ((verbose? (test-ref/default 'verbose? #f)) - (specifically-verbose? (dict-ref/default previous-dto + (specifically-verbose? (dict-ref/default (test-dto) previous-test-info 'verbose? #f)) - (success? (dict-ref/default previous-dto + (success? (dict-ref/default (test-dto) previous-test-info 'success? #f)) (name (cond - ((dict-ref previous-dto previous-test-info 'name)) + ((dict-ref (test-dto) + previous-test-info + 'name)) (else "")))) (cond (success? @@ -200,8 +170,8 @@ (display (string-append "PASS: \"" name "\"\n")))) (else (display (string-append "FAIL: \"" name "\"\n")) - (display-report previous-dto previous-test-info))) - (values previous-dto previous-test-info))) + (display-report previous-test-info))) + previous-test-info)) (define (default-on-exception exn return) (test-set! 'success? #f) @@ -213,21 +183,18 @@ ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (default-setup-group! name) - (test-set! 'tests 0) - (test-set! 'passed 0) - (test-set! 'failed 0) - (test-set! 'skipped 0) + (test-set! 'tests 0 'passed 0 'failed 0 'skipped 0) (setup-name! name)) (define (default-before-group! name) (when (test-ref/default 'verbose? #f) (display (string-append "ENTER " (if name name "group") "\n")))) -(define (default-after-group previous-dto previous-info) +(define (default-after-group previous-info) (define (update/previous! name) (test-update/default! name - (lambda (x) (+ x (dict-ref/default previous-dto + (lambda (x) (+ x (dict-ref/default (test-dto) previous-info name 0))) @@ -236,88 +203,66 @@ (update/previous! 'passed) (update/previous! 'failed) (update/previous! 'skipped) - ((test-ref 'report-group) previous-dto previous-info)) + ((test-ref 'report-group) previous-info)) -(define (default-report-group previous-dto previous-info) +(define (default-report-group previous-info) (when (or (test-ref/default 'verbose? #f) - (dict-ref/default previous-dto previous-info + (dict-ref/default (test-dto) previous-info 'verbose? #f)) (cond - ((dict-ref previous-dto previous-info 'name) + ((dict-ref (test-dto) previous-info 'name) => (lambda (name) (display (string-append "EXIT \"" name "\"\n")))) (else (display "EXIT group\n")))) - (values previous-dto previous-info)) + previous-info) ;;; ;;;;;;;;;;;;;;;; ;;; test info ;;; ;;;;;;;;;;;;;;;; (define default-test-info-dict - `((before-test! . ,default-before-test!) - (skip-test? . ,default-skip-test?) - (when-test-skipped . ,default-when-test-skipped) - (setup-test! . ,default-setup-test!) - (after-test . ,default-after-test) - (report-test . ,default-report-test) - (on-exception . ,default-on-exception) - (setup-group! . ,default-setup-group!) - (after-group . ,default-after-group) - (before-group! . ,default-before-group!) - (report-group . ,default-report-group) - (passed . 0) - (failed . 0) - (skipped . 0) - (tests . 0) - (name . #f) - (name-stack . ()) - (rewriters . ,default-rewriters) - (never-print-dto . ,equal-alist-dto) - (pretty-print . ,pretty-print) - (never-print . ,(map (lambda (x) (cons x x)) - '(before-test! - skip-test? when-test-skipped setup-test! - after-test report-test on-exception - setup-group! after-group before-group! - report-group never-print name rewriters - never-print-dto pretty-print))))) - -(define default-test-info-dto equal-alist-dto) - -(define test-info - (make-parameter - (list 'replace default-test-info-dto default-test-info-dict) - (lambda (value) - (cond - ;; TODO: Should putting in a new test info be allowed? - ((test-info? value) value) - ((not (pair? value)) - (raise-conspire-error "invalid arguments to parameterize" - value)) - ((eq? (car value) 'box) - (unless (null? (cdr value)) - (raise-conspire-error "invalid arguments to copy" - value)) - (inspect-test-info make-test-info)) - ((eq? (car value) 'replace) - (cond - ((null? (list-tail value 1)) - (raise-conspire-error "not enough arguments to replace" - value)) - ((null? (list-tail value 2)) - (inspect-test-info (lambda (dto _) - (make-test-info dto - (list-ref value 1))))) - ((null? (list-tail value 3)) - (make-test-info (list-ref value 1) (list-ref value 2))) - (else (raise-conspire-error "too many arguments to replace" - value)))) - ((eq? (car value) 'operate) - (call-with-values (lambda () - (inspect-test-info (list-ref value 1))) - make-test-info)) - (else (raise-conspire-error "unknown command" value)))))) + (alist->default-dictionary + `((before-test! . ,default-before-test!) + (skip-test? . ,default-skip-test?) + (when-test-skipped . ,default-when-test-skipped) + (setup-test! . ,default-setup-test!) + (after-test . ,default-after-test) + (report-test . ,default-report-test) + (on-exception . ,default-on-exception) + (setup-group! . ,default-setup-group!) + (after-group . ,default-after-group) + (before-group! . ,default-before-group!) + (report-group . ,default-report-group) + (passed . 0) + (failed . 0) + (skipped . 0) + (tests . 0) + (name . #f) + (name-stack . ()) + (never-print-dto . ,equal-alist-dto) + (pretty-print . ,pretty-print) + (never-print . ,(map (lambda (x) (cons x x)) + '(before-test! + skip-test? when-test-skipped setup-test! + after-test report-test on-exception + setup-group! after-group before-group! + report-group never-print name rewriters + never-print-dto pretty-print)))))) + +(define test-dto (make-parameter default-test-dto + (lambda (x) + (unless (dto? x) + (assertion-violation 'test-dto + "must be a DTO" + x)) + x))) +(define test-info (make-parameter default-test-info-dict + (lambda (x) + (if (test-info? x) + x + (wrap-test-info x))))) +(define (test-info-dict) (unwrap-test-info (test-info))) ;;; ;;;;;;;;;;;; ;;; Wrappers and semi-compatability with SRFI-64 @@ -334,7 +279,7 @@ ...) (test-set! 'success? (name ...)))))))) -(define-syntax test-assert +(define-syntax test-body (syntax-rules () ((_ name body ...) (call-as-test name (lambda () @@ -401,9 +346,8 @@ (let ((outer-after-test (test-ref 'after-test))) (test-group #f (test-set! 'after-test - (lambda (dto dict) - (outer-after-test dto - (dict-update! dto dict + (lambda (dict) + (outer-after-test (dict-update! (test-dto) dict 'success? not)))) (let () body ...)))))) @@ -436,13 +380,3 @@ (exit (if (zero? (test-ref/default 'failed 0)) 0 1))) - -;;; Rewriters - -(define (test-rewrite obj) - (let loop ((rewriters (test-ref/default 'rewriters '()))) - (cond - ((null? rewriters) obj) - (((caar rewriters) obj) ((cdar rewriters) obj)) - (else (loop (cdr rewriters)))))) - diff --git a/lib/cuprate.sld b/lib/cuprate.sld new file mode 100644 index 0000000..a032db5 --- /dev/null +++ b/lib/cuprate.sld @@ -0,0 +1,59 @@ +(define-library (cuprate) + (import (scheme base) (scheme write) (scheme process-context) (srfi 225) + (cuprate rewriters)) + (export ;; test info + test-info test-info? modify-test-info! inspect-test-info + test-info-dict test-dto default-test-info-dict default-test-dto + ;; test accessors and setters + test-set! test-update! test-update/default! test-delete! + test-contains? test-ref test-ref/default test-set + test-update/default + call-as-test call-as-group + ;; Default test procedures + setup-name! display-report + default-skip-test? default-before-test! default-setup-test! + default-when-test-skipped default-after-test default-report-test + default-on-exception + default-setup-group! default-before-group! + default-after-group default-report-group + ;; SRFI-64 style assertions + test-application test-body + test-equal test-eqv test-eq test-approximate + call-as-test-error test-error expect-to-fail + test-skip-all + test-group + with-test-group-cleanup + test-exit) + (begin + (define-record-type <test-info> + (wrap-test-info dict) + test-info? + (dict unwrap-test-info set-test-info!)) + (define assertion-violation error)) + ;; Pretty printing + (cond-expand + (chicken (import (only (chicken pretty-print) pretty-print))) + (foment (import (srfi 166)) + (begin (define (pretty-print obj) + (show #t (pretty obj)) + (newline)))) + (chibi (import (srfi 166)) + (begin (define (pretty-print obj) + (show #t (pretty obj))))) + (gauche (import (scheme show)) + (begin (define (pretty-print obj) + (show #t (pretty obj))))) + (else (begin (define (pretty-print x) + (write x) + (newline))))) + ;; Better containers for the test info than alists, if available. + (cond-expand + (chicken (import (srfi 128) (srfi 146 hash)) + (begin + (define default-test-dto hash-mapping-dto) + (define (alist->default-dictionary x) + (alist->hashmap (make-default-comparator) x)))) + (else (begin + (define default-test-info-dto eqv-alist-dto) + (define (alist->default-dictionary x) x)))) + (include "cuprate.scm"))
\ No newline at end of file diff --git a/lib/cuprate/rewriters.chicken.sld b/lib/cuprate/rewriters.chicken.sld new file mode 100644 index 0000000..82a275c --- /dev/null +++ b/lib/cuprate/rewriters.chicken.sld @@ -0,0 +1,35 @@ +(define-library (cuprate rewriters) + (import (scheme base) (scheme write) + (chicken memory representation) + (chicken condition)) + (export rewriters rewrite) + (begin + (define (default-on-pair pair) + (cons (rewrite (car pair)) + (rewrite (cdr pair)))) + (define (default-on-vector vec) + (vector-map rewrite vec)) + (define (default-on-error error) + (cons 'error + (cons (error-object-message error) + (error-object-irritants error)))) + (define (default-on-condition cond) + (map rewrite (condition->list cond))) + (define (default-on-record rec) + `(record (name ,(rewrite (record-instance-type rec))) + (elements + ,(vector-map rewrite (record->vector rec))))) + (define rewriters + (make-parameter + `((,pair? . ,default-on-pair) + (,vector? . ,default-on-vector) + (,error-object? . ,default-on-error) + (,condition? . ,default-on-condition) + (,record-instance? . ,default-on-record)))) + (define (rewrite obj) + (let loop ((rewriters (rewriters))) + (cond + ((null? rewriters) obj) + (((caar rewriters) obj) ((cdar rewriters) obj)) + (else (loop (cdr rewriters)))))))) + diff --git a/lib/cuprate/rewriters.foment.sld b/lib/cuprate/rewriters.foment.sld new file mode 100644 index 0000000..24c26d8 --- /dev/null +++ b/lib/cuprate/rewriters.foment.sld @@ -0,0 +1,32 @@ +(define-library (cuprate rewriters) + (import (scheme base) + (only (foment base) + error-object-type + error-object-who + error-object-kind)) + (export rewriters rewrite) + (begin + (define (default-on-pair pair) + (cons (test-rewrite (car pair)) + (test-rewrite (cdr pair)))) + (define (default-on-vector vec) + (vector-map test-rewrite vec)) + (define (default-on-error error) + (let ((msg (error-object-message error)) + (irritants (error-object-irritants error))) + `(error (type ,(test-rewrite (error-object-type error))) + (who ,(test-rewrite (error-object-who error))) + (kind ,(test-rewrite (error-object-kind error))) + (msg ,(test-rewrite (error-object-message error))) + (irritants ,@(map test-rewrite (error-object-irritants error)))))) + (define rewriters + (make-parameter `((,pair? . ,default-on-pair) + (,vector? . ,default-on-vector) + (,error-object? . ,default-on-error)))) + (define (rewrite obj) + (let loop ((rewriters (rewriters))) + (cond + ((null? rewriters) obj) + (((caar rewriters) obj) ((cdar rewriters) obj)) + (else (loop (cdr rewriters)))))))) + diff --git a/lib/cuprate/rewriters.r7rs.sld b/lib/cuprate/rewriters.r7rs.sld new file mode 100644 index 0000000..3996db6 --- /dev/null +++ b/lib/cuprate/rewriters.r7rs.sld @@ -0,0 +1,24 @@ +(define-library (cuprate rewriters) + (import (scheme base)) + (export rewriiters rewrite) + (begin + (define (default-on-pair pair) + (cons (test-rewrite (car pair)) + (test-rewrite (cdr pair)))) + (define (default-on-vector vec) + (vector-map test-rewrite vec)) + (define (default-on-error error) + (let ((msg (error-object-message error)) + (irritants (error-object-irritants error))) + (cons 'error (cons msg irritants)))) + (define rewriters + (make-parameter `((,pair? . ,default-on-pair) + (,vector? . ,default-on-vector) + (,error-object? . ,default-on-error)))) + (define (rewrite obj) + (let loop ((rewriters (rewriters))) + (cond + ((null? rewriters) obj) + (((caar rewriters) obj) ((cdar rewriters) obj)) + (else (loop (cdr rewriters)))))))) + diff --git a/lib/rewriters.chicken.scm b/lib/rewriters.chicken.scm deleted file mode 100644 index 6b715f5..0000000 --- a/lib/rewriters.chicken.scm +++ /dev/null @@ -1,48 +0,0 @@ -#| Copyright © 2025 Peter McGoron - | - | Permission is hereby granted, free of charge, to any person obtaining - | a copy of this software and associated documentation files (the - | “Software”), to deal in the Software without restriction, including - | without limitation the rights to use, copy, modify, merge, publish, - | distribute, sublicense, and/or sell copies of the Software, and to - | permit persons to whom the Software is furnished to do so, subject to - | the following conditions: - | - | The above copyright notice and this permission notice shall be included - | in all copies or substantial portions of the Software. - | - | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, - | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN - | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, - | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR - | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR - | THE USE OR OTHER DEALINGS IN THE SOFTWARE. - |# - -(import (chicken memory representation) - (chicken condition)) - -(begin - (define (default-on-pair pair) - (cons (test-rewrite (car pair)) - (test-rewrite (cdr pair)))) - (define (default-on-vector vec) - (vector-map test-rewrite vec)) - (define (default-on-error error) - (cons 'error - (cons (error-object-message error) - (error-object-irritants error)))) - (define (default-on-condition cond) - (map test-rewrite (condition->list cond))) - (define (default-on-record rec) - `(record (name ,(test-rewrite (record-instance-type rec))) - (elements - ,(vector-map test-rewrite (record->vector rec))))) - (define default-rewriters - `((,pair? . ,default-on-pair) - (,vector? . ,default-on-vector) - (,error-object? . ,default-on-error) - (,condition? . ,default-on-condition) - (,record-instance? . ,default-on-record)))) - diff --git a/lib/rewriters.foment.scm b/lib/rewriters.foment.scm deleted file mode 100644 index 4d26429..0000000 --- a/lib/rewriters.foment.scm +++ /dev/null @@ -1,45 +0,0 @@ -#| Copyright © 2025 Peter McGoron - | - | Permission is hereby granted, free of charge, to any person obtaining - | a copy of this software and associated documentation files (the - | “Software”), to deal in the Software without restriction, including - | without limitation the rights to use, copy, modify, merge, publish, - | distribute, sublicense, and/or sell copies of the Software, and to - | permit persons to whom the Software is furnished to do so, subject to - | the following conditions: - | - | The above copyright notice and this permission notice shall be included - | in all copies or substantial portions of the Software. - | - | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, - | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN - | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, - | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR - | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR - | THE USE OR OTHER DEALINGS IN THE SOFTWARE. - |# - -(import (only (foment base) - error-object-type - error-object-who - error-object-kind)) - -(begin - (define (default-on-pair pair) - (cons (test-rewrite (car pair)) - (test-rewrite (cdr pair)))) - (define (default-on-vector vec) - (vector-map test-rewrite vec)) - (define (default-on-error error) - (let ((msg (error-object-message error)) - (irritants (error-object-irritants error))) - `(error (type ,(test-rewrite (error-object-type error))) - (who ,(test-rewrite (error-object-who error))) - (kind ,(test-rewrite (error-object-kind error))) - (msg ,(test-rewrite (error-object-message error))) - (irritants ,@(map test-rewrite (error-object-irritants error)))))) - (define default-rewriters - `((,pair? . ,default-on-pair) - (,vector? . ,default-on-vector) - (,error-object? . ,default-on-error))))
\ No newline at end of file diff --git a/lib/rewriters.r7rs.scm b/lib/rewriters.r7rs.scm deleted file mode 100644 index 3b6ba96..0000000 --- a/lib/rewriters.r7rs.scm +++ /dev/null @@ -1,37 +0,0 @@ -#| Copyright © 2025 Peter McGoron - | - | Permission is hereby granted, free of charge, to any person obtaining - | a copy of this software and associated documentation files (the - | “Software”), to deal in the Software without restriction, including - | without limitation the rights to use, copy, modify, merge, publish, - | distribute, sublicense, and/or sell copies of the Software, and to - | permit persons to whom the Software is furnished to do so, subject to - | the following conditions: - | - | The above copyright notice and this permission notice shall be included - | in all copies or substantial portions of the Software. - | - | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, - | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN - | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, - | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR - | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR - | THE USE OR OTHER DEALINGS IN THE SOFTWARE. - |# - -(begin - (define (default-on-pair pair) - (cons (test-rewrite (car pair)) - (test-rewrite (cdr pair)))) - (define (default-on-vector vec) - (vector-map test-rewrite vec)) - (define (default-on-error error) - (let ((msg (error-object-message error)) - (irritants (error-object-irritants error))) - (display (list msg irritants)) (newline) - (cons 'error (cons msg irritants)))) - (define default-rewriters - `((,pair? . ,default-on-pair) - (,vector? . ,default-on-vector) - (,error-object? . ,default-on-error))))
\ No newline at end of file diff --git a/lib/threads.r7rs-srfi-18.scm b/lib/threads.r7rs-srfi-18.scm deleted file mode 100644 index 59634d8..0000000 --- a/lib/threads.r7rs-srfi-18.scm +++ /dev/null @@ -1,31 +0,0 @@ -#| Copyright © 2025 Peter McGoron - | - | Permission is hereby granted, free of charge, to any person obtaining - | a copy of this software and associated documentation files (the - | “Software”), to deal in the Software without restriction, including - | without limitation the rights to use, copy, modify, merge, publish, - | distribute, sublicense, and/or sell copies of the Software, and to - | permit persons to whom the Software is furnished to do so, subject to - | the following conditions: - | - | The above copyright notice and this permission notice shall be included - | in all copies or substantial portions of the Software. - | - | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, - | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN - | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, - | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR - | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR - | THE USE OR OTHER DEALINGS IN THE SOFTWARE. - |# - -(define-record-type <test-info> - (%make-test-info dto dict mutex) - test-info? - (dto test-info-dto) - (dict test-info-dict set-test-info-dict!) - (mutex test-info-mutex)) - -(define (make-test-info dto dict) - (%make-test-info dto dict (make-mutex "test-info")))
\ No newline at end of file diff --git a/lib/threads.single-threaded-r7rs.scm b/lib/threads.single-threaded-r7rs.scm deleted file mode 100644 index f3138e8..0000000 --- a/lib/threads.single-threaded-r7rs.scm +++ /dev/null @@ -1,32 +0,0 @@ -#| Copyright © 2025 Peter McGoron - | - | Permission is hereby granted, free of charge, to any person obtaining - | a copy of this software and associated documentation files (the - | “Software”), to deal in the Software without restriction, including - | without limitation the rights to use, copy, modify, merge, publish, - | distribute, sublicense, and/or sell copies of the Software, and to - | permit persons to whom the Software is furnished to do so, subject to - | the following conditions: - | - | The above copyright notice and this permission notice shall be included - | in all copies or substantial portions of the Software. - | - | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, - | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN - | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, - | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR - | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR - | THE USE OR OTHER DEALINGS IN THE SOFTWARE. - |# - -(define-record-type <test-info> - (make-test-info dto dict) - test-info? - (dto test-info-dto) - (dict test-info-dict set-test-info-dict!)) - -(define (test-info-mutex x) #f) -(define (mutex-lock! x) #f) -(define (mutex-unlock! x) #f) - diff --git a/tests/impl.scm b/tests/impl.scm index 0395fb2..f8757cd 100644 --- a/tests/impl.scm +++ b/tests/impl.scm @@ -1,25 +1,3 @@ -#| Copyright © 2025 Peter McGoron - | - | Permission is hereby granted, free of charge, to any person obtaining - | a copy of this software and associated documentation files (the - | “Software”), to deal in the Software without restriction, including - | without limitation the rights to use, copy, modify, merge, publish, - | distribute, sublicense, and/or sell copies of the Software, and to - | permit persons to whom the Software is furnished to do so, subject to - | the following conditions: - | - | The above copyright notice and this permission notice shall be included - | in all copies or substantial portions of the Software. - | - | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, - | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN - | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, - | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR - | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR - | THE USE OR OTHER DEALINGS IN THE SOFTWARE. - |# - ;;; This is a meta-test suite for Conspire, similar to the meta-test ;;; suite of SRFI-64. ;;; @@ -31,7 +9,7 @@ (test-group "default keys" (for-each (lambda (key value) (let ((name (symbol->string key))) - (test-assert (string-append "contains " name) + (test-body (string-append "contains " name) (test-contains? key)) (test-eq name value (test-ref key)))) '(setup-test! after-test before-test! report-test @@ -51,12 +29,12 @@ (let ((pair (cons #f #f))) (test-set! 'nonexistent-key pair) (test-eq "set unused key" pair (test-ref 'nonexistent-key)) - (parameterize ((test-info '(box))) + (parameterize ((test-info (test-info-dict))) (test-eq "persistent across parameterization" pair (test-ref 'nonexistent-key)) (let ((pair2 (cons #f #f))) - (test-assert "made a new pair" + (test-body "made a new pair" (not (eq? pair pair2))) (test-set! 'nonexistent-key pair2) (test-eq "set key to a new pair" @@ -65,15 +43,14 @@ (test-eq "outside of parameterization" pair (test-ref 'nonexistent-key))) - (parameterize ((test-info (list 'replace - (test-set 'other-key 123)))) + (parameterize ((test-info (test-set 'other-key 123))) (test-eqv "other key in parameterization" 123 (test-ref 'other-key))) (test-eqv "does not affect outside" 456 (test-ref/default 'other-key 456)) - (test-assert "deleted key" + (test-body "deleted key" (test-delete! 'nonexistent-key) (not (test-contains? 'nonexistent-keys)))) @@ -85,46 +62,42 @@ ;;; `on-exception` handler. Hence exceptions inside of a `call-as-test` ;;; will trip the actual exception handler for the meta test-info. -(define-values (dummy-dto dummy-dict) - (inspect-test-info - (lambda (dto dict) - (define dummy (lambda _ #f)) - (values dto - (dict-set! dto - dict - 'skip-test? dummy - 'before-test! dummy - 'setup-test! dummy - 'when-test-skipped dummy - 'after-test values - 'report-test dummy - 'on-exception dummy - 'setup-group! dummy - 'before-group! dummy - 'after-group values - 'report-group dummy))))) +(define dummy-dict + (let ((dummy (lambda _ #f))) + (dict-set! (test-dto) + default-test-info-dict + 'skip-test? dummy + 'before-test! dummy + 'setup-test! dummy + 'when-test-skipped dummy + 'after-test values + 'report-test dummy + 'on-exception dummy + 'setup-group! dummy + 'before-group! dummy + 'after-group values + 'report-group dummy))) (test-group "call-as-test, dummy dict" (test-group "before test" - (test-assert "skip-test? skips tests when returning #f" + (test-body "skip-test? skips tests when returning #f" (parameterize ((test-info - (list 'replace - (dict-set! dummy-dto dummy-dict - 'skip-test? - (lambda (name) #t))))) + (dict-set! (test-dto) + dummy-dict + 'skip-test? + (lambda (name) #t)))) (let ((called? #f)) (call-as-test "name" (lambda () (set! called? #t))) (not called?)))) - (test-assert "before-test gets the test name" - (define inside-test-info - (dict-set! dummy-dto dummy-dict - 'before-test! - (lambda (name) - (unless (equal? name "1234") - (raise "exception")) - #t))) + (test-body "before-test gets the test name" (parameterize ((test-info - (list 'replace inside-test-info))) + (dict-set! (test-dto) + dummy-dict + 'before-test! + (lambda (name) + (unless (equal? name "1234") + (raise "exception")) + #t)))) (let ((called? #f)) (call-as-test "1234" (lambda () (set! called? #t))) @@ -132,76 +105,70 @@ (test-group "after test" (let ((called? #f) (pair (cons #f #f))) - (define inside-test-info - (dict-set! dummy-dto dummy-dict - 'after-test - (lambda (previous-dto previous-dict) - (set! called? - (dict-ref previous-dto previous-dict - 'after-test-test))))) - (test-assert "after test is called with previous test-info" + (define inside-test-info) + (test-body "after test is called with previous test-info" (parameterize ((test-info - (list 'replace dummy-dto inside-test-info))) + (dict-set! (test-dto) dummy-dict + 'after-test + (lambda (previous-dict) + (set! called? + (dict-ref (test-dto) + previous-dict + 'after-test-test)))))) (call-as-test #f (lambda () (test-set! 'after-test-test #t)))) called?)) - (let* ((pair (cons #f #f)) - (inside-test-info - (dict-set! dummy-dto dummy-dict - 'after-test - (lambda _ pair)))) + (let* ((pair (cons #f #f))) (test-eq "return value of call-as-test is after-test" pair (parameterize ((test-info - (list 'replace - dummy-dto inside-test-info))) + (dict-set! (test-dto) dummy-dict + 'after-test + (lambda _ pair)))) (call-as-test #f (lambda () #f)))))) - (test-assert "setup-test runs in dynamic extent" + (test-body "setup-test runs in dynamic extent" (let ((global-name "setup-test-name") (called? #f) (pair (cons #f #f))) - (define inside-test-info - (dict-set! dummy-dto dummy-dict - 'setup-test! - (lambda (name) - (test-set! 'setup-test-test pair)))) - (parameterize ((test-info (list 'replace dummy-dto inside-test-info))) + (parameterize ((test-info + (dict-set! (test-dto) + dummy-dict + 'setup-test! + (lambda (name) + (test-set! 'setup-test-test pair))))) (call-as-test global-name (lambda () (set! called? (eq? (test-ref 'setup-test-test) pair))))) (and called? (not (test-contains? 'setup-test-test))))) (test-group "on-exception" - (test-assert "not called" + (test-body "not called" (call/cc (lambda (return) (define inside-test-info - (dict-set! dummy-dto dummy-dict + (dict-set! (test-dto) + dummy-dict 'exception-not-called? #t 'on-exception (lambda (exn return) (test-set! 'exception-not-called? #f)) 'after-test - (lambda (previous-dto previous-dict) - (return (dict-ref previous-dto previous-dict + (lambda (previous-dict) + (return (dict-ref (test-dto) + previous-dict 'exception-not-called?))))) - (parameterize ((test-info (list 'replace dummy-dto - inside-test-info))) + (parameterize ((test-info inside-test-info)) (call-as-test #f (lambda () #f))) #f))) (let* ((message "exception message") - (caught #f) - (inside-test-info - (dict-set! dummy-dto dummy-dict - 'on-exception - (lambda (exn return) - (set! caught exn) - (return))))) - (test-assert "called" - (parameterize ((test-info - (list 'replace dummy-dto - inside-test-info))) + (caught #f)) + (test-body "called" + (parameterize ((test-info (dict-set! (test-dto) dummy-dict + 'on-exception + (lambda (exn return) + (set! caught exn) + (return))))) (call-as-test #f (lambda () (raise message))) caught))))) @@ -219,7 +186,7 @@ ;;; `(inspect-test-info values)` inside the dynamic extent. (define silent-dict - (dict-set! default-test-info-dto default-test-info-dict + (dict-set! default-test-dto default-test-info-dict 'before-test! values 'before-group! values 'report-test values @@ -227,223 +194,208 @@ (test-group "call-as-test, some defaults" (test-group "no name" - (define-values (dto dict outer-dto outer-dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) - (let*-values (((inner-dto inner-dict) - (call-as-test #f (lambda () #f))) - ((outer-dto outer-dict) - (inspect-test-info values))) - (values inner-dto inner-dict outer-dto outer-dict)))) - (test-eqv "name is #f" #f (dict-ref dto dict 'name)) - (test-eqv "name-stack" '() (dict-ref dto dict 'name-stack)) - (test-eqv "outer name is #f" #f (dict-ref outer-dto outer-dict 'name)) - (test-eqv "outer name-stack" '() (dict-ref outer-dto outer-dict 'name-stack))) + (define-values (dict outer-dict) + (parameterize ((test-info silent-dict)) + (let ((inner-dict (call-as-test #f (lambda () #f)))) + (values inner-dict (test-info-dict))))) + (test-eqv "name is #f" #f (dict-ref (test-dto) dict 'name)) + (test-eqv "name-stack" '() (dict-ref (test-dto) dict 'name-stack)) + (test-eqv "outer name is #f" #f (dict-ref (test-dto) outer-dict 'name)) + (test-eqv "outer name-stack" '() (dict-ref (test-dto) outer-dict 'name-stack))) (test-group "named" - (define-values (dto dict outer-dto outer-dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) - (let*-values (((inner-dto inner-dict) - (call-as-test "asdfasdf" (lambda () #f))) - ((outer-dto outer-dict) - (inspect-test-info values))) - (values inner-dto inner-dict outer-dto outer-dict)))) - (test-equal "name is #f" "asdfasdf" (dict-ref dto dict 'name)) - (test-equal "name-stack" '("asdfasdf") (dict-ref dto dict 'name-stack)) - (test-eqv "outer name is #f" #f (dict-ref outer-dto outer-dict 'name)) - (test-eqv "outer name-stack" '() (dict-ref outer-dto outer-dict 'name-stack))) + (define-values (dict outer-dict) + (parameterize ((test-info silent-dict)) + (let ((inner-dict (call-as-test "asdfasdf" (lambda () #f)))) + (values inner-dict (test-info-dict))))) + (test-equal "name is #f" "asdfasdf" (dict-ref (test-dto) dict 'name)) + (test-equal "name-stack" '("asdfasdf") (dict-ref (test-dto) dict 'name-stack)) + (test-eqv "outer name is #f" #f (dict-ref (test-dto) outer-dict 'name)) + (test-eqv "outer name-stack" '() (dict-ref (test-dto) outer-dict 'name-stack))) (test-group "tests that success is true" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (define dict + (parameterize ((test-info silent-dict)) (call-as-test #f (lambda () (test-set! 'success? #t))) - (inspect-test-info values))) - (test-eqv "passed number" 1 (dict-ref dto dict 'passed)) - (test-eqv "failed number" 0 (dict-ref dto dict 'failed)) - (test-eqv "test number" 1 (dict-ref dto dict 'tests))) + (test-info-dict))) + (test-eqv "passed number" 1 (dict-ref (test-dto) dict 'passed)) + (test-eqv "failed number" 0 (dict-ref (test-dto) dict 'failed)) + (test-eqv "test number" 1 (dict-ref (test-dto) dict 'tests))) (test-group "test that success is false" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (define dict + (parameterize ((test-info silent-dict)) (call-as-test #f (lambda () (test-set! 'success? #f))) - (inspect-test-info values))) - (test-eqv "passed number" 0 (dict-ref dto dict 'passed)) - (test-eqv "failed number" 1 (dict-ref dto dict 'failed)) - (test-eqv "test number" 1 (dict-ref dto dict 'tests))) + (test-info-dict))) + (test-eqv "passed number" 0 (dict-ref (test-dto) dict 'passed)) + (test-eqv "failed number" 1 (dict-ref (test-dto) dict 'failed)) + (test-eqv "test number" 1 (dict-ref (test-dto) dict 'tests))) (test-group "success not set" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (define dict + (parameterize ((test-info silent-dict)) (call-as-test #f (lambda () #f)) - (inspect-test-info values))) - (test-eqv "passed number" 0 (dict-ref dto dict 'passed)) - (test-eqv "failed number" 1 (dict-ref dto dict 'failed)) - (test-eqv "test number" 1 (dict-ref dto dict 'tests))) + (test-info-dict))) + (test-eqv "passed number" 0 (dict-ref (test-dto) dict 'passed)) + (test-eqv "failed number" 1 (dict-ref (test-dto) dict 'failed)) + (test-eqv "test number" 1 (dict-ref (test-dto) dict 'tests))) (test-group "catching exceptions" (define pair (cons #f #f)) - (define-values (inner-dto inner-dict outer-dto outer-dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) - (let*-values (((inner-dto inner-dict) (call-as-test #f (lambda () (raise pair)))) - ((outer-dto outer-dict) (inspect-test-info values))) - (values inner-dto inner-dict outer-dto outer-dict)))) - (test-eqv "exception" pair (dict-ref inner-dto inner-dict 'exception)) - (test-eqv "passed number" 0 (dict-ref outer-dto outer-dict 'passed)) - (test-eqv "failed number" 1 (dict-ref outer-dto outer-dict 'failed)) - (test-eqv "test number" 1 (dict-ref outer-dto outer-dict 'tests)))) + (define-values (inner-dict outer-dict) + (parameterize ((test-info silent-dict)) + (let ((inner-dict (call-as-test #f (lambda () (raise pair))))) + (values inner-dict (test-info-dict))))) + (test-eqv "exception" pair (dict-ref (test-dto) inner-dict 'exception)) + (test-eqv "passed number" 0 (dict-ref (test-dto) outer-dict 'passed)) + (test-eqv "failed number" 1 (dict-ref (test-dto) outer-dict 'failed)) + (test-eqv "test number" 1 (dict-ref (test-dto) outer-dict 'tests)))) (test-group "call-as-group" (test-group "group with no tests" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (define dict + (parameterize ((test-info silent-dict)) (call-as-group #f (lambda () #f)) - (inspect-test-info values))) - (test-eqv "passed number" 0 (dict-ref dto dict 'passed)) - (test-eqv "tests number" 0 (dict-ref dto dict 'tests)) - (test-eqv "failed number" 0 (dict-ref dto dict 'failed)) - (test-eqv "skipped number" 0 (dict-ref dto dict 'skipped))) + (test-info-dict))) + (test-eqv "passed number" 0 (dict-ref (test-dto) dict 'passed)) + (test-eqv "tests number" 0 (dict-ref (test-dto) dict 'tests)) + (test-eqv "failed number" 0 (dict-ref (test-dto) dict 'failed)) + (test-eqv "skipped number" 0 (dict-ref (test-dto) dict 'skipped))) (test-group "group with 1 test" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) - (test-group #f (test-assert #f #t)) - (inspect-test-info values))) - (test-eqv "passed number" 1 (dict-ref dto dict 'passed)) - (test-eqv "tests number" 1 (dict-ref dto dict 'tests)) - (test-eqv "failed number" 0 (dict-ref dto dict 'failed)) - (test-eqv "skipped number" 0 (dict-ref dto dict 'skipped))) + (define dict + (parameterize ((test-info silent-dict)) + (test-group #f (test-body #f #t)) + (test-info-dict))) + (test-eqv "passed number" 1 (dict-ref (test-dto) dict 'passed)) + (test-eqv "tests number" 1 (dict-ref (test-dto) dict 'tests)) + (test-eqv "failed number" 0 (dict-ref (test-dto) dict 'failed)) + (test-eqv "skipped number" 0 (dict-ref (test-dto) dict 'skipped))) (test-group "group with multiple tests" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (define dict + (parameterize ((test-info silent-dict)) (test-group #f - (call-as-test #f (lambda () - (test-set! 'success? #t))) - (call-as-test #f (lambda () - (test-set! 'success? #t))) - (call-as-test #f (lambda () - (test-set! 'success? #f))) + (call-as-test #f (lambda () (test-set! 'success? #t))) + (call-as-test #f (lambda () (test-set! 'success? #t))) + (call-as-test #f (lambda () (test-set! 'success? #f))) (test-skip-all - (call-as-test #f (lambda () - (test-set! 'success? #f))))) - (inspect-test-info values))) + (call-as-test #f (lambda () (test-set! 'success? #f))))) + (test-info-dict))) (begin - (test-eqv "passed number" 2 (dict-ref dto dict 'passed)) - (test-eqv "tests number" 4 (dict-ref dto dict 'tests)) - (test-eqv "failed number" 1 (dict-ref dto dict 'failed)) - (test-eqv "skipped number" 1 (dict-ref dto dict 'skipped)))) + (test-eqv "passed number" 2 (dict-ref (test-dto) dict 'passed)) + (test-eqv "tests number" 4 (dict-ref (test-dto) dict 'tests)) + (test-eqv "failed number" 1 (dict-ref (test-dto) dict 'failed)) + (test-eqv "skipped number" 1 (dict-ref (test-dto) dict 'skipped)))) (test-group "nested groups" (define inner-dict #f) - (define inner-dto #f) - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (define dict + (parameterize ((test-info silent-dict)) (test-group "gr1" - (test-assert #f #t) + (test-body #f #t) (test-group "gr2" - (test-assert #f - (inspect-test-info - (lambda (dto dict) - (set! inner-dto dto) - (set! inner-dict dict))) + (test-body #f + (set! inner-dict (test-info-dict)) #f))) (inspect-test-info values))) - (test-eqv "passed number" 1 (dict-ref dto dict 'passed)) - (test-eqv "tests number" 2 (dict-ref dto dict 'tests)) - (test-eqv "failed number" 1 (dict-ref dto dict 'failed)) - (test-eqv "skipped number" 0 (dict-ref dto dict 'skipped)) - (test-eqv "inner name" #f (dict-ref inner-dto inner-dict 'name)) + (test-eqv "passed number" 1 (dict-ref (test-dto) dict 'passed)) + (test-eqv "tests number" 2 (dict-ref (test-dto) dict 'tests)) + (test-eqv "failed number" 1 (dict-ref (test-dto) dict 'failed)) + (test-eqv "skipped number" 0 (dict-ref (test-dto) dict 'skipped)) + (test-eqv "inner name" #f (dict-ref (test-dto) inner-dict 'name)) (test-equal "inner name stack" '("gr2" "gr1") - (dict-ref inner-dto inner-dict 'name-stack)))) + (dict-ref (test-dto) inner-dict 'name-stack)))) (test-group "test application" - (test-assert "true" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-body "true" + (define dict + (parameterize ((test-info silent-dict)) (test-application "not" (not not) (arg #f)) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'passed))) - (test-assert "false" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'passed))) + (test-body "false" + (define dict + (parameterize ((test-info silent-dict)) (test-application "not" (not not) (arg #t)) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'failed)))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'failed)))) (test-group "test-equal" - (test-assert "true" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-body "true" + (define dict + (parameterize ((test-info silent-dict)) (test-equal "equal" "abc" "abc") - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'passed))) - (test-assert "false" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'passed))) + (test-body "false" + (define dict + (parameterize ((test-info silent-dict)) (test-equal "equal" "abc" "def") - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'failed)))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'failed)))) (test-group "test-eq" - (test-assert "true" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-body "true" + (define dict + (parameterize ((test-info silent-dict)) (test-eq "eq" 'abc 'abc) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'passed))) - (test-assert "false" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'passed))) + (test-body "false" + (define dict + (parameterize ((test-info silent-dict)) (test-eq "eq" 'abc 'def) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'failed)))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'failed)))) (test-group "test-eqv" - (test-assert "true" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-body "true" + (define dict + (parameterize ((test-info silent-dict)) (test-eqv "eqv" 100 100) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'passed))) - (test-assert "false" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'passed))) + (test-body "false" + (define dict + (parameterize ((test-info silent-dict)) (test-eqv "eqv" 100 200) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'failed)))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'failed)))) (test-group "test-approximate" - (test-assert "true" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-body "true" + (define dict + (parameterize ((test-info silent-dict)) (test-approximate "approx" 1 1.001 0.01) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'passed))) - (test-assert "false" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'passed))) + (test-body "false" + (define dict + (parameterize ((test-info silent-dict)) (test-approximate "approx" 100 1.01 0.01) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'failed)))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'failed)))) (test-group "test-error" - (test-assert "thrown exception" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-body "thrown exception" + (define dict + (parameterize ((test-info silent-dict)) (test-error #f (lambda (ex) (equal? ex "exception")) (raise "exception")) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'passed))) - (test-assert "no thrown exception" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'passed))) + (test-body "no thrown exception" + (define dict + (parameterize ((test-info silent-dict)) (test-error #f (lambda (ex) #t) #f) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'failed))) - (test-assert "incorrectly thrown exception" - (define-values (dto dict) - (parameterize ((test-info (list 'replace default-test-info-dto silent-dict))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'failed))) + (test-body "incorrectly thrown exception" + (define dict + (parameterize ((test-info silent-dict)) (test-error #f number? (raise "exception")) - (inspect-test-info values))) - (eqv? 1 (dict-ref dto dict 'failed)))) + (test-info-dict))) + (eqv? 1 (dict-ref (test-dto) dict 'failed)))) (test-group "expect-to-fail" (expect-to-fail - (test-assert "1 = 2" (eqv? 1 2)) - (test-assert "type error" (car '())))) + (test-body "1 = 2" (eqv? 1 2)) + (test-body "type error" (car '())))) (test-exit) diff --git a/tests/run.scm b/tests/run.scm index 474672c..e70e8af 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -1,30 +1,8 @@ -#| Copyright © 2025 Peter McGoron - | - | Permission is hereby granted, free of charge, to any person obtaining - | a copy of this software and associated documentation files (the - | “Software”), to deal in the Software without restriction, including - | without limitation the rights to use, copy, modify, merge, publish, - | distribute, sublicense, and/or sell copies of the Software, and to - | permit persons to whom the Software is furnished to do so, subject to - | the following conditions: - | - | The above copyright notice and this permission notice shall be included - | in all copies or substantial portions of the Software. - | - | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, - | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN - | NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, - | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR - | OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR - | THE USE OR OTHER DEALINGS IN THE SOFTWARE. - |# - (cond-expand (chicken-5 (import r7rs)) - (else #f)) + (else)) -(import (conspire) (srfi 225) (scheme load)) +(import (cuprate) (srfi 225)) + (include "impl.scm") -(include "impl.scm") |
