90 lines
2.3 KiB
Scheme
90 lines
2.3 KiB
Scheme
|
|
(define body-accum null)
|
|
(define-syntax (htdp-top stx)
|
|
(syntax-case stx (quote)
|
|
[(_ expr)
|
|
#'(set! body-accum (append body-accum (list #'expr)))]))
|
|
(define (htdp-top-pop w)
|
|
(set! body-accum (let loop ([body-accum body-accum])
|
|
(if (null? (cdr body-accum))
|
|
null
|
|
(cons (car body-accum) (loop (cdr body-accum)))))))
|
|
|
|
(define htdp-syntax-test
|
|
(case-lambda
|
|
[(stx) (htdp-syntax-test stx #rx".")]
|
|
[(stx rx)
|
|
(error-test #`(module m #,current-htdp-lang
|
|
#,@body-accum
|
|
#,stx)
|
|
(lambda (x)
|
|
(and (exn:fail:syntax? x)
|
|
(regexp-match rx (exn-message x)))))]))
|
|
|
|
(define-syntax (htdp-test stx)
|
|
(syntax-case stx ()
|
|
[(_ expect f . args)
|
|
#'(do-htdp-test #'(test expect f . args) #f #f)]))
|
|
|
|
(define (htdp-string-to-pred exn?/rx)
|
|
(if (string? exn?/rx)
|
|
(lambda (x)
|
|
(regexp-match exn?/rx (exn-message x)))
|
|
exn?/rx))
|
|
|
|
(define-syntax (htdp-err/rt-test stx)
|
|
(syntax-case stx ()
|
|
[(_ expr)
|
|
#'(do-htdp-test #'expr #f exn:application:type?)]
|
|
[(_ expr exn?)
|
|
#'(do-htdp-test #'expr #f (htdp-string-to-pred exn?))]))
|
|
|
|
(define (htdp-error-test stx)
|
|
(do-htdp-test stx #t #f))
|
|
|
|
(module helper mzscheme
|
|
(define-syntax (module-begin stx)
|
|
(syntax-case stx ()
|
|
[(_ the-test lang to-export . rest)
|
|
#`(#%module-begin
|
|
(require (rename tester the-test test))
|
|
(require lang)
|
|
#,@(if (syntax-object->datum (syntax to-export))
|
|
(list (syntax (provide to-export)))
|
|
'())
|
|
. rest)]))
|
|
(provide (rename module-begin #%module-begin)))
|
|
|
|
(module tester mzscheme
|
|
(define test (namespace-variable-value 'test))
|
|
(provide test))
|
|
|
|
(define (do-htdp-test stx stx-err? exn?)
|
|
(let ([name (gensym 'm)])
|
|
((if stx-err? syntax-test eval)
|
|
#`(module #,name helper
|
|
test
|
|
(all-except #,current-htdp-lang #%module-begin)
|
|
#f
|
|
#,@body-accum
|
|
#,stx))
|
|
(unless stx-err?
|
|
(if exn?
|
|
(err/rt-test (eval #`(require #,name)) exn?)
|
|
(eval #`(require #,name))))))
|
|
|
|
(define-syntax (htdp-eval stx)
|
|
(syntax-case stx ()
|
|
[(_ arg) (syntax (do-htdp-eval #'arg))]))
|
|
|
|
(define (do-htdp-eval stx)
|
|
(let ([name (gensym 'm)])
|
|
(eval
|
|
#`(module #,name helper
|
|
test
|
|
(all-except #,current-htdp-lang #%module-begin)
|
|
the-answer
|
|
#,@body-accum
|
|
(define the-answer #,stx)))
|
|
(dynamic-require name 'the-answer)))
|