154 lines
4.4 KiB
Scheme
154 lines
4.4 KiB
Scheme
|
|
(define (strip-context v)
|
|
;; Just to be sure, remove all top-level context from the syntax object
|
|
(cond
|
|
[(syntax? v)
|
|
(datum->syntax-object
|
|
#f
|
|
(strip-context (syntax-e v))
|
|
v
|
|
v)]
|
|
[(pair? v) (cons (strip-context (car v))
|
|
(strip-context (cdr v)))]
|
|
[else v]))
|
|
|
|
(define body-accum null)
|
|
(define-syntax (htdp-top stx)
|
|
(syntax-case stx (quote)
|
|
[(_ expr)
|
|
#'(set! body-accum (append body-accum (list (strip-context #'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 teachpack-accum null)
|
|
(define-syntax (htdp-teachpack stx)
|
|
(syntax-case stx ()
|
|
[(_ lib)
|
|
#'(set! teachpack-accum (cons (strip-context (quote-syntax lib)) teachpack-accum))]))
|
|
(define (htdp-teachpack-pop)
|
|
(set! teachpack-accum (cdr teachpack-accum)))
|
|
|
|
(define previous-tp-accum #f)
|
|
(define previous-tp-lang #f)
|
|
(define (add-teachpacks lang)
|
|
(cond
|
|
[(null? teachpack-accum) lang]
|
|
[(equal? teachpack-accum previous-tp-accum)
|
|
previous-tp-lang]
|
|
[else
|
|
(let ([name (string->symbol (format "~a+tp~a" lang (gensym)))])
|
|
(eval #`(module #,name mzscheme
|
|
(define-syntax (bounce stx)
|
|
#'(begin
|
|
(require #,lang #,@teachpack-accum)
|
|
(provide (all-from #,lang)
|
|
#,@(map (lambda (tp)
|
|
#`(all-from #,tp))
|
|
teachpack-accum))))
|
|
(bounce)))
|
|
(set! previous-tp-accum teachpack-accum)
|
|
(set! previous-tp-lang name)
|
|
name)]))
|
|
|
|
(define htdp-syntax-test
|
|
(case-lambda
|
|
[(stx) (htdp-syntax-test stx #rx".")]
|
|
[(stx rx)
|
|
(error-test #`(module m #,(add-teachpacks current-htdp-lang)
|
|
#,@body-accum
|
|
#,(strip-context stx))
|
|
(lambda (x)
|
|
(and (exn:fail:syntax? x)
|
|
(regexp-match rx (exn-message x)))))]))
|
|
|
|
(require (rename mzscheme mz-let let))
|
|
|
|
(define-syntax (htdp-test stx)
|
|
(syntax-case stx ()
|
|
[(_ expect f . args)
|
|
#'(begin
|
|
(do-htdp-test #'(test expect f . args) #f #f)
|
|
(htdp-try-direct-module f . args))]))
|
|
|
|
(define-syntax (htdp-try-direct-module stx)
|
|
(syntax-case stx ()
|
|
[(_ 'nm expr)
|
|
;; double-check that there's no error, at least,
|
|
;; when using the real module-begin:
|
|
#'(mz-let ([name (gensym)])
|
|
(eval
|
|
#`(module #,name #,(add-teachpacks current-htdp-lang)
|
|
#,@body-accum
|
|
#,(strip-context #'expr)))
|
|
(dynamic-require name #f))]
|
|
[_
|
|
(printf "~s\n" (syntax-object->datum stx))
|
|
#'(void)]))
|
|
|
|
(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 requires . rest)
|
|
#`(#%module-begin
|
|
(require (rename tester the-test test))
|
|
(require lang . requires)
|
|
#,@(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
|
|
#,teachpack-accum
|
|
#,@body-accum
|
|
#,(strip-context 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
|
|
#,teachpack-accum
|
|
#,@body-accum
|
|
(define the-answer #,(strip-context stx))))
|
|
(dynamic-require name 'the-answer)))
|