3ba54a2a3e
drracket so they put the 'source' field into the syntax objects that they create (at the very top) this allows the debugger to connect the syntax objects to the file that's open in drracket (the way this worked changed a while back, but I didn't check the teaching languages to see if the debugger was supposed to work there) closes PR 13159 please merge to the release branch
143 lines
5.5 KiB
Racket
143 lines
5.5 KiB
Racket
#lang scheme/base
|
|
|
|
(require "stepper-language-interface.rkt"
|
|
"debugger-language-interface.rkt"
|
|
stepper/private/syntax-property
|
|
scheme/class
|
|
scheme/contract
|
|
test-engine/racket-tests
|
|
(only-in racket/list split-at)
|
|
(only-in racket/sequence sequence->list))
|
|
|
|
(provide/contract
|
|
[expand-teaching-program (->* (input-port?
|
|
(-> any/c input-port? any/c)
|
|
any/c
|
|
(listof any/c))
|
|
(symbol? boolean?)
|
|
any)])
|
|
|
|
;; this function expands a port providing a program and a bunch of
|
|
;; arguments describing the user environment, and returns a thunk
|
|
;; that returns the top-level expressions that make up the expanded
|
|
;; program, one on each call.
|
|
|
|
;; the expanded program generally contains two expressions: a module, and
|
|
;; a require. The module includes a 'require' for each teachpack that
|
|
;; the user has added. Also, any 'provide' expressions are stripped out.
|
|
|
|
(define (expand-teaching-program port reader language-module teachpacks [module-name '#%htdp] [enable-testing? #t])
|
|
(define state 'init)
|
|
;; state : 'init => 'require => 'done-or-exn
|
|
|
|
;; in state 'done-or-exn, if this is an exn, we raise it
|
|
;; otherwise, we just return eof
|
|
(define saved-exn #f)
|
|
|
|
(lambda ()
|
|
(case state
|
|
[(init)
|
|
(set! state 'require)
|
|
(with-handlers ([exn:fail?
|
|
(λ (x)
|
|
(set! saved-exn x)
|
|
(expand
|
|
(datum->syntax
|
|
#f
|
|
`(,#'module ,module-name ,language-module
|
|
,@(map (λ (x)
|
|
`(require ,x))
|
|
teachpacks)))))])
|
|
(define body-exps (suck-all-exps port reader))
|
|
(define teachpack-requires (teachpacks->requires teachpacks))
|
|
(rewrite-module
|
|
(expand
|
|
(datum->syntax
|
|
#f
|
|
`(,#'module ,module-name ,language-module
|
|
,@teachpack-requires
|
|
,@(if enable-testing?
|
|
(if (null? body-exps)
|
|
'()
|
|
;; this definition pulls the test~object binding from the user's namespace
|
|
;; over to the one that is used in the REPL when module->namepsace
|
|
;; grabs a hold of this module to make a namespace for the REPL
|
|
`(,(syntax-property
|
|
#`(define #,(datum->syntax #f 'test~object) (namespace-variable-value 'test~object))
|
|
'test-call #t)))
|
|
'())
|
|
,@body-exps)
|
|
(vector (object-name port) #f #f #f #f)))))]
|
|
[(require)
|
|
(set! state 'done-or-exn)
|
|
(stepper-skip
|
|
#`(let ([done-already? #f])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(dynamic-require ''#,module-name #f)) ;; work around a bug in dynamic-require
|
|
(lambda ()
|
|
(unless done-already?
|
|
(set! done-already? #t)
|
|
#,(if enable-testing?
|
|
#'(test)
|
|
#'(begin))
|
|
(current-namespace (module->namespace ''#,module-name)))))))]
|
|
[(done-or-exn)
|
|
(cond
|
|
[saved-exn (raise saved-exn)]
|
|
[else eof])])))
|
|
|
|
;; take all of the body expressions from the port
|
|
(define (suck-all-exps port reader)
|
|
(define (port-reader p) (parameterize ([read-accept-lang #f])
|
|
(reader (object-name port) p)))
|
|
(sequence->list (in-port port-reader port)))
|
|
|
|
;; check that the teachpacks exist, return
|
|
;; syntax objects that require them (tagged
|
|
;; with stepper-skip-completely)
|
|
(define (teachpacks->requires teachpacks)
|
|
(for/list ([tp (in-list teachpacks)])
|
|
(unless (file-exists? (build-path (apply collection-path (cddr tp))
|
|
(cadr tp)))
|
|
(error 'teachpack (missing-tp-message tp)))
|
|
(stepper-skip
|
|
(datum->syntax #f `(require ,tp)))))
|
|
|
|
(define (missing-tp-message x)
|
|
(let* ([m (regexp-match #rx"/([^/]*)$" (cadr x))]
|
|
[name (if m
|
|
(cadr m)
|
|
(cadr x))])
|
|
(format "the teachpack '~a' was not found" name)))
|
|
|
|
|
|
;; rewrite-module : syntax -> syntax
|
|
;; rewrites the module to remove provide's (for now...)
|
|
(define (rewrite-module stx)
|
|
(syntax-case stx (module #%plain-module-begin)
|
|
[(module name lang (#%plain-module-begin bodies ...))
|
|
(with-syntax ([(rewritten-bodies ...)
|
|
(filter not-provide?
|
|
(syntax->list (syntax (bodies ...))))])
|
|
(syntax/loc stx
|
|
(module name lang
|
|
(#%plain-module-begin
|
|
rewritten-bodies ...))))]
|
|
[else
|
|
(raise-syntax-error 'htdp-languages "internal error .1")]))
|
|
|
|
|
|
;; not-provide? : syntax -> boolean
|
|
;; return #t for expressions that are not 'provide's
|
|
(define (not-provide? stx)
|
|
(syntax-case stx (#%provide)
|
|
[(#%provide specs ...) #f]
|
|
[else #t]))
|
|
|
|
;; stepper-skip : syntax -> syntax
|
|
;; tag the expression with stepper-skip-completely
|
|
(define (stepper-skip stx)
|
|
(stepper-syntax-property stx 'stepper-skip-completely #t))
|