462a348f19
also adjust the test-engine-test.rkt test suite to bring it into
sync with the changes to the way the DrRacket REPL works from
commit bfa6b1d953
1432 lines
65 KiB
Racket
1432 lines
65 KiB
Racket
#lang scheme/base
|
|
|
|
(require string-constants
|
|
framework
|
|
(prefix-in et: errortrace/stacktrace)
|
|
(prefix-in tr: trace/stacktrace)
|
|
mzlib/pretty
|
|
(prefix-in pc: mzlib/pconvert)
|
|
mzlib/file
|
|
mzlib/unit
|
|
mzlib/class
|
|
mzlib/list
|
|
mzlib/struct
|
|
mzlib/compile
|
|
drscheme/tool
|
|
mred
|
|
framework/private/bday
|
|
syntax/moddep
|
|
mrlib/cache-image-snip
|
|
compiler/embed
|
|
wxme/wxme
|
|
setup/dirs
|
|
|
|
lang/stepper-language-interface
|
|
lang/debugger-language-interface
|
|
lang/run-teaching-program
|
|
lang/private/continuation-mark-key
|
|
stepper/private/shared
|
|
|
|
(only-in test-engine/scheme-gui make-formatter)
|
|
test-engine/scheme-tests
|
|
(lib "test-display.scm" "test-engine")
|
|
deinprogramm/signature/signature
|
|
)
|
|
|
|
|
|
(require mzlib/pconvert-prop)
|
|
|
|
(require "convert-explicit.rkt")
|
|
|
|
(require (only-in mrlib/syntax-browser render-syntax/snip))
|
|
|
|
(provide tool@)
|
|
|
|
(define ellipses-cutoff 200)
|
|
|
|
(define o (current-output-port))
|
|
(define (oprintf . args) (apply fprintf o args))
|
|
|
|
(define user-installed-teachpacks-collection "installed-teachpacks")
|
|
(define teachpack-installation-dir (build-path (find-user-collects-dir) user-installed-teachpacks-collection))
|
|
|
|
(define generic-proc
|
|
(procedure-rename void '?))
|
|
|
|
;; adapted from collects/drracket/private/main.rkt
|
|
(preferences:set-default 'drscheme:deinprogramm:last-set-teachpacks
|
|
'()
|
|
(lambda (x)
|
|
(and (list? x)
|
|
(andmap (lambda (x)
|
|
(and (list? x)
|
|
(pair? x)
|
|
(eq? (car x) 'lib)
|
|
(andmap string? (cdr x))))
|
|
x))))
|
|
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drscheme:tool^)
|
|
(export drscheme:tool-exports^)
|
|
|
|
(define drs-eventspace (current-eventspace))
|
|
|
|
;; writing-style : {explicit, datum}
|
|
;; tracing? : boolean
|
|
;; teachpacks : (listof require-spec)
|
|
(define-struct (deinprogramm-lang-settings drscheme:language:simple-settings)
|
|
(writing-style tracing? teachpacks))
|
|
(define deinprogramm-lang-settings->vector (make-->vector deinprogramm-lang-settings))
|
|
|
|
(define image-string "<image>")
|
|
|
|
(define deinprogramm-language<%>
|
|
(interface ()
|
|
get-module
|
|
get-language-position
|
|
get-sharing-printing
|
|
get-abbreviate-cons-as-list
|
|
get-allow-sharing?
|
|
get-use-function-output-syntax?
|
|
get-accept-quasiquote?
|
|
get-read-accept-dot))
|
|
|
|
;; module-based-language-extension : (implements drscheme:language:module-based-language<%>)
|
|
;; -> (implements drscheme:language:module-based-language<%>)
|
|
;; changes the default settings and sets a few more paramters during `on-execute'
|
|
(define (module-based-language-extension printing-style writing-style super%)
|
|
(class* super% ()
|
|
|
|
(inherit get-sharing-printing get-abbreviate-cons-as-list)
|
|
|
|
(define/override (default-settings)
|
|
(make-deinprogramm-lang-settings
|
|
#f
|
|
printing-style
|
|
'repeating-decimal
|
|
(get-sharing-printing)
|
|
#t
|
|
'none
|
|
writing-style
|
|
#f
|
|
(preferences:get 'drscheme:deinprogramm:last-set-teachpacks)))
|
|
|
|
(define/override (default-settings? s)
|
|
(and (not (drscheme:language:simple-settings-case-sensitive s))
|
|
(eq? (drscheme:language:simple-settings-printing-style s)
|
|
printing-style)
|
|
(eq? (drscheme:language:simple-settings-fraction-style s)
|
|
'repeating-decimal)
|
|
(eqv? (drscheme:language:simple-settings-show-sharing s)
|
|
(get-sharing-printing))
|
|
(drscheme:language:simple-settings-insert-newlines s)
|
|
(eq? (drscheme:language:simple-settings-annotations s)
|
|
'none)
|
|
(eq? writing-style (deinprogramm-lang-settings-writing-style s))
|
|
(not (deinprogramm-lang-settings-tracing? s))
|
|
(null? (deinprogramm-lang-settings-teachpacks s))))
|
|
|
|
(define/override (marshall-settings x)
|
|
(list (super marshall-settings x)
|
|
(deinprogramm-lang-settings-writing-style x)
|
|
(deinprogramm-lang-settings-tracing? x)
|
|
(deinprogramm-lang-settings-teachpacks x)))
|
|
|
|
(define/override (unmarshall-settings x)
|
|
(if (and (list? x)
|
|
(= (length x) 4)
|
|
(symbol? (list-ref x 1)) ; ####
|
|
(boolean? (list-ref x 2))
|
|
(list-of-require-specs? (list-ref x 3)))
|
|
(let ([drs-settings (super unmarshall-settings (first x))])
|
|
(make-deinprogramm-lang-settings
|
|
(drscheme:language:simple-settings-case-sensitive drs-settings)
|
|
(drscheme:language:simple-settings-printing-style drs-settings)
|
|
(drscheme:language:simple-settings-fraction-style drs-settings)
|
|
(drscheme:language:simple-settings-show-sharing drs-settings)
|
|
(drscheme:language:simple-settings-insert-newlines drs-settings)
|
|
(drscheme:language:simple-settings-annotations drs-settings)
|
|
(cadr x)
|
|
(caddr x)
|
|
(cadddr x)))
|
|
(default-settings)))
|
|
|
|
(define/private (list-of-require-specs? l)
|
|
(and (list? l)
|
|
(andmap (lambda (x)
|
|
(and (list? x)
|
|
(andmap (lambda (x) (or (string? x) (symbol? x))) x)))
|
|
l)))
|
|
|
|
(inherit get-allow-sharing? get-use-function-output-syntax?
|
|
get-accept-quasiquote? get-read-accept-dot)
|
|
(define/override (config-panel parent)
|
|
(sharing/not-config-panel (get-allow-sharing?) (get-accept-quasiquote?) parent))
|
|
|
|
(define/override (on-execute settings run-in-user-thread)
|
|
(let ([drs-namespace (current-namespace)]
|
|
[scheme-test-module-name
|
|
((current-module-name-resolver) '(lib "test-engine/scheme-tests.rkt") #f #f)]
|
|
[scheme-signature-module-name
|
|
((current-module-name-resolver) '(lib "deinprogramm/signature/signature-german.rkt") #f #f)]
|
|
[tests-on? (preferences:get 'test-engine:enable?)])
|
|
(run-in-user-thread
|
|
(lambda ()
|
|
(when (getenv "PLTDRHTDPNOCOMPILED") (use-compiled-file-paths '()))
|
|
(read-accept-quasiquote (get-accept-quasiquote?))
|
|
(ensure-drscheme-secrets-declared drs-namespace)
|
|
(namespace-attach-module drs-namespace ''drscheme-secrets)
|
|
(error-display-handler teaching-languages-error-display-handler)
|
|
|
|
(current-eval (add-annotation (deinprogramm-lang-settings-tracing? settings) (current-eval)))
|
|
|
|
(error-print-source-location #f)
|
|
(read-decimal-as-inexact #t)
|
|
(read-accept-dot (get-read-accept-dot))
|
|
(namespace-attach-module drs-namespace scheme-test-module-name)
|
|
(namespace-require scheme-test-module-name)
|
|
|
|
(namespace-attach-module drs-namespace scheme-signature-module-name)
|
|
(namespace-require scheme-signature-module-name)
|
|
|
|
;; hack: the test-engine code knows about the test~object name; we do, too
|
|
(namespace-set-variable-value! 'test~object (build-test-engine))
|
|
;; record signature violations with the test engine
|
|
(signature-violation-proc
|
|
(lambda (obj signature message blame)
|
|
(cond
|
|
((namespace-variable-value 'test~object #f (lambda () #f))
|
|
=> (lambda (engine)
|
|
(send (send engine get-info) signature-failed
|
|
obj signature message blame))))))
|
|
(scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%))
|
|
(test-execute tests-on?)
|
|
(signature-checking-enabled? (preferences:get 'signatures:enable-checking?))
|
|
(test-format (make-formatter (lambda (v o)
|
|
(render-value/format (if (procedure? v)
|
|
generic-proc
|
|
v)
|
|
settings o 40))))
|
|
)))
|
|
(super on-execute settings run-in-user-thread)
|
|
|
|
;; DeinProgramm addition, copied from language.rkt
|
|
(run-in-user-thread
|
|
(lambda ()
|
|
(global-port-print-handler
|
|
(lambda (value port)
|
|
(let ([converted-value (simple-module-based-language-convert-value value settings)])
|
|
(setup-printing-parameters
|
|
(lambda ()
|
|
(parameterize ([pretty-print-columns 'infinity])
|
|
(pretty-print converted-value port)))
|
|
settings
|
|
'infinity)))))))
|
|
|
|
;; set-printing-parameters : settings ( -> TST) -> TST
|
|
;; is implicitly exposed to the stepper. watch out! -- john
|
|
(define/public (set-printing-parameters settings thunk)
|
|
(parameterize ([pc:booleans-as-true/false #f]
|
|
[pc:abbreviate-cons-as-list (get-abbreviate-cons-as-list)]
|
|
[pretty-print-show-inexactness #f]
|
|
[pretty-print-exact-as-decimal #f]
|
|
[pc:use-named/undefined-handler
|
|
(lambda (x)
|
|
(and (get-use-function-output-syntax?)
|
|
(procedure? x)
|
|
(object-name x)))]
|
|
[pc:named/undefined-handler
|
|
(lambda (x)
|
|
(string->symbol
|
|
(format "function:~a" (object-name x))))])
|
|
(thunk)))
|
|
|
|
(define/override (render-value/format value settings port width)
|
|
(set-printing-parameters
|
|
settings
|
|
(lambda ()
|
|
(simple-module-based-language-render-value/format value settings port width))))
|
|
|
|
(define/override (render-value value settings port)
|
|
(set-printing-parameters
|
|
settings
|
|
(lambda ()
|
|
(simple-module-based-language-render-value/format value settings port 'infinity))))
|
|
|
|
(super-new)))
|
|
|
|
;; this inspector should be powerful enough to see
|
|
;; any structure defined in the user's namespace
|
|
(define drscheme-inspector (current-inspector))
|
|
|
|
;; FIXME: brittle, mimics drscheme-secrets
|
|
;; as declared in lang/htdp-langs.rkt.
|
|
;; Is it even needed for DeinProgramm langs?
|
|
;; Only used by htdp/hangman teachpack.
|
|
(define (ensure-drscheme-secrets-declared drs-namespace)
|
|
(parameterize ((current-namespace drs-namespace))
|
|
(define (declare)
|
|
(eval `(,#'module drscheme-secrets mzscheme
|
|
(provide drscheme-inspector)
|
|
(define drscheme-inspector ,drscheme-inspector)))
|
|
(namespace-require ''drscheme-secrets))
|
|
(with-handlers ([exn:fail? (lambda (e) (declare))])
|
|
;; May have been declared by lang/htdp-langs tool, if loaded
|
|
(dynamic-require ''drscheme-secrets 'drscheme-inspector))
|
|
(void)))
|
|
|
|
|
|
;; {
|
|
;; all this copied from collects/drracket/private/language.rkt
|
|
|
|
;; stepper-convert-value : TST settings -> TST
|
|
(define (stepper-convert-value value settings)
|
|
(define ((leave-snips-alone-hook sh) expr basic-convert sub-convert)
|
|
(if (or (is-a? expr snip%)
|
|
;; FIXME: internal in language.rkt (to-snip-value? expr)
|
|
)
|
|
expr
|
|
(sh expr basic-convert sub-convert)))
|
|
;; mflatt: MINOR HACK - work around temporary
|
|
;; print-convert problems
|
|
(define (stepper-print-convert v)
|
|
(or (and (procedure? v) (object-name v))
|
|
(pc:print-convert v)))
|
|
|
|
(case (drscheme:language:simple-settings-printing-style settings)
|
|
[(write)
|
|
(let ((v (convert-explicit value)))
|
|
(or (and (procedure? v) (object-name v))
|
|
v))]
|
|
[(current-print) value]
|
|
[(constructor)
|
|
(parameterize
|
|
([pc:constructor-style-printing #t]
|
|
[pc:show-sharing
|
|
(drscheme:language:simple-settings-show-sharing settings)]
|
|
[pc:current-print-convert-hook
|
|
(leave-snips-alone-hook (pc:current-print-convert-hook))])
|
|
(stepper-print-convert value))]
|
|
[(quasiquote)
|
|
(parameterize
|
|
([pc:constructor-style-printing #f]
|
|
[pc:show-sharing
|
|
(drscheme:language:simple-settings-show-sharing settings)]
|
|
[pc:current-print-convert-hook
|
|
(leave-snips-alone-hook (pc:current-print-convert-hook))])
|
|
(stepper-print-convert value))]
|
|
[else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")]))
|
|
|
|
;; set-print-settings ; settings ( -> TST) -> TST
|
|
(define (set-print-settings language simple-settings thunk)
|
|
(if (method-in-interface? 'set-printing-parameters (object-interface language))
|
|
(send language set-printing-parameters simple-settings thunk)
|
|
;; assume that the current print-convert context is fine
|
|
;; (error 'stepper-tool "language object does not contain set-printing-parameters method")
|
|
(thunk)))
|
|
|
|
;; simple-module-based-language-render-value/format : TST settings port (union #f (snip% -> void)) (union 'infinity number) -> void
|
|
(define (simple-module-based-language-render-value/format value settings port width)
|
|
(if (eq? (drscheme:language:simple-settings-printing-style settings) 'current-print)
|
|
(parameterize ([current-output-port port])
|
|
((current-print) value))
|
|
(let ([converted-value (simple-module-based-language-convert-value value settings)])
|
|
(setup-printing-parameters
|
|
(lambda ()
|
|
(cond
|
|
[(drscheme:language:simple-settings-insert-newlines settings)
|
|
(if (number? width)
|
|
(parameterize ([pretty-print-columns width])
|
|
(pretty-print converted-value port))
|
|
(pretty-print converted-value port))]
|
|
[else
|
|
(parameterize ([pretty-print-columns 'infinity])
|
|
(pretty-print converted-value port))
|
|
(newline port)]))
|
|
settings
|
|
width))))
|
|
|
|
;; setup-printing-parameters : (-> void) -> void
|
|
(define (setup-printing-parameters thunk settings width)
|
|
(let ([use-number-snip?
|
|
(lambda (x)
|
|
(and (number? x)
|
|
(exact? x)
|
|
(real? x)
|
|
(not (integer? x))))])
|
|
(parameterize (;; these three handlers aren't used, but are set to override the user's settings
|
|
[pretty-print-print-line (lambda (line-number op old-line dest-columns)
|
|
(when (and (not (equal? line-number 0))
|
|
(not (equal? dest-columns 'infinity)))
|
|
(newline op))
|
|
0)]
|
|
[pretty-print-pre-print-hook (lambda (val port) (void))]
|
|
[pretty-print-post-print-hook (lambda (val port) (void))]
|
|
|
|
|
|
[pretty-print-columns width]
|
|
[pretty-print-size-hook
|
|
(lambda (value display? port)
|
|
(cond
|
|
[(not (port-writes-special? port)) #f]
|
|
[(is-a? value snip%) 1]
|
|
[(use-number-snip? value) 1]
|
|
[(syntax? value) 1]
|
|
[(to-snip-value? value) 1]
|
|
[else #f]))]
|
|
[pretty-print-print-hook
|
|
(lambda (value display? port)
|
|
(cond
|
|
[(is-a? value snip%)
|
|
(write-special value port)
|
|
1]
|
|
[(use-number-snip? value)
|
|
(write-special
|
|
(case (drscheme:language:simple-settings-fraction-style settings)
|
|
[(mixed-fraction)
|
|
(number-snip:make-fraction-snip value #f)]
|
|
[(mixed-fraction-e)
|
|
(number-snip:make-fraction-snip value #t)]
|
|
[(repeating-decimal)
|
|
(number-snip:make-repeating-decimal-snip value #f)]
|
|
[(repeating-decimal-e)
|
|
(number-snip:make-repeating-decimal-snip value #t)])
|
|
port)
|
|
1]
|
|
[(syntax? value)
|
|
(write-special (render-syntax/snip value) port)]
|
|
[else (write-special (value->snip value) port)]))]
|
|
[print-graph
|
|
;; only turn on print-graph when using `write' printing
|
|
;; style because the sharing is being taken care of
|
|
;; by the print-convert sexp construction when using
|
|
;; other printing styles.
|
|
(and (eq? (drscheme:language:simple-settings-printing-style settings) 'write)
|
|
(drscheme:language:simple-settings-show-sharing settings))])
|
|
(thunk))))
|
|
|
|
;; DeinProgramm changes in this procedure
|
|
;; simple-module-based-language-convert-value : TST settings -> TST
|
|
(define (simple-module-based-language-convert-value value settings)
|
|
(case (drscheme:language:simple-settings-printing-style settings)
|
|
[(write)
|
|
;; THIS IS THE CHANGE
|
|
(case (deinprogramm-lang-settings-writing-style settings)
|
|
[(explicit) (convert-explicit value)]
|
|
[(datum) value])]
|
|
[(current-print) value]
|
|
[(constructor)
|
|
(parameterize ([pc:constructor-style-printing #t]
|
|
[pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)]
|
|
[pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))])
|
|
(pc:print-convert value))]
|
|
[(quasiquote)
|
|
(parameterize ([pc:constructor-style-printing #f]
|
|
[pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)]
|
|
[pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))])
|
|
(pc:print-convert value))]))
|
|
|
|
;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable
|
|
(define ((leave-snips-alone-hook sh) expr basic-convert sub-convert)
|
|
(if (is-a? expr snip%)
|
|
expr
|
|
(sh expr basic-convert sub-convert)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; snip/value extensions
|
|
;;
|
|
|
|
(define to-snips null)
|
|
(define-struct to-snip (predicate? >value))
|
|
(define (add-snip-value predicate constructor)
|
|
(set! to-snips (cons (make-to-snip predicate constructor) to-snips)))
|
|
|
|
(define (value->snip v)
|
|
(ormap (lambda (to-snip) (and ((to-snip-predicate? to-snip) v)
|
|
((to-snip->value to-snip) v)))
|
|
to-snips))
|
|
(define (to-snip-value? v)
|
|
(ormap (lambda (to-snip) ((to-snip-predicate? to-snip) v)) to-snips))
|
|
|
|
|
|
;; }
|
|
|
|
;; sharing/not-config-panel : boolean boolean parent -> (case-> (-> settings) (settings -> void))
|
|
;; constructs the config-panel for a language without a sharing option.
|
|
(define (sharing/not-config-panel allow-sharing-config? accept-quasiquote? _parent)
|
|
(let* ([parent (make-object vertical-panel% _parent)]
|
|
|
|
[input-panel (instantiate group-box-panel% ()
|
|
(parent parent)
|
|
(label (string-constant input-syntax))
|
|
(alignment '(left center)))]
|
|
|
|
[output-panel (instantiate group-box-panel% ()
|
|
(parent parent)
|
|
(label (string-constant output-syntax))
|
|
(alignment '(left center)))]
|
|
|
|
[tp-group-box (instantiate group-box-panel% ()
|
|
(label (string-constant teachpacks))
|
|
(parent parent)
|
|
(alignment '(center top)))]
|
|
[tp-panel (new vertical-panel%
|
|
[parent tp-group-box]
|
|
[alignment '(center center)]
|
|
[stretchable-width #f]
|
|
[stretchable-height #f])]
|
|
|
|
[case-sensitive (make-object check-box%
|
|
(string-constant case-sensitive-label)
|
|
input-panel
|
|
void)]
|
|
[output-style (make-object radio-box%
|
|
(string-constant output-style-label)
|
|
(if accept-quasiquote?
|
|
(list (string-constant constructor-printing-style)
|
|
(string-constant quasiquote-printing-style)
|
|
(string-constant write-printing-style))
|
|
(list (string-constant constructor-printing-style)
|
|
(string-constant write-printing-style)))
|
|
output-panel
|
|
void)]
|
|
[writing-style (make-object radio-box%
|
|
"write-Ausgabe"
|
|
(list "explizit"
|
|
"Datum")
|
|
output-panel
|
|
void)]
|
|
[fraction-style
|
|
(make-object radio-box% (string-constant fraction-style)
|
|
(list (string-constant use-mixed-fractions)
|
|
(string-constant use-repeating-decimals))
|
|
output-panel
|
|
void)]
|
|
[show-sharing #f]
|
|
[insert-newlines (make-object check-box%
|
|
(string-constant use-pretty-printer-label)
|
|
output-panel
|
|
void)]
|
|
|
|
[tracing (new check-box%
|
|
(parent output-panel)
|
|
(label (string-constant tracing-enable-tracing))
|
|
(callback void))]
|
|
|
|
[tps '()])
|
|
|
|
(when allow-sharing-config?
|
|
(set! show-sharing
|
|
(instantiate check-box% ()
|
|
(parent output-panel)
|
|
(label (string-constant sharing-printing-label))
|
|
(callback void))))
|
|
|
|
;; set the characteristics of the GUI
|
|
(send _parent set-alignment 'center 'center)
|
|
(send parent stretchable-height #f)
|
|
(send parent stretchable-width #f)
|
|
(send parent set-alignment 'center 'center)
|
|
|
|
(case-lambda
|
|
[()
|
|
(make-deinprogramm-lang-settings
|
|
(send case-sensitive get-value)
|
|
(if accept-quasiquote?
|
|
(case (send output-style get-selection)
|
|
[(0) 'constructor]
|
|
[(1) 'quasiquote]
|
|
[(2) 'write])
|
|
(case (send output-style get-selection)
|
|
[(0) 'constructor]
|
|
[(1) 'write]))
|
|
(case (send fraction-style get-selection)
|
|
[(0) 'mixed-fraction]
|
|
[(1) 'repeating-decimal])
|
|
(and allow-sharing-config? (send show-sharing get-value))
|
|
(send insert-newlines get-value)
|
|
'none
|
|
(case (send writing-style get-selection)
|
|
[(0) 'explicit]
|
|
[(1) 'datum])
|
|
(send tracing get-value)
|
|
tps)]
|
|
[(settings)
|
|
(send case-sensitive set-value (drscheme:language:simple-settings-case-sensitive settings))
|
|
(send output-style set-selection
|
|
(if accept-quasiquote?
|
|
(case (drscheme:language:simple-settings-printing-style settings)
|
|
[(constructor) 0]
|
|
[(quasiquote) 1]
|
|
[(write) 2]
|
|
[(print) 2])
|
|
(case (drscheme:language:simple-settings-printing-style settings)
|
|
[(constructor) 0]
|
|
[(quasiquote) 0]
|
|
[(write) 1]
|
|
[(print) 1])))
|
|
(send writing-style set-selection
|
|
(case (deinprogramm-lang-settings-writing-style settings)
|
|
[(explicit) 0]
|
|
[(datum) 1]))
|
|
(send fraction-style set-selection
|
|
(case (drscheme:language:simple-settings-fraction-style settings)
|
|
[(mixed-fraction) 0]
|
|
[(repeating-decimal) 1]))
|
|
(when allow-sharing-config?
|
|
(send show-sharing set-value (drscheme:language:simple-settings-show-sharing settings)))
|
|
(send insert-newlines set-value
|
|
(drscheme:language:simple-settings-insert-newlines settings))
|
|
(set! tps (deinprogramm-lang-settings-teachpacks settings))
|
|
(send tp-panel change-children (lambda (l) '()))
|
|
(if (null? tps)
|
|
(new message%
|
|
[parent tp-panel]
|
|
[label (string-constant teachpacks-none)])
|
|
(for-each
|
|
(lambda (tp) (new message%
|
|
[parent tp-panel]
|
|
[label (format "~s" tp)]))
|
|
tps))
|
|
(send tracing set-value (deinprogramm-lang-settings-tracing? settings))
|
|
(void)])))
|
|
|
|
(define simple-deinprogramm-language%
|
|
(class* drscheme:language:simple-module-based-language% (deinprogramm-language<%>)
|
|
(init-field sharing-printing
|
|
abbreviate-cons-as-list
|
|
allow-sharing?
|
|
manual
|
|
reader-module
|
|
(use-function-output-syntax? #f)
|
|
(accept-quasiquote? #t)
|
|
(read-accept-dot #t) ;; #### should only be this in advanced mode
|
|
(style-delta #f))
|
|
(define/public (get-sharing-printing) sharing-printing)
|
|
(define/public (get-abbreviate-cons-as-list) abbreviate-cons-as-list)
|
|
(define/public (get-allow-sharing?) allow-sharing?)
|
|
(define/public (get-manual) manual)
|
|
(define/public (get-use-function-output-syntax?) use-function-output-syntax?)
|
|
(define/public (get-accept-quasiquote?) accept-quasiquote?)
|
|
(define/public (get-read-accept-dot) read-accept-dot)
|
|
;(define/override (get-one-line-summary) one-line-summary)
|
|
(define/public (get-deinprogramm-style-delta) style-delta)
|
|
|
|
(super-instantiate ()
|
|
(language-url "http://www.deinprogramm.de/dmda/"))))
|
|
|
|
(define (language-extension %)
|
|
(class %
|
|
(inherit get-manual)
|
|
|
|
(define/override (extra-repl-information settings port)
|
|
(define welcome (drscheme:rep:get-welcome-delta))
|
|
(define (go str sd)
|
|
(let* ([s (make-object string-snip% str)]
|
|
[sl (editor:get-standard-style-list)]
|
|
[std (send sl find-named-style "Standard")]
|
|
[style (send sl find-or-create-style std sd)])
|
|
(send s set-style style)
|
|
(write-special s port)))
|
|
|
|
(define tps (deinprogramm-lang-settings-teachpacks settings))
|
|
|
|
(unless (null? tps)
|
|
(go "Teachpack" welcome)
|
|
(cond
|
|
[(= 1 (length tps))
|
|
(go ": " welcome)
|
|
(go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))]
|
|
[(= 2 (length tps))
|
|
(go "s: " welcome)
|
|
(go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))
|
|
(go " und " welcome)
|
|
(go (cadr (cadr tps)) (drscheme:rep:get-dark-green-delta))]
|
|
[else
|
|
(go "s: " welcome)
|
|
(go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))
|
|
(let loop ([these-tps (cdr tps)])
|
|
(cond
|
|
[(null? (cdr these-tps))
|
|
(go " und " welcome)
|
|
(go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))]
|
|
[else
|
|
(go ", " welcome)
|
|
(go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))
|
|
(loop (cdr these-tps))]))])
|
|
(go "." welcome)
|
|
(newline port)))
|
|
|
|
(inherit get-module get-transformer-module get-init-code
|
|
use-namespace-require/copy?)
|
|
(define/override (create-executable setting parent program-filename)
|
|
(let ([dist-filename
|
|
(drscheme:language:put-executable
|
|
parent program-filename
|
|
'distribution
|
|
#t
|
|
(string-constant save-a-mred-distribution))])
|
|
(when dist-filename
|
|
(drscheme:language:create-distribution-for-executable
|
|
dist-filename
|
|
#t
|
|
(lambda (exe-name)
|
|
(create-embedding-executable
|
|
exe-name
|
|
#:modules `((#f ,program-filename))
|
|
#:cmdline `("-l"
|
|
"scheme/base"
|
|
"-e"
|
|
,(format "~s" `(#%require ',(filename->require-symbol program-filename))))
|
|
#:src-filter
|
|
(lambda (path) (cannot-compile? path))
|
|
#:get-extra-imports
|
|
(lambda (path cm)
|
|
(call-with-input-file path
|
|
(lambda (port)
|
|
(cond
|
|
[(is-wxme-stream? port)
|
|
(let-values ([(snip-class-names data-class-names)
|
|
(extract-used-classes port)])
|
|
(list*
|
|
'(lib "wxme/read.ss")
|
|
'(lib "mred/mred.ss")
|
|
reader-module
|
|
(filter
|
|
values
|
|
(map (lambda (x) (string->lib-path x #t))
|
|
(append
|
|
snip-class-names
|
|
data-class-names)))))]
|
|
[else
|
|
'()]))))
|
|
#:mred? #t))))))
|
|
|
|
(define/private (filename->require-symbol fn)
|
|
(let-values ([(base name dir) (split-path fn)])
|
|
(string->symbol
|
|
(path->string
|
|
(path-replace-suffix name #"")))))
|
|
|
|
(define/private (get-export-names sexp)
|
|
(let* ([sym-name ((current-module-name-resolver) sexp #f #f)]
|
|
[no-ext-name (substring (symbol->string sym-name)
|
|
1
|
|
(string-length (symbol->string sym-name)))]
|
|
[full-name
|
|
(cond
|
|
[(file-exists? (string-append no-ext-name ".ss"))
|
|
(string-append no-ext-name ".ss")]
|
|
[(file-exists? (string-append no-ext-name ".scm"))
|
|
(string-append no-ext-name ".scm")]
|
|
[(file-exists? no-ext-name)
|
|
no-ext-name]
|
|
[else (error 'deinprogramm-lang.rkt "could not find language filename ~s" no-ext-name)])]
|
|
[base-dir (let-values ([(base _1 _2) (split-path full-name)]) base)]
|
|
[stx
|
|
(call-with-input-file full-name
|
|
(lambda (port)
|
|
(read-syntax full-name port)))]
|
|
[code
|
|
(parameterize ([current-load-relative-directory base-dir]
|
|
[current-directory base-dir])
|
|
(expand stx))]
|
|
[find-name
|
|
(lambda (p)
|
|
(cond
|
|
[(symbol? p) p]
|
|
[(and (pair? p) (pair? (cdr p)))
|
|
(cadr p)]
|
|
[else (car p)]))])
|
|
(append
|
|
(map find-name (syntax-property code 'module-variable-provides))
|
|
(map find-name (syntax-property code 'module-syntax-provides)))))
|
|
|
|
(define/private (symbol-append x y)
|
|
(string->symbol
|
|
(string-append
|
|
(symbol->string x)
|
|
(symbol->string y))))
|
|
|
|
(inherit get-deinprogramm-style-delta)
|
|
(define/override (get-style-delta)
|
|
(get-deinprogramm-style-delta))
|
|
|
|
(inherit get-reader set-printing-parameters)
|
|
|
|
(define/override (front-end/complete-program port settings)
|
|
(expand-teaching-program port
|
|
(get-reader)
|
|
(get-module)
|
|
(deinprogramm-lang-settings-teachpacks settings)
|
|
(drscheme:rep:current-rep)
|
|
'#%deinprogramm))
|
|
|
|
(define/override (front-end/interaction port settings)
|
|
(let ([reader (get-reader)] ;; DeinProgramm addition:
|
|
;; needed for test boxes; see
|
|
;; the code in
|
|
;; collects/drracket/private/language.rkt
|
|
[start? #t]
|
|
[done? #f])
|
|
(λ ()
|
|
(cond
|
|
[start?
|
|
(set! start? #f)
|
|
#'(#%plain-app reset-tests)]
|
|
[done? eof]
|
|
[else
|
|
(let ([ans (reader (object-name port) port)])
|
|
(cond
|
|
[(eof-object? ans)
|
|
(set! done? #t)
|
|
#`(test)]
|
|
[else
|
|
ans]))]))))
|
|
|
|
(define/augment (capability-value key)
|
|
(case key
|
|
[(drscheme:teachpack-menu-items) deinprogramm-teachpack-callbacks]
|
|
[(drscheme:special:insert-lambda) #f]
|
|
[else (inner (drscheme:language:get-capability-default key)
|
|
capability-value
|
|
key)]))
|
|
|
|
(define deinprogramm-teachpack-callbacks
|
|
(drscheme:unit:make-teachpack-callbacks
|
|
(lambda (settings)
|
|
(map cadr (deinprogramm-lang-settings-teachpacks settings)))
|
|
(lambda (settings parent)
|
|
(let ([teachpack (get-teachpack-from-user parent)])
|
|
(if teachpack
|
|
(let ([old-tps (deinprogramm-lang-settings-teachpacks settings)])
|
|
(if (member teachpack old-tps)
|
|
(begin
|
|
(message-box (string-constant drscheme)
|
|
(format (string-constant already-added-teachpack)
|
|
(cadr teachpack)))
|
|
settings)
|
|
|
|
(let ([new-tps (append old-tps (list teachpack))])
|
|
(preferences:set 'drscheme:deinprogramm:last-set-teachpacks new-tps)
|
|
(make-deinprogramm-lang-settings
|
|
(drscheme:language:simple-settings-case-sensitive settings)
|
|
(drscheme:language:simple-settings-printing-style settings)
|
|
(drscheme:language:simple-settings-fraction-style settings)
|
|
(drscheme:language:simple-settings-show-sharing settings)
|
|
(drscheme:language:simple-settings-insert-newlines settings)
|
|
(drscheme:language:simple-settings-annotations settings)
|
|
(deinprogramm-lang-settings-writing-style settings)
|
|
(deinprogramm-lang-settings-tracing? settings)
|
|
new-tps))))
|
|
settings)))
|
|
(lambda (settings name)
|
|
(let ([new-tps (filter (lambda (x) (not (equal? (cadr x) name)))
|
|
(deinprogramm-lang-settings-teachpacks settings))])
|
|
(preferences:set 'drscheme:deinprogramm:last-set-teachpacks new-tps)
|
|
(make-deinprogramm-lang-settings
|
|
(drscheme:language:simple-settings-case-sensitive settings)
|
|
(drscheme:language:simple-settings-printing-style settings)
|
|
(drscheme:language:simple-settings-fraction-style settings)
|
|
(drscheme:language:simple-settings-show-sharing settings)
|
|
(drscheme:language:simple-settings-insert-newlines settings)
|
|
(drscheme:language:simple-settings-annotations settings)
|
|
(deinprogramm-lang-settings-writing-style settings)
|
|
(deinprogramm-lang-settings-tracing? settings)
|
|
new-tps)))
|
|
(lambda (settings)
|
|
(preferences:set 'drscheme:deinprogramm:last-set-teachpacks '())
|
|
(make-deinprogramm-lang-settings
|
|
(drscheme:language:simple-settings-case-sensitive settings)
|
|
(drscheme:language:simple-settings-printing-style settings)
|
|
(drscheme:language:simple-settings-fraction-style settings)
|
|
(drscheme:language:simple-settings-show-sharing settings)
|
|
(drscheme:language:simple-settings-insert-newlines settings)
|
|
(drscheme:language:simple-settings-annotations settings)
|
|
(deinprogramm-lang-settings-writing-style settings)
|
|
(deinprogramm-lang-settings-tracing? settings)
|
|
'()))))
|
|
|
|
(inherit-field reader-module)
|
|
(define/override (get-reader-module) reader-module)
|
|
(define/override (get-metadata modname settings)
|
|
(string-append
|
|
";; Die ersten drei Zeilen dieser Datei wurden von DrRacket eingefügt. Sie enthalten Metadaten\n"
|
|
";; über die Sprachebene dieser Datei in einer Form, die DrRacket verarbeiten kann.\n"
|
|
(format "#reader~s~s\n"
|
|
reader-module
|
|
`((modname ,modname)
|
|
(read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings))
|
|
(teachpacks ,(deinprogramm-lang-settings-teachpacks settings))
|
|
(deinprogramm-settings ,(deinprogramm-lang-settings->vector settings))))))
|
|
|
|
(inherit default-settings)
|
|
(define/override (metadata->settings metadata)
|
|
(let* ([table (metadata->table metadata)] ;; extract the table
|
|
[ssv (assoc 'deinprogramm-settings table)])
|
|
(if ssv
|
|
(let ([settings-list (vector->list (cadr ssv))])
|
|
(if (equal? (length settings-list)
|
|
(procedure-arity make-deinprogramm-lang-settings))
|
|
(apply make-deinprogramm-lang-settings settings-list)
|
|
(default-settings)))
|
|
(default-settings))))
|
|
|
|
(define/private (metadata->table metadata)
|
|
(let ([p (open-input-string metadata)])
|
|
(regexp-match #rx"\n#reader" p) ;; skip to reader
|
|
(read p) ;; skip module
|
|
(read p)))
|
|
|
|
(define/override (get-metadata-lines) 3)
|
|
|
|
(super-new)))
|
|
|
|
;; cannot-compile? : path -> boolean
|
|
;; returns #t if the file cannot be compiled, #f otherwise
|
|
(define (cannot-compile? path)
|
|
(call-with-input-file path
|
|
(lambda (port)
|
|
(let ([ok-to-compile-names
|
|
(map (lambda (x) (format "~s" x))
|
|
'(wxtext
|
|
(lib "comment-snip.ss" "framework")
|
|
(lib "xml-snipclass.ss" "xml")
|
|
(lib "scheme-snipclass.ss" "xml")
|
|
(lib "test-case-box-snipclass.ss" "test-suite")))])
|
|
(and (is-wxme-stream? port)
|
|
(let-values ([(snip-class-names data-class-names)
|
|
(extract-used-classes port)])
|
|
(not (and (andmap
|
|
(lambda (used-name) (member used-name ok-to-compile-names))
|
|
snip-class-names)
|
|
(andmap
|
|
(lambda (used-name) (member used-name ok-to-compile-names))
|
|
data-class-names)))))))))
|
|
|
|
(define (get-teachpack-from-user parent)
|
|
(define tp-dir (collection-path "teachpack" "deinprogramm"))
|
|
(define columns 2)
|
|
(define tps (filter
|
|
(lambda (x) (file-exists? (build-path tp-dir x)))
|
|
(directory-list tp-dir)))
|
|
(define sort-order (lambda (x y) (string<=? (path->string x) (path->string y))))
|
|
(define pre-installed-tps (sort tps sort-order))
|
|
(define dlg (new dialog% [parent parent] [label (string-constant drscheme)]))
|
|
(define hp (new horizontal-panel% [parent dlg]))
|
|
(define answer #f)
|
|
(define compiling? #f)
|
|
|
|
(define pre-installed-gb (new group-box-panel%
|
|
[label (string-constant teachpack-pre-installed)]
|
|
[parent hp]))
|
|
(define user-installed-gb (new group-box-panel%
|
|
[label (string-constant teachpack-user-installed)]
|
|
[parent hp]))
|
|
|
|
(define pre-installed-lb
|
|
(new list-box%
|
|
[label #f]
|
|
[choices (map path->string pre-installed-tps)]
|
|
[stretchable-height #t]
|
|
[min-height 300]
|
|
[min-width 200]
|
|
[callback
|
|
(lambda (x evt)
|
|
(case (send evt get-event-type)
|
|
[(list-box-dclick) (selected pre-installed-lb)]
|
|
[else
|
|
(clear-selection user-installed-lb)
|
|
(update-button)]))]
|
|
[parent pre-installed-gb]))
|
|
|
|
(define user-installed-lb
|
|
(new list-box%
|
|
[label #f]
|
|
[choices '()]
|
|
[stretchable-height #t]
|
|
[min-width 200]
|
|
[callback
|
|
(lambda (x evt)
|
|
(case (send evt get-event-type)
|
|
[(list-box-dclick) (selected user-installed-lb)]
|
|
[else
|
|
(clear-selection pre-installed-lb)
|
|
(update-button)]))]
|
|
[parent user-installed-gb]))
|
|
|
|
(define (selected lb)
|
|
(unless compiling?
|
|
(set! answer (figure-out-answer))
|
|
(send dlg show #f)))
|
|
|
|
(define (clear-selection lb)
|
|
(for-each
|
|
(lambda (x) (send lb select x #f))
|
|
(send lb get-selections)))
|
|
|
|
(define add-button (new button%
|
|
[parent user-installed-gb]
|
|
[label (string-constant add-teachpack-to-list...)]
|
|
[callback (lambda (x y) (install-teachpack))]))
|
|
|
|
(define (install-teachpack)
|
|
(let ([file (get-file (string-constant select-a-teachpack) dlg)])
|
|
(when file
|
|
(let-values ([(base name dir) (split-path file)])
|
|
(let ([dest-file (build-path teachpack-installation-dir name)])
|
|
(when (or (not (file-exists? dest-file))
|
|
(equal? 1
|
|
(message-box/custom
|
|
(string-constant drscheme)
|
|
(format
|
|
(string-constant teachpack-already-installed)
|
|
(path->string name))
|
|
(string-constant overwrite)
|
|
(string-constant cancel)
|
|
#f
|
|
dlg
|
|
'(default=2 caution))))
|
|
(make-directory* teachpack-installation-dir)
|
|
(when (file-exists? dest-file)
|
|
(delete-file dest-file))
|
|
(copy-file file dest-file)
|
|
|
|
;; compiling the teachpack should be the last thing in this GUI callback
|
|
(compile-new-teachpack dest-file)))))))
|
|
|
|
(define (compile-new-teachpack filename)
|
|
(let-values ([(_1 short-name _2) (split-path filename)])
|
|
(cond
|
|
[(cannot-compile? filename)
|
|
(post-compilation-gui-cleanup short-name)]
|
|
[else
|
|
(send compiling-message set-label
|
|
(format (string-constant compiling-teachpack)
|
|
(path->string short-name)))
|
|
(starting-compilation)
|
|
(let ([nc (make-custodian)]
|
|
[exn #f])
|
|
(let ([t
|
|
(parameterize ([current-custodian nc])
|
|
(thread (lambda ()
|
|
(with-handlers ((exn? (lambda (x) (set! exn x))))
|
|
(parameterize ([current-namespace (make-base-namespace)])
|
|
(with-module-reading-parameterization
|
|
(lambda ()
|
|
(compile-file filename))))))))])
|
|
(thread
|
|
(lambda ()
|
|
(thread-wait t)
|
|
(queue-callback
|
|
(lambda ()
|
|
(cond
|
|
[exn
|
|
(message-box (string-constant drscheme)
|
|
(exn-message exn))
|
|
(delete-file filename)
|
|
(update-user-installed-lb)]
|
|
[else
|
|
(post-compilation-gui-cleanup short-name)])
|
|
(done-compilation)
|
|
(send compiling-message set-label "")))))))])))
|
|
|
|
(define (post-compilation-gui-cleanup short-name)
|
|
(update-user-installed-lb)
|
|
(clear-selection pre-installed-lb)
|
|
(send user-installed-lb set-string-selection (path->string short-name)))
|
|
|
|
(define (starting-compilation)
|
|
(set! compiling? #t)
|
|
(update-button)
|
|
(send cancel-button enable #f))
|
|
|
|
(define (done-compilation)
|
|
(set! compiling? #f)
|
|
(update-button)
|
|
(send cancel-button enable #t))
|
|
|
|
(define (update-user-installed-lb)
|
|
(let ([files
|
|
(if (directory-exists? teachpack-installation-dir)
|
|
(map path->string
|
|
(filter
|
|
(lambda (x) (file-exists? (build-path teachpack-installation-dir x)))
|
|
(directory-list teachpack-installation-dir)))
|
|
'())])
|
|
(send user-installed-lb set (sort files string<=?))))
|
|
|
|
|
|
(define (update-button)
|
|
(send ok-button enable
|
|
(and (not compiling?)
|
|
(or (pair? (send user-installed-lb get-selections))
|
|
(pair? (send pre-installed-lb get-selections))))))
|
|
|
|
(define button-panel (new horizontal-panel%
|
|
[parent dlg]
|
|
[alignment '(right center)]
|
|
[stretchable-height #f]))
|
|
(define compiling-message (new message% [parent button-panel] [label ""] [stretchable-width #t]))
|
|
(define-values (ok-button cancel-button)
|
|
(gui-utils:ok/cancel-buttons button-panel
|
|
(lambda (b e)
|
|
(set! answer (figure-out-answer))
|
|
(send dlg show #f))
|
|
(lambda (b e)
|
|
(send dlg show #f))
|
|
(string-constant ok) (string-constant cancel)))
|
|
|
|
(define (figure-out-answer)
|
|
(cond
|
|
[(send pre-installed-lb get-selection)
|
|
=>
|
|
(lambda (i) `(lib ,(send pre-installed-lb get-string i)
|
|
"teachpack"
|
|
"deinprogramm"))]
|
|
[(send user-installed-lb get-selection)
|
|
=>
|
|
(lambda (i) `(lib ,(send user-installed-lb get-string i)
|
|
,user-installed-teachpacks-collection))]
|
|
[else (error 'figure-out-answer "no selection!")]))
|
|
|
|
|
|
(send ok-button enable #f)
|
|
(update-user-installed-lb)
|
|
|
|
(send dlg show #t)
|
|
answer)
|
|
|
|
(define (stepper-settings-language %)
|
|
(if (implementation? % stepper-language<%>)
|
|
(class* % (stepper-language<%>)
|
|
(init-field stepper:supported)
|
|
(define/override (stepper:supported?) stepper:supported)
|
|
(define/override (stepper:show-inexactness?) #f)
|
|
(define/override (stepper:show-consumed-and/or-clauses?) #f)
|
|
(define/override (stepper:render-to-sexp val settings language-level)
|
|
(parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)])
|
|
(set-print-settings
|
|
language-level
|
|
settings
|
|
(lambda ()
|
|
(stepper-convert-value val settings)))))
|
|
(super-new))
|
|
(class %
|
|
(init stepper:supported)
|
|
(super-new))))
|
|
|
|
(define (debugger-settings-language %)
|
|
(if (implementation? % debugger-language<%>)
|
|
(class* % (debugger-language<%>)
|
|
(init-field [debugger:supported #f])
|
|
(define/override (debugger:supported?) debugger:supported)
|
|
(super-new))
|
|
(class %
|
|
(init [debugger:supported #f])
|
|
(super-new))))
|
|
|
|
;; make-print-convert-hook:
|
|
;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST)
|
|
;; this code copied from various locations in language.rkt and rep.rkt
|
|
(define (make-print-convert-hook simple-settings)
|
|
(lambda (exp basic-convert sub-convert)
|
|
(cond
|
|
[(is-a? exp snip%)
|
|
(send exp copy)]
|
|
[else (basic-convert exp)])))
|
|
|
|
;; filter/hide-ids : syntax[list] -> listof syntax
|
|
(define (filter/hide-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)))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;
|
|
; ;;; ; ; ; ; ;;; ; ; ;;;; ; ; ;;; ;;; ;;;
|
|
; ; ; ;; ;; ; ; ;; ; ;; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;;; ; ; ;;; ; ;; ; ;;;;; ;;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(define mf-note
|
|
(let ([bitmap
|
|
(make-object bitmap%
|
|
(build-path (collection-path "icons") "mf.gif"))])
|
|
(and (send bitmap ok?)
|
|
(make-object image-snip% bitmap))))
|
|
|
|
;; teaching-languages-error-display-handler :
|
|
;; (string (union TST exn) -> void) -> string exn -> void
|
|
;; adds in the bug icon, if there are contexts to display
|
|
(define (teaching-languages-error-display-handler msg exn)
|
|
|
|
(if (exn? exn)
|
|
(display (exn-message exn) (current-error-port))
|
|
(fprintf (current-error-port) "uncaught exception: ~e" exn))
|
|
(fprintf (current-error-port) "\n")
|
|
|
|
;; need to flush here so that error annotations inserted in next line
|
|
;; don't get erased if this output were to happen after the insertion
|
|
(flush-output (current-error-port))
|
|
|
|
(let ([rep (drscheme:rep:current-rep)])
|
|
(when (and (is-a? rep drscheme:rep:text<%>)
|
|
(eq? (send rep get-err-port) (current-error-port)))
|
|
(let ([to-highlight
|
|
(cond
|
|
[(exn:srclocs? exn)
|
|
((exn:srclocs-accessor exn) exn)]
|
|
[(exn? exn)
|
|
(let ([cms (continuation-mark-set->list (exn-continuation-marks exn) teaching-languages-continuation-mark-key)])
|
|
(cond
|
|
((not cms) '())
|
|
((findf (lambda (mark)
|
|
(and mark
|
|
(or (path? (car mark))
|
|
(symbol? (car mark)))))
|
|
cms)
|
|
=> (lambda (mark)
|
|
(apply (lambda (source line col pos span)
|
|
(list (make-srcloc source line col pos span)))
|
|
mark)))
|
|
(else '())))]
|
|
[else '()])])
|
|
|
|
(parameterize ([current-eventspace drs-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
;; need to make sure that the user's eventspace is still the same
|
|
;; and still running here?
|
|
(send rep highlight-errors to-highlight #f))))))))
|
|
|
|
;; with-mark : syntax syntax exact-nonnegative-integer -> syntax
|
|
;; a member of stacktrace-imports^
|
|
;; guarantees that the continuation marks associated with teaching-languages-continuation-mark-key are
|
|
;; members of the debug-source type
|
|
(define (with-mark source-stx expr phase)
|
|
(let ([source (syntax-source source-stx)]
|
|
[line (syntax-line source-stx)]
|
|
[col (syntax-column source-stx)]
|
|
[start-position (syntax-position source-stx)]
|
|
[span (syntax-span source-stx)])
|
|
(if (and (or (symbol? source) (path? source))
|
|
(number? start-position)
|
|
(number? span))
|
|
(with-syntax ([expr expr]
|
|
[mark (list source line col start-position span)]
|
|
[teaching-languages-continuation-mark-key teaching-languages-continuation-mark-key])
|
|
#`(with-continuation-mark 'teaching-languages-continuation-mark-key
|
|
'mark
|
|
expr))
|
|
expr)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; profiling infrastructure. Not used.
|
|
;;
|
|
|
|
(define profile-key (gensym))
|
|
(define (profiling-enabled) #f)
|
|
(define (initialize-profile-point . x) (void))
|
|
(define (register-profile-start . x) #f)
|
|
(define (register-profile-done . x) (void))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; test coverage
|
|
;;
|
|
|
|
;; WARNING: much code copied from "collects/lang/htdp-langs.rkt"
|
|
|
|
(define test-coverage-enabled (make-parameter #t))
|
|
(define current-test-coverage-info (make-thread-cell #f))
|
|
|
|
(define (initialize-test-coverage-point expr)
|
|
(unless (thread-cell-ref current-test-coverage-info)
|
|
(let ([ht (make-hasheq)])
|
|
(thread-cell-set! current-test-coverage-info ht)
|
|
(let ([rep (drscheme:rep:current-rep)])
|
|
(when rep
|
|
(parameterize ([current-eventspace drs-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(let ([on-sd (make-object style-delta%)]
|
|
[off-sd (make-object style-delta%)])
|
|
(cond
|
|
[(preferences:get 'framework:white-on-black?)
|
|
(send on-sd set-delta-foreground "white")
|
|
(send off-sd set-delta-background "lightblue")
|
|
(send off-sd set-delta-foreground "black")]
|
|
[else
|
|
(send on-sd set-delta-foreground "black")
|
|
(send off-sd set-delta-background "lightblue")
|
|
(send off-sd set-delta-foreground "black")])
|
|
(send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
|
|
(let ([ht (thread-cell-ref current-test-coverage-info)])
|
|
(when ht
|
|
(hash-set! ht expr #;(box #f) (mcons #f #f)))))
|
|
|
|
(define (test-covered expr)
|
|
(let* ([ht (or (thread-cell-ref current-test-coverage-info)
|
|
(error 'deinprogramm-langs
|
|
"internal-error: no test-coverage table"))]
|
|
[v (hash-ref ht expr
|
|
(lambda ()
|
|
(error 'deinprogramm-langs
|
|
"internal-error: expression not found: ~.s"
|
|
expr)))])
|
|
#; (lambda () (set-box! v #t))
|
|
(with-syntax ([v v]) #'(#%plain-app set-mcar! v #t))))
|
|
|
|
(define-values/invoke-unit et:stacktrace@
|
|
(import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))
|
|
|
|
;; add-annotation : boolean (sexp -> value) -> sexp -> value
|
|
;; adds debugging and test coverage information to `sexp' and calls `oe'
|
|
(define (add-annotation tracing? oe)
|
|
(let ([teaching-language-eval-handler
|
|
(lambda (exp)
|
|
(let* ([is-compiled? (compiled-expression? (if (syntax? exp) (syntax-e exp) exp))]
|
|
[annotated
|
|
(if is-compiled?
|
|
exp
|
|
(let* ([et-annotated (et:annotate-top (expand exp)
|
|
(namespace-base-phase))]
|
|
[tr-annotated
|
|
(if tracing?
|
|
(drscheme:tracing:annotate (expand et-annotated))
|
|
et-annotated)])
|
|
tr-annotated))])
|
|
(oe annotated)))])
|
|
teaching-language-eval-handler))
|
|
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ; ;
|
|
; ; ; ;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ;; ; ; ;;;; ; ;;;; ;;; ; ; ;;;; ;;; ;; ; ;;; ;;;; ; ;; ;;; ; ;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;;;; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;
|
|
; ; ;; ;; ; ;; ; ;; ;;;;; ; ; ;; ;;; ;; ; ;;;; ;; ; ; ;;;; ;
|
|
; ; ;
|
|
; ; ; ;
|
|
; ; ;;;;
|
|
|
|
|
|
;; add-deinprogramm-language : (instanceof deinprogramm-language<%>) -> void
|
|
(define (add-deinprogramm-language o)
|
|
(drscheme:language-configuration:add-language o))
|
|
|
|
(define (phase1) (void))
|
|
|
|
;; phase2 : -> void
|
|
(define (phase2)
|
|
(define (make-deinprogramm-language% printing-style writing-style)
|
|
(debugger-settings-language
|
|
(stepper-settings-language
|
|
((drscheme:language:get-default-mixin)
|
|
(language-extension
|
|
(drscheme:language:module-based-language->language-mixin
|
|
(module-based-language-extension
|
|
printing-style writing-style
|
|
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
|
simple-deinprogramm-language%))))))))
|
|
|
|
(add-deinprogramm-language
|
|
(instantiate (make-deinprogramm-language% 'write 'explicit) ()
|
|
(one-line-summary "Die Macht der Abstraktion - Anfänger")
|
|
(module '(lib "deinprogramm/DMdA-beginner.rkt"))
|
|
(manual #"DMdA-beginner")
|
|
(language-position (list (string-constant teaching-languages)
|
|
"DeinProgramm" "Die Macht der Abstraktion - Anfänger"))
|
|
(language-id "DMdA:beginner")
|
|
(language-numbers '(-500 -300 3))
|
|
(sharing-printing #f)
|
|
(abbreviate-cons-as-list #t)
|
|
(allow-sharing? #f)
|
|
(reader-module '(lib "DMdA-beginner-reader.ss" "deinprogramm"))
|
|
(stepper:supported #t)))
|
|
|
|
(add-deinprogramm-language
|
|
(instantiate (make-deinprogramm-language% 'write 'explicit) ()
|
|
(one-line-summary "Die Macht der Abstraktion")
|
|
(module '(lib "deinprogramm/DMdA-vanilla.rkt"))
|
|
(manual #"DMdA-vanilla")
|
|
(language-position (list (string-constant teaching-languages)
|
|
"DeinProgramm" "Die Macht der Abstraktion"))
|
|
(language-id "DMdA:vanilla")
|
|
(language-numbers '(-500 -300 4))
|
|
(sharing-printing #f)
|
|
(abbreviate-cons-as-list #t)
|
|
(allow-sharing? #f)
|
|
(reader-module '(lib "DMdA-vanilla-reader.ss" "deinprogramm"))
|
|
(stepper:supported #t)))
|
|
|
|
(add-deinprogramm-language
|
|
(instantiate (make-deinprogramm-language% 'write 'explicit) ()
|
|
(one-line-summary "Die Macht der Abstraktion mit Zuweisungen")
|
|
(module '(lib "deinprogramm/DMdA-assignments.rkt"))
|
|
(manual #"DMdA-assignments")
|
|
(language-position (list (string-constant teaching-languages)
|
|
"DeinProgramm" "Die Macht der Abstraktion mit Zuweisungen"))
|
|
(language-id "DMdA:assignments")
|
|
(language-numbers '(-500 -300 5))
|
|
(sharing-printing #t)
|
|
(abbreviate-cons-as-list #t)
|
|
(allow-sharing? #t)
|
|
(reader-module '(lib "DMdA-assignments-reader.ss" "deinprogramm"))
|
|
(stepper:supported #f)
|
|
(debugger:supported #t)))
|
|
|
|
(add-deinprogramm-language
|
|
(instantiate (make-deinprogramm-language% 'write 'datum) ()
|
|
(one-line-summary "Die Macht der Abstraktion - fortgeschritten")
|
|
(module '(lib "deinprogramm/DMdA-advanced.rkt"))
|
|
(manual #"DMdA-advanced")
|
|
(language-position (list (string-constant teaching-languages)
|
|
"DeinProgramm" "Die Macht der Abstraktion - fortgeschritten"))
|
|
(language-id "DMdA:advanced")
|
|
(language-numbers '(-500 -300 6))
|
|
(sharing-printing #t)
|
|
(abbreviate-cons-as-list #t)
|
|
(allow-sharing? #t)
|
|
(reader-module '(lib "DMdA-advanced-reader.ss" "deinprogramm"))
|
|
(stepper:supported #f)
|
|
(debugger:supported #t))))))
|