From 53af4d6a9a07393790e90f9f742ee11210245139 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 11 Mar 2009 17:42:04 +0000 Subject: [PATCH] moved tracing support from the htdp tool into drscheme proper svn: r14054 --- collects/deinprogramm/deinprogramm-langs.ss | 225 +------ collects/drscheme/private/drsig.ss | 641 ++++++++++---------- collects/drscheme/private/get-extend.ss | 15 +- collects/drscheme/private/link.ss | 113 ++-- collects/drscheme/private/tools.ss | 3 +- collects/drscheme/private/tracing.ss | 223 +++++++ collects/drscheme/private/unit.ss | 13 +- collects/lang/htdp-langs.ss | 287 ++------- collects/tests/drscheme/language-test.ss | 27 +- 9 files changed, 684 insertions(+), 863 deletions(-) create mode 100644 collects/drscheme/private/tracing.ss diff --git a/collects/deinprogramm/deinprogramm-langs.ss b/collects/deinprogramm/deinprogramm-langs.ss index 5fa33a405f..71803aaaa1 100644 --- a/collects/deinprogramm/deinprogramm-langs.ss +++ b/collects/deinprogramm/deinprogramm-langs.ss @@ -46,11 +46,6 @@ (provide tool@) - (define sc-tracing (string-constant tracing-enable-tracing)) - (define sc-show-tracing-window (string-constant tracing-show-tracing-window)) - (define sc-hide-tracing-window (string-constant tracing-hide-tracing-window)) - (define sc-tracing-nothing-to-show (string-constant tracing-tracing-nothing-to-show)) - (define ellipses-cutoff 200) (define o (current-output-port)) @@ -76,18 +71,6 @@ (unit (import drscheme:tool^) (export drscheme:tool-exports^) - (define-local-member-name - get-tracing-text - show-tracing - tracing:add-line - tracing:rest) - (define tab-tracing<%> - (interface () - get-tracing-text - get-any-results? - tracing:add-line - tracing:reset)) - (define drs-eventspace (current-eventspace)) @@ -502,10 +485,10 @@ (string-constant use-pretty-printer-label) output-panel void)] - #; + [tracing (new check-box% (parent output-panel) - (label sc-tracing) + (label (string-constant tracing-enable-tracing)) (callback void))] [tps '()]) @@ -544,8 +527,8 @@ (case (send writing-style get-selection) [(0) 'explicit] [(1) 'datum]) - #f ;; (send tracing get-value) -- disabled tracing - tps)] + (send tracing get-value) + tps)] [(settings) (send case-sensitive set-value (drscheme:language:simple-settings-case-sensitive settings)) (send output-style set-selection @@ -583,8 +566,7 @@ [parent tp-panel] [label (format "~s" tp)])) tps)) - ;; disabled tracing - #; (send tracing set-value (htdp-lang-settings-tracing? settings)) + (send tracing set-value (deinprogramm-lang-settings-tracing? settings)) (void)]))) (define simple-deinprogramm-language% @@ -1278,60 +1260,6 @@ (define-values/invoke-unit et:stacktrace@ (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) - (define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key))) - - (define (print-call-trace inferred-name original? src args improper? depth) - (when inferred-name - (let ([name (cond - [(identifier? inferred-name) (syntax-e inferred-name)] - [else (object-name inferred-name)])] - [rep (drscheme:rep:current-rep)]) - (when (and name rep) - (let ([canvas (send rep get-canvas)]) - (when canvas - (let* ([frame (send canvas get-top-level-window)] - [tab (send frame get-current-tab)]) - (when (is-a? tab tab-tracing<%>) - (let ([sp (open-output-string)]) - (let loop ([i depth]) - (unless (zero? i) - (display " " sp) - (loop (- i 1)))) - (fprintf sp "(") - (fprintf sp "~a" name) - (let loop ([args args]) - (cond - [(null? args) (void)] - [(and (null? (cdr args)) improper?) - (fprintf sp " . ") - (fprintf sp "~v" (car args))] - [else - (let ([arg (car args)]) - (fprintf sp " ") - (fprintf sp "~v" arg)) - (loop (cdr args))])) - (fprintf sp ")") - (let ([sema (make-semaphore)]) - ;; Disable breaks, so an exn handler can't - ;; grab the DrScheme eventspacae: - (parameterize-break #f - ;; Queue callback to write trace line --- - ;; low priority, so that infinite loops don't stop the user - ;; from clicking "Break" - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (lambda () - (send tab tracing:add-line (get-output-string sp)) - (semaphore-post sema)) - #f))) - ;; Wait for the line to get written, so that the - ;; trace output doesn't get too far behind (which - ;; matters, again, for infinite loops) - (semaphore-wait sema))))))))))) - - (define-values/invoke-unit tr:stacktrace@ - (import tr:stacktrace-imports^) (export (prefix tr: tr:stacktrace^))) - ;; add-annotation : boolean (sexp -> value) -> sexp -> value ;; adds debugging and test coverage information to `sexp' and calls `oe' (define (add-annotation tracing? oe) @@ -1345,146 +1273,12 @@ (namespace-base-phase))] [tr-annotated (if tracing? - (tr:annotate (expand et-annotated)) + (drscheme:tracing:annotate (expand et-annotated)) et-annotated)]) tr-annotated))]) (oe annotated)))]) teaching-language-eval-handler)) - (define tab-tracing-mixin - (mixin (drscheme:unit:tab<%> drscheme:rep:context<%>) (tab-tracing<%>) - (inherit get-frame) - - (define tracing-visible? #f) - (define/public (set-tracing-visible? v?) (set! tracing-visible? v?)) - (define/public (get-tracing-visible?) tracing-visible?) - - (define/augment (clear-annotations) - (tracing:reset) - (inner (void) clear-annotations)) - - (define any-results? #f) - (define/public (get-any-results?) any-results?) - (define/public (tracing:reset) - (set! any-results? #f) - (send show-tracing-text lock #f) - (send show-tracing-text erase) - (send show-tracing-text auto-wrap #t) - (send show-tracing-text insert sc-tracing-nothing-to-show) - (send show-tracing-text lock #t)) - - (define show-tracing-text (new text:hide-caret/selection%)) - (define/public (get-tracing-text) show-tracing-text) - (send show-tracing-text lock #t) - - (define/public (tracing:add-line s) - (let ([old-any? any-results?]) - (set! any-results? #t) - (unless old-any? - (send (get-frame) show-tracing)) - (send show-tracing-text begin-edit-sequence) - (send show-tracing-text lock #f) - (unless old-any? - (send show-tracing-text erase) - (send show-tracing-text auto-wrap #f)) - (let ([insert - (lambda (s) - (send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))]) - (cond - [(<= (string-length s) ellipses-cutoff) - (insert s) - (insert "\n")] - [else - (insert (substring s 0 ellipses-cutoff)) - (insert " ") - (let ([ell-start (send show-tracing-text last-position)]) - (insert "...") - (let ([ell-end (send show-tracing-text last-position)]) - (let ([para (send show-tracing-text last-paragraph)]) - (insert "\n") - (send show-tracing-text change-style clickback-delta ell-start ell-end) - (send show-tracing-text set-clickback ell-start ell-end - (lambda (t x y) - (send show-tracing-text begin-edit-sequence) - (send show-tracing-text lock #f) - (let ([line-start (send show-tracing-text paragraph-start-position para)] - [line-end (send show-tracing-text paragraph-end-position para)]) - (send show-tracing-text delete line-start line-end #f) - (send show-tracing-text insert s line-start 'same #f)) - (send show-tracing-text lock #t) - (send show-tracing-text end-edit-sequence))))))])) - (send show-tracing-text lock #t) - (send show-tracing-text end-edit-sequence))) - - (super-new))) - - - (define frame-tracing-mixin - (mixin (drscheme:frame:<%> drscheme:unit:frame<%>) () - (inherit get-current-tab) - (define show-tracing-menu-item #f) - (define tracing-visible? #f) - - (define/augment (on-tab-change old new) - (inner (void) on-tab-change old new) - (send show-tracing-canvas set-editor (send new get-tracing-text)) - (cond - [(eq? tracing-visible? (send new get-tracing-visible?)) - (void)] - [(send new get-tracing-visible?) - (show-tracing)] - [else - (hide-tracing)])) - - (define/override (add-show-menu-items show-menu) - (super add-show-menu-items show-menu) - (set! show-tracing-menu-item - (new menu-item% - (parent show-menu) - (label sc-show-tracing-window) - (callback (lambda (x y) (toggle-tracing)))))) - - (define/public (show-tracing) - (set! tracing-visible? #t) - (send show-tracing-menu-item set-label sc-hide-tracing-window) - (send dragable-parent begin-container-sequence) - (send dragable-parent change-children - (lambda (l) - (let ([without (remq show-tracing-canvas l)]) - (append without (list show-tracing-canvas))))) - (send dragable-parent set-percentages '(3/4 1/4)) - (send dragable-parent end-container-sequence)) - - (define/private (hide-tracing) - (set! tracing-visible? #f) - (send show-tracing-menu-item set-label sc-show-tracing-window) - (send dragable-parent change-children - (lambda (l) - (remq show-tracing-canvas l)))) - - (define/private (toggle-tracing) - (if tracing-visible? - (hide-tracing) - (show-tracing))) - - (define dragable-parent #f) - (define show-tracing-parent-panel #f) - (define show-tracing-canvas #f) - - (define/override (make-root-area-container cls parent) - (set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent)) - (let ([root (make-object cls dragable-parent)]) - (set! show-tracing-canvas (new editor-canvas% - (parent dragable-parent) - (editor (send (get-current-tab) get-tracing-text)))) - (send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l))) - root)) - - (super-new))) - - (define clickback-delta (make-object style-delta%)) - (send clickback-delta set-delta-foreground "BLUE") - (send clickback-delta set-delta 'change-underline #t) ; @@ -1584,9 +1378,4 @@ (allow-sharing? #t) (reader-module '(lib "DMdA-advanced-reader.ss" "deinprogramm")) (stepper:supported #f) - (debugger:supported #t))) - - ;; #### these bomb: - ;(drscheme:get/extend:extend-unit-frame frame-tracing-mixin) - ;(drscheme:get/extend:extend-tab tab-tracing-mixin) - ))) + (debugger:supported #t)))))) diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 9511472d18..fbb18b6e80 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -1,320 +1,329 @@ #lang scheme/base - (require scheme/unit) - - (provide drscheme:eval^ - drscheme:debug^ - drscheme:module-language^ - drscheme:get-collection^ - drscheme:main^ - drscheme:init^ - drscheme:language-configuration^ - drscheme:language-configuration/internal^ - drscheme:tools^ - drscheme:get/extend^ - drscheme:unit^ - drscheme:frame^ - drscheme:program^ - drscheme:text^ - drscheme:rep^ - drscheme:app^ - drscheme:draw-arrow^ - drscheme:help-desk^ - drscheme:language^ - drscheme:multi-file-search^ - drscheme:module-overview^ - drscheme:font^ - drscheme:modes^ - drscheme:tool-exports^ - drscheme:tool^ - drscheme:tool-cm^) - - (define-signature drscheme:modes-cm^ - ()) - (define-signature drscheme:modes^ extends drscheme:modes-cm^ - (add-mode - get-modes - add-initial-modes - (struct mode (name surrogate repl-submit matches-language) - #:omit-constructor))) - - (define-signature drscheme:font-cm^ - ()) - (define-signature drscheme:font^ extends drscheme:font-cm^ - (setup-preferences)) - - (define-signature drscheme:debug-cm^ - (profile-definitions-text-mixin - profile-tab-mixin - profile-unit-frame-mixin - test-coverage-interactions-text-mixin - test-coverage-definitions-text-mixin - test-coverage-tab-mixin)) - (define-signature drscheme:debug^ extends drscheme:debug-cm^ - (make-debug-error-display-handler - make-debug-eval-handler - error-display-handler/stacktrace - bug-info->ticket-url - test-coverage-enabled - profiling-enabled +(require scheme/unit) - add-prefs-panel - - get-error-color - - hide-backtrace-window - show-backtrace-window - open-and-highlight-in-file - get-cm-key - - small-planet-bitmap - - ;show-error-and-highlight - ;print-bug-to-stderr - ;display-srclocs-in-error - ;show-syntax-error-context - )) +(provide drscheme:eval^ + drscheme:debug^ + drscheme:module-language^ + drscheme:get-collection^ + drscheme:main^ + drscheme:init^ + drscheme:language-configuration^ + drscheme:language-configuration/internal^ + drscheme:tools^ + drscheme:get/extend^ + drscheme:unit^ + drscheme:frame^ + drscheme:program^ + drscheme:text^ + drscheme:rep^ + drscheme:app^ + drscheme:draw-arrow^ + drscheme:help-desk^ + drscheme:language^ + drscheme:multi-file-search^ + drscheme:module-overview^ + drscheme:font^ + drscheme:modes^ + drscheme:tracing^ + drscheme:tool-exports^ + drscheme:tool^ + drscheme:tool-cm^) - (define-signature drscheme:module-langauge-cm^ - (module-language<%>)) - (define-signature drscheme:module-language^ extends drscheme:module-langauge-cm^ - (add-module-language - module-language-put-file-mixin)) - - (define-signature drscheme:get-collection-cm^ ()) - (define-signature drscheme:get-collection^ extends drscheme:get-collection-cm^ - (get-file/collection)) - - (define-signature drscheme:main-cm^ ()) - (define-signature drscheme:main^ extends drscheme:main-cm^ ()) - - (define-signature drscheme:init-cm^ - ()) - (define-signature drscheme:init^ extends drscheme:init-cm^ - (original-output-port - original-error-port - original-error-display-handler - primitive-eval - primitive-load - error-display-handler-message-box-title - system-logger - system-custodian - system-eventspace - system-namespace - first-dir)) - - (define-signature drscheme:language-configuration-cm^ - ()) - (define-signature drscheme:language-configuration^ extends drscheme:language-configuration-cm^ - (add-language - get-languages - (struct language-settings (language settings)) - get-settings-preferences-symbol - language-dialog - fill-language-dialog)) - - (define-signature drscheme:language-configuration/internal^ extends drscheme:language-configuration^ - (add-info-specified-languages - get-default-language-settings - settings-preferences-symbol - get-all-scheme-manual-keywords - get-all-manual-keywords - add-built-in-languages - not-a-language-language<%>)) - - (define-signature drscheme:tools-cm^ - ()) - (define-signature drscheme:tools^ extends drscheme:tools-cm^ - ((struct successful-tool (spec bitmap name url)) - get-successful-tools - only-in-phase - load/invoke-all-tools - add-prefs-panel)) - - (define-signature drscheme:get/extend-cm^ - ()) - (define-signature drscheme:get/extend^ extends drscheme:get/extend-cm^ - (extend-tab - extend-interactions-text - extend-definitions-text - extend-interactions-canvas - extend-definitions-canvas - extend-unit-frame - get-tab - get-interactions-text - get-definitions-text - get-interactions-canvas - get-definitions-canvas - get-unit-frame)) - - (define-signature drscheme:unit-cm^ - (tab% - tab<%> - frame% - frame<%> - definitions-canvas% - get-definitions-text% - definitions-text<%> - interactions-canvas%)) - (define-signature drscheme:unit^ extends drscheme:unit-cm^ - (open-drscheme-window - find-symbol - get-program-editor-mixin - add-to-program-editor-mixin - forget-saved-bug-report - record-saved-bug-report - (struct teachpack-callbacks (get-names remove add)))) - - (define-signature drscheme:frame-cm^ - (<%> - mixin - basics-mixin - basics<%>)) - (define-signature drscheme:frame^ extends drscheme:frame-cm^ - (create-root-menubar - add-keybindings-item - planet-spec?)) - - (define-signature drscheme:program-cm^ - (frame%)) - (define-signature drscheme:program^ extends drscheme:program-cm^ - ()) - - (define-signature drscheme:eval-cm^ - ()) - (define-signature drscheme:eval^ extends drscheme:eval-cm^ - (expand-program - expand-program/multiple - traverse-program/multiple - build-user-eventspace/custodian - set-basic-parameters - get-snip-classes)) - - (define-signature drscheme:text-cm^ - (text<%> - text%)) - (define-signature drscheme:text^ extends drscheme:text-cm^ - ()) - - (define-signature drscheme:setup-cm^ - ()) - (define-signature drscheme:setup^ extends drscheme:setup-cm^ - (do-setup)) - - (define-signature drscheme:rep-cm^ - (drs-bindings-keymap-mixin - text% - text<%> - context<%>)) - (define-signature drscheme:rep^ extends drscheme:rep-cm^ - (current-rep - current-language-settings - current-value-port - get-drs-bindings-keymap - error-delta - get-welcome-delta - get-dark-green-delta - drs-autocomplete-mixin)) - - (define-signature drscheme:app-cm^ - ()) - (define-signature drscheme:app^ extends drscheme:app-cm^ - (about-drscheme - add-language-items-to-help-menu - add-important-urls-to-help-menu - switch-language-to)) - - (define-signature drscheme:draw-arrow-cm^ - ()) - (define-signature drscheme:draw-arrow^ extends drscheme:draw-arrow-cm^ - (draw-arrow)) - - (define-signature drscheme:help-desk-cm^ - ()) - (define-signature drscheme:help-desk^ extends drscheme:help-desk-cm^ - (help-desk - goto-plt-license - get-docs)) - - (define-signature drscheme:language-cm^ - (language<%> - module-based-language<%> - simple-module-based-language<%> - simple-module-based-language% - simple-module-based-language->module-based-language-mixin - module-based-language->language-mixin)) - (define-signature drscheme:language^ extends drscheme:language-cm^ - (get-default-mixin - extend-language-interface - get-language-extensions - - create-module-based-launcher - create-module-based-stand-alone-executable - create-module-based-distribution - - create-distribution-for-executable - - create-executable-gui - put-executable - - ;(struct loc (source position line column span)) - - (struct text/pos (text start end)) - (struct simple-settings (case-sensitive - printing-style - fraction-style - show-sharing - insert-newlines - annotations)) - simple-settings->vector - - simple-module-based-language-config-panel - - add-snip-value - setup-setup-values - - register-capability - capability-registered? - get-capability-default - get-capability-contract)) - - (define-signature drscheme:multi-file-search-cm^ - ()) - (define-signature drscheme:multi-file-search^ extends drscheme:multi-file-search-cm^ - (multi-file-search)) - - (define-signature drscheme:module-overview-cm^ - ()) - (define-signature drscheme:module-overview^ extends drscheme:module-overview-cm^ - (module-overview - make-module-overview-pasteboard - fill-pasteboard)) - - (define-signature drscheme:tool-exports-cm^ - ()) - (define-signature drscheme:tool-exports^ extends drscheme:tool-exports-cm^ - (phase1 - phase2)) - - (define-signature drscheme:tool-cm^ - ((open (prefix drscheme:debug: drscheme:debug-cm^)) - (open (prefix drscheme:unit: drscheme:unit-cm^)) - (open (prefix drscheme:rep: drscheme:rep-cm^)) - (open (prefix drscheme:frame: drscheme:frame-cm^)) - (open (prefix drscheme:get/extend: drscheme:get/extend-cm^)) - (open (prefix drscheme:language-configuration: drscheme:language-configuration-cm^)) - (open (prefix drscheme:language: drscheme:language-cm^)) - (open (prefix drscheme:help-desk: drscheme:help-desk-cm^)) - (open (prefix drscheme:eval: drscheme:eval-cm^)) - (open (prefix drscheme:modes: drscheme:modes-cm^)))) +(define-signature drscheme:modes-cm^ + ()) +(define-signature drscheme:modes^ extends drscheme:modes-cm^ + (add-mode + get-modes + add-initial-modes + (struct mode (name surrogate repl-submit matches-language) + #:omit-constructor))) - (define-signature drscheme:tool^ - ((open (prefix drscheme:debug: drscheme:debug^)) - (open (prefix drscheme:unit: drscheme:unit^)) - (open (prefix drscheme:rep: drscheme:rep^)) - (open (prefix drscheme:frame: drscheme:frame^)) - (open (prefix drscheme:get/extend: drscheme:get/extend^)) - (open (prefix drscheme:language-configuration: drscheme:language-configuration^)) - (open (prefix drscheme:language: drscheme:language^)) - (open (prefix drscheme:help-desk: drscheme:help-desk^)) - (open (prefix drscheme:eval: drscheme:eval^)) - (open (prefix drscheme:modes: drscheme:modes^)))) +(define-signature drscheme:font-cm^ + ()) +(define-signature drscheme:font^ extends drscheme:font-cm^ + (setup-preferences)) + +(define-signature drscheme:debug-cm^ + (profile-definitions-text-mixin + profile-tab-mixin + profile-unit-frame-mixin + test-coverage-interactions-text-mixin + test-coverage-definitions-text-mixin + test-coverage-tab-mixin)) +(define-signature drscheme:debug^ extends drscheme:debug-cm^ + (make-debug-error-display-handler + make-debug-eval-handler + error-display-handler/stacktrace + bug-info->ticket-url + test-coverage-enabled + profiling-enabled + + add-prefs-panel + + get-error-color + + hide-backtrace-window + show-backtrace-window + open-and-highlight-in-file + get-cm-key + + small-planet-bitmap + + ;show-error-and-highlight + ;print-bug-to-stderr + ;display-srclocs-in-error + ;show-syntax-error-context + )) + +(define-signature drscheme:module-langauge-cm^ + (module-language<%>)) +(define-signature drscheme:module-language^ extends drscheme:module-langauge-cm^ + (add-module-language + module-language-put-file-mixin)) + +(define-signature drscheme:get-collection-cm^ ()) +(define-signature drscheme:get-collection^ extends drscheme:get-collection-cm^ + (get-file/collection)) + +(define-signature drscheme:main-cm^ ()) +(define-signature drscheme:main^ extends drscheme:main-cm^ ()) + +(define-signature drscheme:init-cm^ + ()) +(define-signature drscheme:init^ extends drscheme:init-cm^ + (original-output-port + original-error-port + original-error-display-handler + primitive-eval + primitive-load + error-display-handler-message-box-title + system-logger + system-custodian + system-eventspace + system-namespace + first-dir)) + +(define-signature drscheme:language-configuration-cm^ + ()) +(define-signature drscheme:language-configuration^ extends drscheme:language-configuration-cm^ + (add-language + get-languages + (struct language-settings (language settings)) + get-settings-preferences-symbol + language-dialog + fill-language-dialog)) + +(define-signature drscheme:language-configuration/internal^ extends drscheme:language-configuration^ + (add-info-specified-languages + get-default-language-settings + settings-preferences-symbol + get-all-scheme-manual-keywords + get-all-manual-keywords + add-built-in-languages + not-a-language-language<%>)) + +(define-signature drscheme:tools-cm^ + ()) +(define-signature drscheme:tools^ extends drscheme:tools-cm^ + ((struct successful-tool (spec bitmap name url)) + get-successful-tools + only-in-phase + load/invoke-all-tools + add-prefs-panel)) + +(define-signature drscheme:get/extend-cm^ + ()) +(define-signature drscheme:get/extend^ extends drscheme:get/extend-cm^ + (extend-tab + extend-interactions-text + extend-definitions-text + extend-interactions-canvas + extend-definitions-canvas + extend-unit-frame + get-tab + get-interactions-text + get-definitions-text + get-interactions-canvas + get-definitions-canvas + get-unit-frame)) + +(define-signature drscheme:unit-cm^ + (tab% + tab<%> + frame% + frame<%> + definitions-canvas% + get-definitions-text% + definitions-text<%> + interactions-canvas%)) +(define-signature drscheme:unit^ extends drscheme:unit-cm^ + (open-drscheme-window + find-symbol + get-program-editor-mixin + add-to-program-editor-mixin + forget-saved-bug-report + record-saved-bug-report + (struct teachpack-callbacks (get-names remove add)))) + +(define-signature drscheme:frame-cm^ + (<%> + mixin + basics-mixin + basics<%>)) +(define-signature drscheme:frame^ extends drscheme:frame-cm^ + (create-root-menubar + add-keybindings-item + planet-spec?)) + +(define-signature drscheme:program-cm^ + (frame%)) +(define-signature drscheme:program^ extends drscheme:program-cm^ + ()) + +(define-signature drscheme:eval-cm^ + ()) +(define-signature drscheme:eval^ extends drscheme:eval-cm^ + (expand-program + expand-program/multiple + traverse-program/multiple + build-user-eventspace/custodian + set-basic-parameters + get-snip-classes)) + +(define-signature drscheme:text-cm^ + (text<%> + text%)) +(define-signature drscheme:text^ extends drscheme:text-cm^ + ()) + +(define-signature drscheme:setup-cm^ + ()) +(define-signature drscheme:setup^ extends drscheme:setup-cm^ + (do-setup)) + +(define-signature drscheme:rep-cm^ + (drs-bindings-keymap-mixin + text% + text<%> + context<%>)) +(define-signature drscheme:rep^ extends drscheme:rep-cm^ + (current-rep + current-language-settings + current-value-port + get-drs-bindings-keymap + error-delta + get-welcome-delta + get-dark-green-delta + drs-autocomplete-mixin)) + +(define-signature drscheme:app-cm^ + ()) +(define-signature drscheme:app^ extends drscheme:app-cm^ + (about-drscheme + add-language-items-to-help-menu + add-important-urls-to-help-menu + switch-language-to)) + +(define-signature drscheme:draw-arrow-cm^ + ()) +(define-signature drscheme:draw-arrow^ extends drscheme:draw-arrow-cm^ + (draw-arrow)) + +(define-signature drscheme:help-desk-cm^ + ()) +(define-signature drscheme:help-desk^ extends drscheme:help-desk-cm^ + (help-desk + goto-plt-license + get-docs)) + +(define-signature drscheme:language-cm^ + (language<%> + module-based-language<%> + simple-module-based-language<%> + simple-module-based-language% + simple-module-based-language->module-based-language-mixin + module-based-language->language-mixin)) +(define-signature drscheme:language^ extends drscheme:language-cm^ + (get-default-mixin + extend-language-interface + get-language-extensions + + create-module-based-launcher + create-module-based-stand-alone-executable + create-module-based-distribution + + create-distribution-for-executable + + create-executable-gui + put-executable + + ;(struct loc (source position line column span)) + + (struct text/pos (text start end)) + (struct simple-settings (case-sensitive + printing-style + fraction-style + show-sharing + insert-newlines + annotations)) + simple-settings->vector + + simple-module-based-language-config-panel + + add-snip-value + setup-setup-values + + register-capability + capability-registered? + get-capability-default + get-capability-contract)) + +(define-signature drscheme:multi-file-search-cm^ + ()) +(define-signature drscheme:multi-file-search^ extends drscheme:multi-file-search-cm^ + (multi-file-search)) + +(define-signature drscheme:module-overview-cm^ + ()) +(define-signature drscheme:module-overview^ extends drscheme:module-overview-cm^ + (module-overview + make-module-overview-pasteboard + fill-pasteboard)) + +(define-signature drscheme:tracing-cm^ + (tab-mixin + frame-mixin)) +(define-signature drscheme:tracing^ extends drscheme:tracing-cm^ + (annotate)) + +(define-signature drscheme:tool-exports-cm^ + ()) +(define-signature drscheme:tool-exports^ extends drscheme:tool-exports-cm^ + (phase1 + phase2)) + +(define-signature drscheme:tool-cm^ + ((open (prefix drscheme:debug: drscheme:debug-cm^)) + (open (prefix drscheme:unit: drscheme:unit-cm^)) + (open (prefix drscheme:rep: drscheme:rep-cm^)) + (open (prefix drscheme:frame: drscheme:frame-cm^)) + (open (prefix drscheme:get/extend: drscheme:get/extend-cm^)) + (open (prefix drscheme:language-configuration: drscheme:language-configuration-cm^)) + (open (prefix drscheme:language: drscheme:language-cm^)) + (open (prefix drscheme:help-desk: drscheme:help-desk-cm^)) + (open (prefix drscheme:eval: drscheme:eval-cm^)) + (open (prefix drscheme:modes: drscheme:modes-cm^)) + (open (prefix drscheme:tracing: drscheme:tracing-cm^)))) + +(define-signature drscheme:tool^ + ((open (prefix drscheme:debug: drscheme:debug^)) + (open (prefix drscheme:unit: drscheme:unit^)) + (open (prefix drscheme:rep: drscheme:rep^)) + (open (prefix drscheme:frame: drscheme:frame^)) + (open (prefix drscheme:get/extend: drscheme:get/extend^)) + (open (prefix drscheme:language-configuration: drscheme:language-configuration^)) + (open (prefix drscheme:language: drscheme:language^)) + (open (prefix drscheme:help-desk: drscheme:help-desk^)) + (open (prefix drscheme:eval: drscheme:eval^)) + (open (prefix drscheme:modes: drscheme:modes^)) + (open (prefix drscheme:tracing: drscheme:tracing^)))) diff --git a/collects/drscheme/private/get-extend.ss b/collects/drscheme/private/get-extend.ss index faa82d7040..58f20ea88a 100644 --- a/collects/drscheme/private/get-extend.ss +++ b/collects/drscheme/private/get-extend.ss @@ -6,7 +6,8 @@ (import [prefix drscheme:unit: drscheme:unit^] [prefix drscheme:frame: drscheme:frame^] [prefix drscheme:rep: drscheme:rep^] - [prefix drscheme:debug: drscheme:debug^]) + [prefix drscheme:debug: drscheme:debug^] + [prefix drscheme:tracing: drscheme:tracing^]) (export drscheme:get/extend^) (define make-extender @@ -43,9 +44,10 @@ built))))) (define (get-base-tab%) - (drscheme:debug:test-coverage-tab-mixin - (drscheme:debug:profile-tab-mixin - drscheme:unit:tab%))) + (drscheme:tracing:tab-mixin + (drscheme:debug:test-coverage-tab-mixin + (drscheme:debug:profile-tab-mixin + drscheme:unit:tab%)))) (define-values (extend-tab get-tab) (make-extender get-base-tab% 'tab%)) @@ -62,8 +64,9 @@ (make-extender get-base-definitions-canvas% 'definitions-canvas%)) (define (get-base-unit-frame%) - (drscheme:debug:profile-unit-frame-mixin - drscheme:unit:frame%)) + (drscheme:tracing:frame-mixin + (drscheme:debug:profile-unit-frame-mixin + drscheme:unit:frame%))) (define-values (extend-unit-frame get-unit-frame) (make-extender get-base-unit-frame% 'drscheme:unit:frame)) diff --git a/collects/drscheme/private/link.ss b/collects/drscheme/private/link.ss index cd839dc391..0a02240234 100644 --- a/collects/drscheme/private/link.ss +++ b/collects/drscheme/private/link.ss @@ -1,55 +1,60 @@ -#lang mzscheme - (require "modes.ss" - "font.ss" - "eval.ss" - "module-browser.ss" - "multi-file-search.ss" - "debug.ss" - "module-language.ss" - "tools.ss" - mzlib/unit - "language.ss" - "language-configuration.ss" - "drsig.ss" - "init.ss" - "text.ss" - "app.ss" - "main.ss" - "rep.ss" - "frame.ss" - "unit.ss" - "get-extend.ss" - "help-desk.ss") - (provide drscheme@) - - - (define-compound-unit/infer drscheme-unit@ - (import) - (export drscheme:debug^ - drscheme:unit^ - drscheme:rep^ - drscheme:frame^ - drscheme:get/extend^ - drscheme:language-configuration^ - drscheme:language^ - drscheme:help-desk^ - drscheme:eval^ - drscheme:modes^) - (link init@ tools@ modes@ text@ eval@ frame@ rep@ language@ - module-overview@ unit@ debug@ multi-file-search@ get-extend@ - language-configuration@ font@ module-language@ help-desk@ app@ main@)) - - (define-unit/new-import-export drscheme@ - (import) (export drscheme:tool^) - (((prefix drscheme:debug: drscheme:debug^) - (prefix drscheme:unit: drscheme:unit^) - (prefix drscheme:rep: drscheme:rep^) - (prefix drscheme:frame: drscheme:frame^) - (prefix drscheme:get/extend: drscheme:get/extend^) - (prefix drscheme:language-configuration: drscheme:language-configuration^) - (prefix drscheme:language: drscheme:language^) - (prefix drscheme:help-desk: drscheme:help-desk^) - (prefix drscheme:eval: drscheme:eval^) - (prefix drscheme:modes: drscheme:modes^)) - drscheme-unit@)) +#lang scheme/base +(require scheme/unit + "modes.ss" + "font.ss" + "eval.ss" + "module-browser.ss" + "multi-file-search.ss" + "debug.ss" + "module-language.ss" + "tools.ss" + "language.ss" + "language-configuration.ss" + "drsig.ss" + "init.ss" + "text.ss" + "app.ss" + "main.ss" + "rep.ss" + "frame.ss" + "unit.ss" + "tracing.ss" + "get-extend.ss" + "help-desk.ss") + +(provide drscheme@) + +(define-compound-unit/infer drscheme-unit@ + (import) + (export drscheme:debug^ + drscheme:unit^ + drscheme:rep^ + drscheme:frame^ + drscheme:get/extend^ + drscheme:language-configuration^ + drscheme:language^ + drscheme:help-desk^ + drscheme:eval^ + drscheme:modes^ + drscheme:tracing^) + (link init@ tools@ modes@ text@ eval@ frame@ rep@ language@ + module-overview@ unit@ debug@ multi-file-search@ get-extend@ + language-configuration@ font@ module-language@ help-desk@ + tracing@ app@ + main@)) + +(define-unit/new-import-export drscheme@ + (import) (export drscheme:tool^) + (((prefix drscheme:debug: drscheme:debug^) + (prefix drscheme:unit: drscheme:unit^) + (prefix drscheme:rep: drscheme:rep^) + (prefix drscheme:frame: drscheme:frame^) + (prefix drscheme:get/extend: drscheme:get/extend^) + (prefix drscheme:language-configuration: drscheme:language-configuration^) + (prefix drscheme:language: drscheme:language^) + (prefix drscheme:help-desk: drscheme:help-desk^) + (prefix drscheme:eval: drscheme:eval^) + (prefix drscheme:modes: drscheme:modes^) + (prefix drscheme:tracing: drscheme:tracing^)) + drscheme-unit@)) diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss index 598aef8345..a353a1e400 100644 --- a/collects/drscheme/private/tools.ss +++ b/collects/drscheme/private/tools.ss @@ -24,7 +24,8 @@ [prefix drscheme:init: drscheme:init^] [prefix drscheme:debug: drscheme:debug^] [prefix drscheme:eval: drscheme:eval^] - [prefix drscheme:modes: drscheme:modes^]) + [prefix drscheme:modes: drscheme:modes^] + [prefix drscheme:tracing: drscheme:tracing^]) (export drscheme:tools^) ;; An installed-tool is diff --git a/collects/drscheme/private/tracing.ss b/collects/drscheme/private/tracing.ss new file mode 100644 index 0000000000..599b359d11 --- /dev/null +++ b/collects/drscheme/private/tracing.ss @@ -0,0 +1,223 @@ +#lang scheme/base + +(require scheme/contract + scheme/unit + scheme/class + scheme/path + scheme/port + scheme/list + scheme/gui/base + string-constants + framework + (prefix-in tr: trace/stacktrace) + "drsig.ss") + +(provide tracing@) + +(define-unit tracing@ + (import [prefix drscheme:frame: drscheme:frame^] + [prefix drscheme:rep: drscheme:rep^] + [prefix drscheme:init: drscheme:init^] + [prefix drscheme:unit: drscheme:unit^]) + (export drscheme:tracing^) + + (define-local-member-name + get-tracing-text + show-tracing + tracing:add-line + tracing:rest) + (define tab-tracing<%> + (interface () + get-tracing-text + get-any-results? + tracing:add-line + tracing:reset)) + + (define ellipses-cutoff 200) + (define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key))) + + (define (print-call-trace inferred-name original? src args improper? depth) + (when inferred-name + (let ([name (cond + [(identifier? inferred-name) (syntax-e inferred-name)] + [else (object-name inferred-name)])] + [rep (drscheme:rep:current-rep)]) + (when (and name rep) + (let ([canvas (send rep get-canvas)]) + (when canvas + (let* ([frame (send canvas get-top-level-window)] + [tab (send frame get-current-tab)]) + (when (is-a? tab tab-tracing<%>) + (let ([sp (open-output-string)]) + (let loop ([i depth]) + (unless (zero? i) + (display " " sp) + (loop (- i 1)))) + (fprintf sp "(") + (fprintf sp "~a" name) + (let loop ([args args]) + (cond + [(null? args) (void)] + [(and (null? (cdr args)) improper?) + (fprintf sp " . ") + (fprintf sp "~v" (car args))] + [else + (let ([arg (car args)]) + (fprintf sp " ") + (fprintf sp "~v" arg)) + (loop (cdr args))])) + (fprintf sp ")") + (let ([sema (make-semaphore)]) + ;; Disable breaks, so an exn handler can't + ;; grab the DrScheme eventspacae: + (parameterize-break #f + ;; Queue callback to write trace line --- + ;; low priority, so that infinite loops don't stop the user + ;; from clicking "Break" + (parameterize ([current-eventspace drscheme:init:system-eventspace]) + (queue-callback + (lambda () + (send tab tracing:add-line (get-output-string sp)) + (semaphore-post sema)) + #f))) + ;; Wait for the line to get written, so that the + ;; trace output doesn't get too far behind (which + ;; matters, again, for infinite loops) + (semaphore-wait sema))))))))))) + + (define-values/invoke-unit tr:stacktrace@ + (import tr:stacktrace-imports^) (export tr:stacktrace^)) + + (define tab-mixin + (mixin (drscheme:unit:tab<%> drscheme:rep:context<%>) (tab-tracing<%>) + (inherit get-frame) + + (define tracing-visible? #f) + (define/public (set-tracing-visible? v?) (set! tracing-visible? v?)) + (define/public (get-tracing-visible?) tracing-visible?) + + (define/augment (clear-annotations) + (tracing:reset) + (inner (void) clear-annotations)) + + (define any-results? #f) + (define/public (get-any-results?) any-results?) + (define/public (tracing:reset) + (set! any-results? #f) + (send show-tracing-text lock #f) + (send show-tracing-text erase) + (send show-tracing-text auto-wrap #t) + (send show-tracing-text insert (string-constant tracing-tracing-nothing-to-show)) + (send show-tracing-text lock #t)) + + (define show-tracing-text (new text:hide-caret/selection%)) + (define/public (get-tracing-text) show-tracing-text) + (send show-tracing-text lock #t) + + (define/public (tracing:add-line s) + (let ([old-any? any-results?]) + (set! any-results? #t) + (unless old-any? + (send (get-frame) show-tracing)) + (send show-tracing-text begin-edit-sequence) + (send show-tracing-text lock #f) + (unless old-any? + (send show-tracing-text erase) + (send show-tracing-text auto-wrap #f)) + (let ([insert + (lambda (s) + (send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))]) + (cond + [(<= (string-length s) ellipses-cutoff) + (insert s) + (insert "\n")] + [else + (insert (substring s 0 ellipses-cutoff)) + (insert " ") + (let ([ell-start (send show-tracing-text last-position)]) + (insert "...") + (let ([ell-end (send show-tracing-text last-position)]) + (let ([para (send show-tracing-text last-paragraph)]) + (insert "\n") + (send show-tracing-text change-style clickback-delta ell-start ell-end) + (send show-tracing-text set-clickback ell-start ell-end + (lambda (t x y) + (send show-tracing-text begin-edit-sequence) + (send show-tracing-text lock #f) + (let ([line-start (send show-tracing-text paragraph-start-position para)] + [line-end (send show-tracing-text paragraph-end-position para)]) + (send show-tracing-text delete line-start line-end #f) + (send show-tracing-text insert s line-start 'same #f)) + (send show-tracing-text lock #t) + (send show-tracing-text end-edit-sequence))))))])) + (send show-tracing-text lock #t) + (send show-tracing-text end-edit-sequence))) + + (super-new))) + + (define clickback-delta (make-object style-delta%)) + (send clickback-delta set-delta-foreground "BLUE") + (send clickback-delta set-delta 'change-underline #t) + + (define frame-mixin + (mixin (drscheme:frame:<%> drscheme:unit:frame<%>) () + (inherit get-current-tab) + (define show-tracing-menu-item #f) + (define tracing-visible? #f) + + (define/augment (on-tab-change old new) + (inner (void) on-tab-change old new) + (send show-tracing-canvas set-editor (send new get-tracing-text)) + (cond + [(eq? tracing-visible? (send new get-tracing-visible?)) + (void)] + [(send new get-tracing-visible?) + (show-tracing)] + [else + (hide-tracing)])) + + (define/override (add-show-menu-items show-menu) + (super add-show-menu-items show-menu) + (set! show-tracing-menu-item + (new menu-item% + (parent show-menu) + (label (string-constant tracing-show-tracing-window)) + (callback (lambda (x y) (toggle-tracing)))))) + + (define/public (show-tracing) + (set! tracing-visible? #t) + (send show-tracing-menu-item set-label (string-constant tracing-hide-tracing-window)) + (send dragable-parent begin-container-sequence) + (send dragable-parent change-children + (lambda (l) + (let ([without (remq show-tracing-canvas l)]) + (append without (list show-tracing-canvas))))) + (send dragable-parent set-percentages '(3/4 1/4)) + (send dragable-parent end-container-sequence)) + + (define/private (hide-tracing) + (set! tracing-visible? #f) + (send show-tracing-menu-item set-label (string-constant tracing-show-tracing-window)) + (send dragable-parent change-children + (lambda (l) + (remq show-tracing-canvas l)))) + + (define/private (toggle-tracing) + (if tracing-visible? + (hide-tracing) + (show-tracing))) + + (define dragable-parent #f) + (define show-tracing-parent-panel #f) + (define show-tracing-canvas #f) + + (define/override (make-root-area-container cls parent) + (set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent)) + (let ([root (make-object cls dragable-parent)]) + (set! show-tracing-canvas (new editor-canvas% + (parent dragable-parent) + (editor (send (get-current-tab) get-tracing-text)))) + (send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l))) + root)) + + (super-new)))) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index b53792251b..1bfaedf764 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -17,15 +17,11 @@ module browser threading seems wrong. scheme/path scheme/port scheme/list - (only-in mzlib/etc compose) string-constants framework mrlib/name-message mrlib/bitmap-label mrlib/include-bitmap - "drsig.ss" - "auto-language.ss" - "insert-large-letters.ss" mrlib/switchable-button mrlib/cache-image-snip mrlib/include-bitmap @@ -33,6 +29,9 @@ module browser threading seems wrong. net/sendurl net/url + "drsig.ss" + "auto-language.ss" + "insert-large-letters.ss" (prefix-in drscheme:arrow: "../arrow.ss") mred @@ -372,6 +371,8 @@ module browser threading seems wrong. (reset-highlighting) (inner (void) after-delete x y)) + (printf "creating a program editor mixin\n") (flush-output) + (apply super-make-object args))] [get-program-editor-mixin (λ () @@ -380,11 +381,11 @@ module browser threading seems wrong. [add-to-program-editor-mixin (λ (mixin) (drscheme:tools:only-in-phase 'drscheme:unit:add-to-program-editor-mixin 'phase1) - (set! program-editor-mixin (compose mixin program-editor-mixin)))]) + (let ([old program-editor-mixin]) + (set! program-editor-mixin (λ (x) (mixin (old x))))))]) (values get-program-editor-mixin add-to-program-editor-mixin))) - ;; this sends a message to it's frame when it gets the focus (define make-searchable-canvas% (λ (%) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index c956ee557c..37fbadc1af 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -1,50 +1,42 @@ #lang scheme (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 - mzlib/struct - drscheme/tool - mred - framework/private/bday - syntax/moddep - mrlib/cache-image-snip - compiler/embed - wxme/wxme - setup/dirs - - ;; this module is shared between the drscheme's namespace (so loaded here) - ;; and the user's namespace in the teaching languages - "private/set-result.ss" - - "stepper-language-interface.ss" - "debugger-language-interface.ss" - "run-teaching-program.ss" - stepper/private/shared - - (only-in test-engine/scheme-gui make-formatter) - (only-in test-engine/scheme-tests scheme-test-data error-handler test-format test-execute) - (lib "test-engine/test-display.scm") - ) + 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 + compiler/embed + wxme/wxme + setup/dirs + + ;; this module is shared between the drscheme's namespace (so loaded here) + ;; and the user's namespace in the teaching languages + "private/set-result.ss" + + "stepper-language-interface.ss" + "debugger-language-interface.ss" + "run-teaching-program.ss" + stepper/private/shared + + (only-in test-engine/scheme-gui make-formatter) + (only-in test-engine/scheme-tests scheme-test-data error-handler test-format test-execute) + (lib "test-engine/test-display.scm") + ) (provide tool@) - (define sc-tracing (string-constant tracing-enable-tracing)) - (define sc-show-tracing-window (string-constant tracing-show-tracing-window)) - (define sc-hide-tracing-window (string-constant tracing-hide-tracing-window)) - (define sc-tracing-nothing-to-show (string-constant tracing-tracing-nothing-to-show)) - - (define ellipses-cutoff 200) - (define o (current-output-port)) (define (oprintf . args) (apply fprintf o args)) @@ -55,18 +47,6 @@ (unit (import drscheme:tool^) (export drscheme:tool-exports^) - (define-local-member-name - get-tracing-text - show-tracing - tracing:add-line - tracing:rest) - (define tab-tracing<%> - (interface () - get-tracing-text - get-any-results? - tracing:add-line - tracing:reset)) - (define drs-eventspace (current-eventspace)) @@ -269,7 +249,7 @@ void)] [tracing (new check-box% (parent output-panel) - (label sc-tracing) + (label (string-constant tracing-enable-tracing)) (callback void))] [tps '()]) @@ -1127,61 +1107,7 @@ (define-values/invoke-unit et:stacktrace@ (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) - - (define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key))) - - (define (print-call-trace inferred-name original? src args improper? depth) - (when inferred-name - (let ([name (cond - [(identifier? inferred-name) (syntax-e inferred-name)] - [else (object-name inferred-name)])] - [rep (drscheme:rep:current-rep)]) - (when (and name rep) - (let ([canvas (send rep get-canvas)]) - (when canvas - (let* ([frame (send canvas get-top-level-window)] - [tab (send frame get-current-tab)]) - (when (is-a? tab tab-tracing<%>) - (let ([sp (open-output-string)]) - (let loop ([i depth]) - (unless (zero? i) - (display " " sp) - (loop (- i 1)))) - (fprintf sp "(") - (fprintf sp "~a" name) - (let loop ([args args]) - (cond - [(null? args) (void)] - [(and (null? (cdr args)) improper?) - (fprintf sp " . ") - (fprintf sp "~v" (car args))] - [else - (let ([arg (car args)]) - (fprintf sp " ") - (fprintf sp "~v" arg)) - (loop (cdr args))])) - (fprintf sp ")") - (let ([sema (make-semaphore)]) - ;; Disable breaks, so an exn handler can't - ;; grab the DrScheme eventspacae: - (parameterize-break #f - ;; Queue callback to write trace line --- - ;; low priority, so that infinite loops don't stop the user - ;; from clicking "Break" - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (lambda () - (send tab tracing:add-line (get-output-string sp)) - (semaphore-post sema)) - #f))) - ;; Wait for the line to get written, so that the - ;; trace output doesn't get too far behind (which - ;; matters, again, for infinite loops) - (semaphore-wait sema))))))))))) - - (define-values/invoke-unit tr:stacktrace@ - (import tr:stacktrace-imports^) (export (prefix tr: tr:stacktrace^))) - + ;; add-annotation : boolean (sexp -> value) -> sexp -> value ;; adds debugging and test coverage information to `sexp' and calls `oe' (define (add-annotation tracing? oe) @@ -1195,147 +1121,13 @@ (namespace-base-phase))] [tr-annotated (if tracing? - (tr:annotate (expand et-annotated)) + (drscheme:tracing:annotate (expand et-annotated)) et-annotated)]) tr-annotated))]) (oe annotated)))]) teaching-language-eval-handler)) - (define tab-tracing-mixin - (mixin (drscheme:unit:tab<%> drscheme:rep:context<%>) (tab-tracing<%>) - (inherit get-frame) - - (define tracing-visible? #f) - (define/public (set-tracing-visible? v?) (set! tracing-visible? v?)) - (define/public (get-tracing-visible?) tracing-visible?) - - (define/augment (clear-annotations) - (tracing:reset) - (inner (void) clear-annotations)) - - (define any-results? #f) - (define/public (get-any-results?) any-results?) - (define/public (tracing:reset) - (set! any-results? #f) - (send show-tracing-text lock #f) - (send show-tracing-text erase) - (send show-tracing-text auto-wrap #t) - (send show-tracing-text insert sc-tracing-nothing-to-show) - (send show-tracing-text lock #t)) - - (define show-tracing-text (new text:hide-caret/selection%)) - (define/public (get-tracing-text) show-tracing-text) - (send show-tracing-text lock #t) - - (define/public (tracing:add-line s) - (let ([old-any? any-results?]) - (set! any-results? #t) - (unless old-any? - (send (get-frame) show-tracing)) - (send show-tracing-text begin-edit-sequence) - (send show-tracing-text lock #f) - (unless old-any? - (send show-tracing-text erase) - (send show-tracing-text auto-wrap #f)) - (let ([insert - (lambda (s) - (send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))]) - (cond - [(<= (string-length s) ellipses-cutoff) - (insert s) - (insert "\n")] - [else - (insert (substring s 0 ellipses-cutoff)) - (insert " ") - (let ([ell-start (send show-tracing-text last-position)]) - (insert "...") - (let ([ell-end (send show-tracing-text last-position)]) - (let ([para (send show-tracing-text last-paragraph)]) - (insert "\n") - (send show-tracing-text change-style clickback-delta ell-start ell-end) - (send show-tracing-text set-clickback ell-start ell-end - (lambda (t x y) - (send show-tracing-text begin-edit-sequence) - (send show-tracing-text lock #f) - (let ([line-start (send show-tracing-text paragraph-start-position para)] - [line-end (send show-tracing-text paragraph-end-position para)]) - (send show-tracing-text delete line-start line-end #f) - (send show-tracing-text insert s line-start 'same #f)) - (send show-tracing-text lock #t) - (send show-tracing-text end-edit-sequence))))))])) - (send show-tracing-text lock #t) - (send show-tracing-text end-edit-sequence))) - - (super-new))) - - - (define frame-tracing-mixin - (mixin (drscheme:frame:<%> drscheme:unit:frame<%>) () - (inherit get-current-tab) - (define show-tracing-menu-item #f) - (define tracing-visible? #f) - - (define/augment (on-tab-change old new) - (inner (void) on-tab-change old new) - (send show-tracing-canvas set-editor (send new get-tracing-text)) - (cond - [(eq? tracing-visible? (send new get-tracing-visible?)) - (void)] - [(send new get-tracing-visible?) - (show-tracing)] - [else - (hide-tracing)])) - - (define/override (add-show-menu-items show-menu) - (super add-show-menu-items show-menu) - (set! show-tracing-menu-item - (new menu-item% - (parent show-menu) - (label sc-show-tracing-window) - (callback (lambda (x y) (toggle-tracing)))))) - - (define/public (show-tracing) - (set! tracing-visible? #t) - (send show-tracing-menu-item set-label sc-hide-tracing-window) - (send dragable-parent begin-container-sequence) - (send dragable-parent change-children - (lambda (l) - (let ([without (remq show-tracing-canvas l)]) - (append without (list show-tracing-canvas))))) - (send dragable-parent set-percentages '(3/4 1/4)) - (send dragable-parent end-container-sequence)) - - (define/private (hide-tracing) - (set! tracing-visible? #f) - (send show-tracing-menu-item set-label sc-show-tracing-window) - (send dragable-parent change-children - (lambda (l) - (remq show-tracing-canvas l)))) - - (define/private (toggle-tracing) - (if tracing-visible? - (hide-tracing) - (show-tracing))) - - (define dragable-parent #f) - (define show-tracing-parent-panel #f) - (define show-tracing-canvas #f) - - (define/override (make-root-area-container cls parent) - (set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent)) - (let ([root (make-object cls dragable-parent)]) - (set! show-tracing-canvas (new editor-canvas% - (parent dragable-parent) - (editor (send (get-current-tab) get-tracing-text)))) - (send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l))) - root)) - - (super-new))) - - (define clickback-delta (make-object style-delta%)) - (send clickback-delta set-delta-foreground "BLUE") - (send clickback-delta set-delta 'change-underline #t) - + ; ; @@ -1478,7 +1270,4 @@ (reader-module '(lib "htdp-beginner-reader.ss" "lang")) (stepper:supported #t) (stepper:enable-let-lifting #t) - (stepper:show-lambdas-as-lambdas #f))) - - (drscheme:get/extend:extend-unit-frame frame-tracing-mixin) - (drscheme:get/extend:extend-tab tab-tracing-mixin)))) + (stepper:show-lambdas-as-lambdas #f)))))) diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index d7c03eefa0..2b39494008 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -50,7 +50,7 @@ the settings above should match r5rs (check-top-of-repl) (generic-settings #f) - (generic-output #t #t #t) + (generic-output #t #t #t #t) (test-hash-bang) (test-error-after-definition) @@ -150,7 +150,7 @@ the settings above should match r5rs (check-top-of-repl) (generic-settings #f) - (generic-output #t #t #t) + (generic-output #t #t #t #t) (test-hash-bang) (test-error-after-definition) @@ -250,7 +250,7 @@ the settings above should match r5rs (check-top-of-repl) (generic-settings #t) - (generic-output #f #f #f) + (generic-output #f #f #f #f) (teaching-language-fraction-output) (test-hash-bang) @@ -415,7 +415,7 @@ the settings above should match r5rs (check-top-of-repl) (generic-settings #t) - (generic-output #t #f #f) + (generic-output #t #f #f #f) (teaching-language-fraction-output) (test-hash-bang) @@ -578,7 +578,7 @@ the settings above should match r5rs (check-top-of-repl) (generic-settings #t) - (generic-output #t #f #f) + (generic-output #t #f #f #f) (teaching-language-fraction-output) (test-hash-bang) @@ -738,7 +738,7 @@ the settings above should match r5rs (check-top-of-repl) (generic-settings #t) - (generic-output #t #f #f) + (generic-output #t #f #f #f) (teaching-language-fraction-output) (test-hash-bang) @@ -892,7 +892,7 @@ the settings above should match r5rs (check-top-of-repl) (generic-settings #t) - (generic-output #t #t #t) + (generic-output #t #t #t #f) (teaching-language-fraction-output) (test-hash-bang) @@ -1150,8 +1150,9 @@ the settings above should match r5rs "(eq? 'g 'G)" (if false/true? "true" "#t"))) -(define (generic-output list? quasi-quote? has-sharing?) - (let* ([drs (wait-for-drscheme-frame)] +(define (generic-output list? quasi-quote? has-sharing? has-print-printing?) + (let* ([plain-print-style (if has-print-printing? "print" "write")] + [drs (wait-for-drscheme-frame)] [expression (format "(define x (list 2))~n(list x x)")] [set-output-choice (lambda (option show-sharing pretty?) @@ -1193,9 +1194,9 @@ the settings above should match r5rs (clear-definitions drs) (type-in-definitions drs expression) - (test "print" 'off #t "((2) (2))") + (test plain-print-style 'off #t "((2) (2))") (when has-sharing? - (test "print" 'on #t "(#0=(2) #0#)")) + (test plain-print-style 'on #t "(#0=(2) #0#)")) (when quasi-quote? (test "Quasiquote" 'off #t "`((2) (2))") (when has-sharing? @@ -1224,11 +1225,11 @@ the settings above should match r5rs (case-lambda [(x) (member #\newline (string->list x))] [() "newlines in result (may need to make the window smaller)"])) - (test "print" #f #f + (test plain-print-style #f #f (case-lambda [(x) (not (member #\newline (string->list x)))] [() "no newlines in result"])) - (test "print" #f #t + (test plain-print-style #f #t (case-lambda [(x) (member #\newline (string->list x))] [() "newlines in result (may need to make the window smaller)"]))))