115 lines
4.4 KiB
Scheme
115 lines
4.4 KiB
Scheme
(module module-elaborator mzscheme
|
|
|
|
(require (lib "list.ss")
|
|
(lib "contract.ss"))
|
|
|
|
(provide/contract [wrap-in-module ((listof syntax?) any/c (listof any/c) . -> . (listof syntax?))] )
|
|
|
|
;; full-on COPIED from plt/collects/lang/htdp-langs.ss
|
|
|
|
(define (wrap-in-module exps language-module-spec teachpack-specs)
|
|
(let ([new-module-id (gensym "-htdp")])
|
|
(with-syntax ([(tp-spec ...) teachpack-specs])
|
|
(list (let ([mod (expand #`(module #,new-module-id #,language-module-spec
|
|
(require-for-syntax mzscheme)
|
|
(require tp-spec ...)
|
|
#,@exps))])
|
|
(rewrite-module mod))
|
|
#`(require #,new-module-id)
|
|
; #`(let ([done-already? #f])
|
|
; (dynamic-wind
|
|
; void
|
|
; (lambda () (dynamic-require '#,new-module-id #f))
|
|
; (lambda ()
|
|
; (unless done-already?
|
|
; (set! done-already? #t)
|
|
; (current-namespace (module->namespace '#,new-module-id))))))
|
|
))))
|
|
|
|
;; rewrite-module : syntax -> syntax
|
|
;; rewrites te module to provide all definitions and
|
|
;; print out all results.
|
|
|
|
(define (rewrite-module stx)
|
|
(syntax-case stx (module #%plain-module-begin)
|
|
[(module name lang (#%plain-module-begin bodies ...))
|
|
(with-syntax ([(rewritten-bodies ...)
|
|
(rewrite-bodies (syntax->list (syntax (bodies ...))))])
|
|
(syntax (module name lang
|
|
(#%plain-module-begin
|
|
rewritten-bodies ...))))]
|
|
[else
|
|
(raise-syntax-error 'htdp-languages "internal error .1")]))
|
|
|
|
;; rewrite-bodies : (listof syntax) -> syntax
|
|
(define (rewrite-bodies bodies)
|
|
(let loop ([bodies bodies]
|
|
[ids null])
|
|
(cond
|
|
[(null? bodies)
|
|
(list
|
|
(with-syntax ([(ids ...) ids])
|
|
(syntax (provide ids ...))))]
|
|
[else
|
|
(let ([body (car bodies)])
|
|
(syntax-case body (define-values define-syntaxes require require-for-syntax provide)
|
|
[(define-values (new-vars ...) e)
|
|
(cons body (loop (cdr bodies)
|
|
(append
|
|
ids
|
|
(filter-ids (syntax (new-vars ...))))))]
|
|
[(define-syntaxes (new-vars ...) e)
|
|
(cons body (loop (cdr bodies)
|
|
(append
|
|
ids
|
|
(filter-ids (syntax (new-vars ...))))))]
|
|
[(require specs ...)
|
|
(cons body (loop (cdr bodies) ids))]
|
|
[(require-for-syntax specs ...)
|
|
(cons body (loop (cdr bodies) ids))]
|
|
[(provide specs ...)
|
|
(loop (cdr bodies) ids)]
|
|
[else
|
|
(let ([new-exp
|
|
(with-syntax ([body body]
|
|
[print-results
|
|
(lambda (dont-care)
|
|
(void) ; intended to simulate the code in drscheme that actually does something.
|
|
)])
|
|
(syntax
|
|
(call-with-values
|
|
(lambda () body)
|
|
print-results)))])
|
|
(cons new-exp (loop (cdr bodies) ids)))]))])))
|
|
|
|
(define (filter-ids ids)
|
|
;; When a `define-values' or `define-syntax' declaration
|
|
;; is macro-generated, if the defined name also originates
|
|
;; from a macro, then the name is hidden to anything
|
|
;; that wasn't generated by the same macro invocation. This
|
|
;; hiding relies on renaming at the symbol level, and it's
|
|
;; exposed by the fact that `syntax-e' of the identifier
|
|
;; returns a different name than `identifier-binding'.
|
|
(filter
|
|
(lambda (id)
|
|
(let ([ib (identifier-binding id)])
|
|
;; ib should always be a 4-elem list, but
|
|
;; check, just in case:
|
|
(or (not (pair? ib))
|
|
(eq? (syntax-e id)
|
|
(cadr ib)))))
|
|
(syntax->list ids)))
|
|
|
|
|
|
; pathetic 'verified-by-inspection' test case:
|
|
|
|
`(define test-reader
|
|
(let ([done? #f])
|
|
(lambda ()
|
|
(if done?
|
|
eof
|
|
(begin
|
|
(set! done? #t)
|
|
#'(+ 3 4))))))
|
|
`(printf "~a\n" (wrap-in-module test-reader `(lib "htdp-beginner.ss" "lang")))
|
|
) |