#lang scheme (require string-constants framework (prefix-in et: errortrace/stacktrace) mzlib/pretty (prefix-in pc: mzlib/pconvert) mzlib/file mzlib/unit mzlib/class mzlib/list mzlib/struct mzlib/compile mzlib/struct drscheme/tool mred framework/private/bday syntax/moddep mrlib/cache-image-snip (prefix-in ic: mrlib/image-core) setup/dirs test-engine/racket-tests ;; this module is shared between the drscheme's namespace (so loaded here) ;; and the user's namespace in the teaching languages "private/set-result.rkt" "private/rewrite-error-message.rkt" "private/continuation-mark-key.rkt" "private/create-htdp-executable.rkt" "stepper-language-interface.rkt" "debugger-language-interface.rkt" "run-teaching-program.rkt" "htdp-langs-save-file-prefix.rkt" (only-in test-engine/scheme-gui make-formatter) (only-in test-engine/racket-tests scheme-test-data error-handler test-format test-execute display-results build-test-engine) (lib "test-engine/test-display.scm") deinprogramm/signature/signature ) (provide tool@) (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 tool@ (unit (import drscheme:tool^) (export drscheme:tool-exports^) (define drs-eventspace (current-eventspace)) ;; tracing? : boolean ;; teachpacks : (listof require-spec) (define-struct (htdp-lang-settings drscheme:language:simple-settings) (tracing? teachpacks)) (define htdp-lang-settings->vector (make-->vector htdp-lang-settings)) (define image-string "") (define htdp-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 super%) (class* super% () (inherit get-sharing-printing get-abbreviate-cons-as-list) (define/override (default-settings) (make-htdp-lang-settings #t 'constructor 'repeating-decimal (get-sharing-printing) #t 'none #f (preferences:get 'drracket:htdp:last-set-teachpacks))) (define/override (default-settings? s) (and (super default-settings? s) (not (htdp-lang-settings-tracing? s)) (null? (htdp-lang-settings-teachpacks s)))) (define/override (marshall-settings x) (list (super marshall-settings x) (htdp-lang-settings-tracing? x) (htdp-lang-settings-teachpacks x))) (define/override (unmarshall-settings x) (if (and (list? x) (= (length x) 3) (boolean? (list-ref x 1)) (list-of-require-specs? (list-ref x 2))) (let ([drs-settings (super unmarshall-settings (first x))]) (make-htdp-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))) (default-settings))) (define/private (list-of-require-specs? l) (and (list? l) (andmap (λ (x) (and (list? x) (andmap (λ (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)] [set-result-module-name ((current-module-name-resolver) '(lib "lang/private/set-result.ss") #f #f)] [scheme-test-module-name ((current-module-name-resolver) '(lib "test-engine/racket-tests.ss") #f #f)] [scheme-signature-module-name ((current-module-name-resolver) '(lib "deinprogramm/signature/signature-english.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?)) (namespace-attach-module drs-namespace ''drscheme-secrets) (namespace-attach-module drs-namespace set-result-module-name) (error-display-handler teaching-languages-error-display-handler) (error-value->string-handler (λ (x y) (teaching-languages-error-value->string settings x y))) (current-eval (add-annotation (htdp-lang-settings-tracing? settings) (current-eval))) (error-print-source-location #f) (read-decimal-as-inexact #f) (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? (get-preference 'signatures:enable-checking? (lambda () #t))) (test-format (make-formatter (lambda (v o) (render-value/format v settings o 40))))))) (super on-execute settings run-in-user-thread) ;; set the global-port-print-handler after the super class because the super sets it too (run-in-user-thread (lambda () (define my-setup-printing-parameters (drscheme:language:make-setup-printing-parameters)) (global-port-print-handler (λ (value port [depth 0]) (teaching-language-render-value/format my-setup-printing-parameters value settings port 'infinity)))))) (define/private (teaching-languages-error-value->string settings v len) (let ([sp (open-output-string)]) (set-printing-parameters settings (λ () (print v sp))) (flush-output sp) (let ([s (get-output-string sp)]) (cond [(<= (string-length s) len) s] [else (string-append (substring s 0 (- len 3)) "...")])))) ;; set-printing-parameters : settings ( -> TST) -> TST ;; is implicitly exposed to the stepper. watch out! -- john (define/public (set-printing-parameters settings thunk) (define img-str "#") (define (is-image? val) (or (is-a? val ic:image%) ;; 2htdp/image (is-a? val cache-image-snip%) ;; htdp/image (is-a? val image-snip%) ;; literal image constant (is-a? val bitmap%))) ;; works in other places, so include it here too (parameterize ([pc:booleans-as-true/false #t] [pc:add-make-prefix-to-constructor #t] [pc:abbreviate-cons-as-list (get-abbreviate-cons-as-list)] [pc:current-print-convert-hook (let ([ph (pc:current-print-convert-hook)]) (lambda (val basic sub) (cond [(equal? val set!-result) '(void)] [else (ph val basic sub)])))] [pretty-print-show-inexactness #t] [pretty-print-exact-as-decimal #t] [pretty-print-print-hook (let ([oh (pretty-print-print-hook)]) (λ (val display? port) (if (and (not (port-writes-special? port)) (is-image? val)) (begin (display img-str port) (string-length img-str)) (oh val display? port))))] [pretty-print-size-hook (let ([oh (pretty-print-size-hook)]) (λ (val display? port) (if (and (not (port-writes-special? port)) (is-image? val)) (string-length img-str) (oh val display? port))))] [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) (teaching-language-render-value/format drscheme:language:setup-printing-parameters value settings port width)) (define/override (render-value value settings port) (teaching-language-render-value/format drscheme:language:setup-printing-parameters value settings port 'infinity)) (define/private (teaching-language-render-value/format setup-printing-parameters value settings port width) ;; set drscheme's printing parameters (setup-printing-parameters (λ () ;; then adjust the settings for the teaching languages (set-printing-parameters settings (λ () (let-values ([(converted-value write?) (call-with-values (lambda () (drscheme:language:simple-module-based-language-convert-value value settings)) (case-lambda [(converted-value) (values converted-value #t)] [(converted-value write?) (values converted-value write?)]))]) (let ([pretty-out (if write? pretty-write pretty-print)]) (cond [(drscheme:language:simple-settings-insert-newlines settings) (if (number? width) (parameterize ([pretty-print-columns width]) (pretty-out converted-value port)) (pretty-out converted-value port))] [else (parameterize ([pretty-print-columns 'infinity]) (pretty-out converted-value port)) (newline port)])))))) settings width)) (super-new))) ;; 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)] [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))] [fraction-style (make-object radio-box% (string-constant fraction-style) (list (string-constant use-mixed-fractions) (string-constant use-repeating-decimals)) output-panel 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-htdp-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 (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] [(print trad-write write) 2]) (case (drscheme:language:simple-settings-printing-style settings) [(constructor) 0] [(quasiquote) 0] [(print trad-write write) 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 (htdp-lang-settings-teachpacks settings)) (send tp-panel change-children (λ (l) '())) (if (null? tps) (new message% [parent tp-panel] [label (string-constant teachpacks-none)]) (for-each (λ (tp) (new message% [parent tp-panel] [label (format "~s" tp)])) tps)) (send tracing set-value (htdp-lang-settings-tracing? settings)) (void)]))) (define simple-htdp-language% (class* drscheme:language:simple-module-based-language% (htdp-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 #f) (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-htdp-style-delta) style-delta) (super-new [language-url "http://www.htdp.org/"]))) (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 (htdp-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 " and " 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 ", and " 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))) (define/override (first-opened settings) (for ([tp (in-list (htdp-lang-settings-teachpacks settings))]) (namespace-require/constant tp))) (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 (λ (exe-name) (create-htdp-lang-executable program-filename exe-name reader-module)))))) (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 'htdp-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-htdp-style-delta) (define/override (get-style-delta) (get-htdp-style-delta)) (inherit get-reader set-printing-parameters) (define/override (front-end/complete-program port settings) (expand-teaching-program port (get-reader) (get-module) (htdp-lang-settings-teachpacks settings))) (define/override (front-end/interaction port settings) (let ([t (super front-end/interaction port settings)] [start? #t] [done? #f]) (λ () (cond [start? (set! start? #f) #'(#%plain-app reset-tests)] [done? eof] [else (let ([ans (parameterize ([read-accept-lang #f]) (t))]) (cond [(eof-object? ans) (set! done? #t) #`(test)] [else ans]))])))) (define keywords #f) (define/augment (capability-value key) (case key [(drscheme:autocomplete-words) (unless keywords (set! keywords (text:get-completions/manuals #f))) ;; complete with everything, which is wrong .. keywords] [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] [(drscheme:special:insert-lambda) #f] [(drscheme:help-context-term) (let* ([m (get-module)] [m (and m (pair? m) (pair? (cdr m)) (cadr m))] [m (and m (regexp-match #rx"^(lang/[^/.]+).ss$" m))] [m (and m (cadr m))]) (if m (format "O:{ L:~a T:teachpack T:picturing-programs }" m) (error 'drscheme:help-context-term "internal error: unexpected module spec")))] [(tests:test-menu tests:dock-menu) #t] [else (inner (drscheme:language:get-capability-default key) capability-value key)])) (define htdp-teachpack-callbacks (drscheme:unit:make-teachpack-callbacks (λ (settings) (map cadr (htdp-lang-settings-teachpacks settings))) (λ (settings parent) (let ([teachpack (get-teachpack-from-user parent)]) (if teachpack (let ([old-tps (htdp-lang-settings-teachpacks settings)]) (if (member teachpack old-tps) (begin (message-box (string-constant drscheme) (format (string-constant already-added-teachpack) (cadr teachpack)) #:dialog-mixin frame:focus-table-mixin) settings) (let ([new-tps (append old-tps (list teachpack))]) (preferences:set 'drracket:htdp:last-set-teachpacks new-tps) (make-htdp-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) (htdp-lang-settings-tracing? settings) new-tps)))) settings))) (λ (settings name) (let ([new-tps (filter (λ (x) (not (equal? (cadr x) name))) (htdp-lang-settings-teachpacks settings))]) (preferences:set 'drracket:htdp:last-set-teachpacks new-tps) (make-htdp-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) (htdp-lang-settings-tracing? settings) new-tps))) (λ (settings) (preferences:set 'drracket:htdp:last-set-teachpacks '()) (make-htdp-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) (htdp-lang-settings-tracing? settings) '())))) (inherit-field reader-module) (define/override (get-reader-module) reader-module) (define/override (get-metadata modname settings) (string-append (apply string-append (map (λ (x) (string-append x "\n")) htdp-save-file-prefix)) (format "#reader~s~s\n" reader-module `((modname ,modname) (read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings)) (teachpacks ,(htdp-lang-settings-teachpacks settings)) (htdp-settings ,(htdp-lang-settings->vector settings)))))) (inherit default-settings) (define/override (metadata->settings metadata) (let* ([table (massage-metadata (metadata->table metadata))] ;; extract the table [ssv (assoc 'htdp-settings table)]) (if ssv (let ([settings-list (vector->list (cadr ssv))]) (if (equal? (length settings-list) (procedure-arity make-htdp-lang-settings)) (apply make-htdp-lang-settings settings-list) (default-settings))) (default-settings)))) (define/private (massage-metadata md) (if (and (list? md) (andmap (λ (x) (and (pair? x) (symbol? (car x)))) md)) md '())) (define/private (metadata->table metadata) (with-handlers ((exn:fail:read? (λ (x) #f))) (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))) (define (get-teachpack-from-user parent) (define tp-dirs (list "htdp" "2htdp")) (define labels (list (string-constant teachpack-pre-installed/htdp) (string-constant teachpack-pre-installed/2htdp))) (define tpss (map (λ (tp-dir) (let ([base (collection-path "teachpack" tp-dir)]) (filter (λ (x) (file-exists? (build-path base x))) (directory-list base)))) tp-dirs)) (define sort-order (λ (x y) (string<=? (path->string x) (path->string y)))) (define pre-installed-tpss (map (λ (tps) (sort tps sort-order)) tpss)) (define dlg (new (frame:focus-table-mixin dialog%) [parent parent] [label (string-constant drscheme)])) (define hp (new horizontal-panel% [parent dlg])) (define answer #f) (define compiling? #f) (define pre-installed-gbs (map (λ (tps label) (new group-box-panel% [label label] [parent hp])) tpss labels)) (define user-installed-gb (new group-box-panel% [label (string-constant teachpack-user-installed)] [parent hp])) (define pre-installed-lbs (map (λ (pre-installed-gb pre-installed-tps) (new list-box% [label #f] [choices (map path->string pre-installed-tps)] [stretchable-height #t] [min-height 300] [min-width 200] [callback (λ (this evt) (case (send evt get-event-type) [(list-box-dclick) (selected this)] [else (for-each (λ (x) (unless (eq? x this) (clear-selection x))) (cons user-installed-lb pre-installed-lbs)) (update-button)]))] [parent pre-installed-gb])) pre-installed-gbs pre-installed-tpss)) (define user-installed-lb (new list-box% [label #f] [choices '()] [stretchable-height #t] [min-width 200] [callback (λ (x evt) (case (send evt get-event-type) [(list-box-dclick) (selected user-installed-lb)] [else (for ([pre-installed-lb (in-list pre-installed-lbs)]) (clear-selection pre-installed-lb)) (update-button)]))] [parent user-installed-gb])) (define (selected lb) (when (send lb get-selection) (unless compiling? (set! answer (figure-out-answer)) (send dlg show #f)))) (define (clear-selection lb) (for-each (λ (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 (λ (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 (λ () (with-handlers ((exn? (λ (x) (set! exn x)))) (parameterize ([current-namespace (make-base-namespace)]) (with-module-reading-parameterization (lambda () (compile-file filename))))))))]) (thread (λ () (thread-wait t) (queue-callback (λ () (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) (for ([pre-installed-lb (in-list pre-installed-lbs)]) (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 (λ (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)) (ormap (λ (pre-installed-lb) (pair? (send pre-installed-lb get-selections))) pre-installed-lbs))))) (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 (λ (b e) (set! answer (figure-out-answer)) (send dlg show #f)) (λ (b e) (send dlg show #f)) (string-constant ok) (string-constant cancel))) (define (figure-out-answer) (cond [(ormap (λ (pre-installed-lb tp-dir) (and (send pre-installed-lb get-selection) (list tp-dir (send pre-installed-lb get-string (send pre-installed-lb get-selection))))) pre-installed-lbs tp-dirs) => (λ (pr) (define-values (tp-dir f) (apply values pr)) `(lib ,f "teachpack" ,tp-dir))] [(send user-installed-lb get-selection) => (λ (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) (init-field stepper:enable-let-lifting) (init-field stepper:show-lambdas-as-lambdas) (define/override (stepper:supported?) stepper:supported) (define/override (stepper:enable-let-lifting?) stepper:enable-let-lifting) (define/override (stepper:show-lambdas-as-lambdas?) stepper:show-lambdas-as-lambdas) (super-new)) (class* % () (init stepper:supported) (init stepper:enable-let-lifting) (init stepper:show-lambdas-as-lambdas) (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)))) ;; 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))) ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;;; ; ;; ;; ; ; ;; ;; ;;; ; ;; ; ;; ;;; ;;; ; ; ; ;; ; ; ; ;; ; ; ;; ;; ;; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;; ; ; ; ; ;;;; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ;; ; ; ; ; ;;;;; ; ; ; ; ;;;;; ;;; ; ; ; ; ; ; ; ; ;;;; ;; this inspector should be powerful enough to see ;; any structure defined in the user's namespace (define drscheme-inspector (current-inspector)) (eval `(,#'module drscheme-secrets mzscheme (provide drscheme-inspector) (define drscheme-inspector ,drscheme-inspector))) (namespace-require ''drscheme-secrets) ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;;; ; ; ;;;; ; ; ;;; ;;; ;;; ; ; ; ;; ;; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;;; ; ;; ; ;;;;; ;;; ;;;; ; ; ; (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 (get-rewriten-error-message exn) (current-error-port)) (eprintf "uncaught exception: ~e" exn)) (eprintf "\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] [wcm (syntax-shift-phase-level #'with-continuation-mark (- phase base-phase))] [quot (syntax-shift-phase-level #'quote (- phase base-phase))]) #`(wcm (quot teaching-languages-continuation-mark-key) (quot mark) expr)) expr))) (define base-phase (variable-reference->module-base-phase (#%variable-reference))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; 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 ;; (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 (λ () (define sl (editor:get-standard-style-list)) (define on-s (send sl find-named-style test-coverage-on-style-name)) (define off-s (send sl find-named-style test-coverage-off-style-name)) (send rep set-test-coverage-info ht on-s off-s #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 'htdp-langs "internal-error: no test-coverage table"))] [v (hash-ref ht expr (lambda () (error 'htdp-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-htdp-language : (instanceof htdp-language<%>) -> void (define (add-htdp-language o) (drscheme:language-configuration:add-language o)) (define (phase1) (void)) ;; phase2 : -> void (define (phase2) (define htdp-language% (stepper-settings-language (debugger-settings-language ((drscheme:language:get-default-mixin) (language-extension (drscheme:language:module-based-language->language-mixin (module-based-language-extension (drscheme:language:simple-module-based-language->module-based-language-mixin simple-htdp-language%)))))))) (add-htdp-language (instantiate htdp-language% () (one-line-summary (string-constant advanced-one-line-summary)) (module '(lib "lang/htdp-advanced.ss")) (manual #"advanced") (language-position (list (string-constant teaching-languages) (string-constant how-to-design-programs) (string-constant advanced-student))) (language-id "plt:advanced-student") (language-numbers '(-500 -500 5)) (sharing-printing #t) (abbreviate-cons-as-list #t) (allow-sharing? #t) (reader-module '(lib "htdp-advanced-reader.ss" "lang")) (debugger:supported #t) (stepper:supported #f) (stepper:enable-let-lifting #t) (stepper:show-lambdas-as-lambdas #t))) (add-htdp-language (instantiate htdp-language% () (one-line-summary (string-constant intermediate/lambda-one-line-summary)) (module '(lib "lang/htdp-intermediate-lambda.ss")) (manual #"intermediate-lambda") (language-position (list (string-constant teaching-languages) (string-constant how-to-design-programs) (string-constant intermediate-student/lambda))) (language-id "plt:intermediate-student/lambda") (style-delta (let ([match (regexp-match-positions "lambda" (string-constant intermediate-student/lambda))]) (if match (let ([pos (car match)]) (list (list (make-object style-delta% 'change-family 'modern) (car pos) (cdr pos)))) #f))) (language-numbers '(-500 -500 4)) (sharing-printing #f) (abbreviate-cons-as-list #t) (allow-sharing? #f) (reader-module '(lib "htdp-intermediate-lambda-reader.ss" "lang")) (stepper:supported #t) (stepper:enable-let-lifting #t) (stepper:show-lambdas-as-lambdas #t))) (add-htdp-language (instantiate htdp-language% () (one-line-summary (string-constant intermediate-one-line-summary)) (module '(lib "lang/htdp-intermediate.ss")) (manual #"intermediate") (language-position (list (string-constant teaching-languages) (string-constant how-to-design-programs) (string-constant intermediate-student))) (language-id "plt:intermediate-student") (language-numbers '(-500 -500 3)) (sharing-printing #f) (abbreviate-cons-as-list #t) (allow-sharing? #f) (use-function-output-syntax? #t) (reader-module '(lib "htdp-intermediate-reader.ss" "lang")) (stepper:supported #t) (stepper:enable-let-lifting #t) (stepper:show-lambdas-as-lambdas #f))) (add-htdp-language (instantiate htdp-language% () (one-line-summary (string-constant beginning/abbrev-one-line-summary)) (module '(lib "lang/htdp-beginner-abbr.ss")) (manual #"beginning-abbr") (language-position (list (string-constant teaching-languages) (string-constant how-to-design-programs) (string-constant beginning-student/abbrev))) (language-id "plt:beginning-student/abbrev") (language-numbers '(-500 -500 2)) (sharing-printing #f) (abbreviate-cons-as-list #t) (allow-sharing? #f) (reader-module '(lib "htdp-beginner-abbr-reader.ss" "lang")) (stepper:supported #t) (stepper:enable-let-lifting #t) (stepper:show-lambdas-as-lambdas #f))) (add-htdp-language (instantiate htdp-language% () (one-line-summary (string-constant beginning-one-line-summary)) (module '(lib "lang/htdp-beginner.ss")) (manual #"beginning") (language-position (list (string-constant teaching-languages) (string-constant how-to-design-programs) (string-constant beginning-student))) (language-numbers '(-500 -500 1)) (language-id "plt:beginning-student") (sharing-printing #f) (abbreviate-cons-as-list #f) (allow-sharing? #f) (accept-quasiquote? #f) (reader-module '(lib "htdp-beginner-reader.ss" "lang")) (stepper:supported #t) (stepper:enable-let-lifting #t) (stepper:show-lambdas-as-lambdas #f)))) (define test-coverage-on-style-name "plt:htdp:test-coverage-on") (define test-coverage-off-style-name "plt:htdp:test-coverage-off") (define test-coverage-on-style-pref (string->symbol test-coverage-on-style-name)) (define test-coverage-off-style-pref (string->symbol test-coverage-off-style-name)) (color-prefs:register-color-preference test-coverage-on-style-pref test-coverage-on-style-name (send the-color-database find-color "black") (send the-color-database find-color "white")) (color-prefs:register-color-preference test-coverage-off-style-pref test-coverage-off-style-name (send the-color-database find-color "orange") (send the-color-database find-color "indianred") #:background (send the-color-database find-color "black")) (color-prefs:add-to-preferences-panel "HtDP Languages" (λ (parent) (color-prefs:build-color-selection-panel parent test-coverage-on-style-pref test-coverage-on-style-name (string-constant test-coverage-on)) (color-prefs:build-color-selection-panel parent test-coverage-off-style-pref test-coverage-off-style-name (string-constant test-coverage-off) #:background? #t))) (define (update-sds white-on-black?) (define sl (editor:get-standard-style-list)) (define on-s (send sl find-named-style test-coverage-on-style-name)) (define off-s (send sl find-named-style test-coverage-off-style-name)) (define on-sd (make-object style-delta%)) (define off-sd (make-object style-delta%)) (send on-s get-delta on-sd) (send off-s get-delta off-sd) (cond [white-on-black? (send on-sd set-delta-foreground "white") (send off-sd set-delta-foreground "indianred") (send off-sd set-delta-background "black")] [else (send on-sd set-delta-foreground "black") (send off-sd set-delta-foreground "orange") (send off-sd set-delta-background "black")]) (preferences:set test-coverage-on-style-pref on-sd) (preferences:set test-coverage-off-style-pref off-sd)) (preferences:add-callback 'framework:white-on-black? (λ (p v) (update-sds v)))))