55 lines
2.2 KiB
Scheme
55 lines
2.2 KiB
Scheme
(module tests-common mzscheme
|
|
|
|
(require (lib "private/annotate.ss" "stepper")
|
|
(lib "contract.ss")
|
|
(lib "shared.ss" "stepper" "private"))
|
|
|
|
(provide/contract (reset-namespaces (-> void?))
|
|
(annotate-exprs (-> (listof syntax?) break-contract (listof syntax?)))
|
|
(string->stx-list (-> string? (listof syntax?))))
|
|
|
|
(provide mz-namespace
|
|
beginner-namespace
|
|
beginner-wla-namespace
|
|
intermediate-namespace
|
|
intermediate/lambda-namespace)
|
|
|
|
; : ((listof syntax?) (recon-result recon-result -> (void)) -> (listof syntax)
|
|
(define (annotate-exprs stx-list break)
|
|
(let loop ([env (make-initial-env-package)] [stx-list stx-list])
|
|
(if (null? stx-list)
|
|
null
|
|
(let*-values ([(annotated new-env)
|
|
(annotate (car stx-list) env break 'foot-wrap)])
|
|
(cons annotated (loop new-env (cdr stx-list)))))))
|
|
|
|
; : (string -> (listof syntax)
|
|
(define (string->stx-list stx)
|
|
(let ([port (open-input-string stx)])
|
|
(let loop ([first-stx (read-syntax 'test-program port)])
|
|
(if (eof-object? first-stx)
|
|
null
|
|
(cons first-stx (loop (read-syntax 'test-program port)))))))
|
|
|
|
(define source-namespace (current-namespace))
|
|
|
|
(define mz-namespace #f)
|
|
(define beginner-namespace #f)
|
|
(define beginner-wla-namespace #f)
|
|
(define intermediate-namespace #f)
|
|
(define intermediate/lambda-namespace #f)
|
|
|
|
(define (new-namespace-from-spec spec)
|
|
(let ([new-namespace (make-namespace 'empty)])
|
|
(parameterize ([current-namespace new-namespace])
|
|
(namespace-attach-module source-namespace 'mzscheme)
|
|
(namespace-require spec))
|
|
new-namespace))
|
|
|
|
(define (reset-namespaces)
|
|
(set! mz-namespace (new-namespace-from-spec '(lib "plt-mzscheme.ss" "lang")))
|
|
(set! beginner-namespace (new-namespace-from-spec '(lib "htdp-beginner.ss" "lang")))
|
|
(set! beginner-wla-namespace (new-namespace-from-spec '(lib "htdp-beginner-abbr.ss" "lang")))
|
|
(set! intermediate-namespace (new-namespace-from-spec '(lib "htdp-intermediate.ss" "lang")))
|
|
(set! intermediate/lambda-namespace (new-namespace-from-spec '(lib "htdp-intermediate-lambda.ss" "lang")))))
|