dane/d-
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Use parameterized context instead of macro weirdness for tests

Browse Source
This commit is contained in:
Dane Johnson
2026-05-19 11:53:53 -05:00
parent 56fdd158d2
commit 57756193ab
2 changed files with 43 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

66
d-/test.scm
View File

@@ -2,15 +2,31 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 control) #:use-module (ice-9 control)
#:export (define-test-suite anything)) #:export (define-test-suite
assert-equal assert-not-equal assert-unspecified
anything))
(define *anysym* (gensym)) (define *anysym* (gensym))
(define (anything) *anysym*) (define (anything) *anysym*)
(define (assert expected actual eq? fail) (define *fail* (make-parameter #f))
(when (and (not (eq? expected actual)))
(define (assert expected actual eq?)
(cond
[(not (*fail*)) (error "assertion outside test context")]
[(not (eq? expected actual))
(format #t "fail - expected ~a but got ~a~%" expected actual) (format #t "fail - expected ~a but got ~a~%" expected actual)
(fail))) ((*fail*))]
[else #t]))
(define (assert-equal e a)
(assert e a equal-or-any?))
(define (assert-not-equal e a)
(assert e a (compose not equal-or-any?)))
(define (assert-unspecified v)
(assert (when #f '_) v eq?))
(define (equal-or-any? expected actual) (define (equal-or-any? expected actual)
(cond (cond
@@ -22,27 +38,21 @@
(define-syntax define-test-suite (define-syntax define-test-suite
(lambda (stx) (lambda (stx)
(with-syntax ([fail (datum->syntax stx 'fail)]) (define (define-test-stx test)
(define (assert-stx expr) (syntax-case test (define-test)
(syntax-case expr (assert-equal assert-not-equal assert-unspecified) [(define-test test-name e ...)
[(assert-equal e a) #'(assert e a equal-or-any? fail)] #`(call/ec
[(assert-not-equal e a) #'(assert e a (compose not equal-or-any?) fail)] (lambda (fail)
[(assert-unspecified v) #'(assert (when #f 'a) v eq? fail)] (parameterize ([*fail* fail])
[else #'else])) (format #t "~a: " test-name)
(define (define-test-stx test) e ...
(syntax-case test (define-test) (display "ok")
[(define-test test-name e ...) (newline))))]))
#`(call/ec (lambda (fail) (syntax-case stx ()
(format #t "~a: " test-name) [(define-test-suite name test ...)
(begin #`(begin
#,@(map assert-stx #'(e ...))) (format #t "Suite ~a:" name)
(display "ok") (newline)
(newline)))])) #,@(map define-test-stx
(syntax-case stx () #'(test ...))
[(define-test-suite name test ...) (newline))])))
#`(begin
(format #t "Suite ~a:" name)
(newline)
#,@(map define-test-stx
#'(test ...))
(newline))]))))

7
test.scm
View File

@@ -200,16 +200,19 @@
(define solution (get-solution)) (define solution (get-solution))
(assert-equal 'norwegian (assq-ref solution '?water-drinker)) (assert-equal 'norwegian (assq-ref solution '?water-drinker))
(assert-equal 'japanese (assq-ref solution '?zebra-owner))) (assert-equal 'japanese (assq-ref solution '?zebra-owner)))
(define-test "with-db" (define-test "with-db"
(define my-db '()) (define my-db '())
(define get-solution #f) (define get-solution #f)
(define solution #f) (define solution #f)
(with-db my-db (with-db my-db
(<- (foo bar))) (<- (foo bar)))
;; Outside context
(set! get-solution (?- (foo ?x))) (set! get-solution (?- (foo ?x)))
(set! solution (get-solution)) (set! solution (get-solution))
(assert-equal #f (assq-ref solution '?x)) (assert-equal #f (assq-ref solution '?x))
;; Inside context
(with-db my-db (with-db my-db
(set! get-solution (?- (foo ?x))) (set! get-solution (?- (foo ?x)))
(set! solution (get-solution))) (set! solution (get-solution))
(assert-equal 'bar (assq-ref solution '?x)))) (assert-equal 'bar (assq-ref solution '?x)))))