diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 4c8467653b..6b3e583047 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -52,7 +52,12 @@ TODO [-text<%> text<%>]) (define -text<%> - (interface () + (interface ((class->interface text%) + text:ports<%> + editor:file<%> + scheme:text<%> + color:text<%> + text:ports<%>) reset-highlighting highlight-errors highlight-errors/exn @@ -63,6 +68,8 @@ TODO get-user-namespace get-user-teachpack-cache set-user-teachpack-cache + + get-definitions-text kill-evaluation @@ -516,6 +523,7 @@ TODO (define definitions-text 'not-yet-set-definitions-text) (define/public (set-definitions-text dt) (set! definitions-text dt)) + (define/public (get-definitions-text) definitions-text) (unless (is-a? context context<%>) (error 'drscheme:rep:text% @@ -631,56 +639,50 @@ TODO (set! error-ranges locs) - (let ([defs - (let ([f (get-top-level-window)]) - (and f - (is-a? f drscheme:unit:frame<%>) - (send f get-definitions-text)))]) - - (for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs) - - (when color? - (let ([resets - (map (λ (loc) - (let* ([file (srcloc-source loc)] - [start (- (srcloc-position loc) 1)] - [span (srcloc-span loc)] - [finish (+ start span)]) - (send file highlight-range start finish error-color #f #f 'high))) - locs)]) - - (when (and defs error-arrows) - (let ([filtered-arrows - (remove-duplicate-error-arrows - (filter - (λ (arr) - (embedded-in? (car arr) defs)) - error-arrows))]) - (send defs set-error-arrows filtered-arrows))) - - (set! internal-reset-callback - (λ () - (set! error-ranges #f) - (when defs - (send defs set-error-arrows #f)) - (set! internal-reset-callback void) - (for-each (λ (x) (x)) resets))))) - - (let* ([first-loc (and (pair? locs) (car locs))] - [first-file (and first-loc (srcloc-source first-loc))] - [first-start (and first-loc (- (srcloc-position first-loc) 1))] - [first-span (and first-loc (srcloc-span first-loc))]) + (for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs) + + (when color? + (let ([resets + (map (λ (loc) + (let* ([file (srcloc-source loc)] + [start (- (srcloc-position loc) 1)] + [span (srcloc-span loc)] + [finish (+ start span)]) + (send file highlight-range start finish error-color #f #f 'high))) + locs)]) - (when first-loc - (let ([first-finish (+ first-start first-span)]) - (when (eq? first-file defs) ;; only move set the cursor in the defs window - (send first-file set-position first-start first-start)) - (send first-file scroll-to-position first-start #f first-finish))) + (when (and definitions-text error-arrows) + (let ([filtered-arrows + (remove-duplicate-error-arrows + (filter + (λ (arr) + (embedded-in? (car arr) definitions-text)) + error-arrows))]) + (send definitions-text set-error-arrows filtered-arrows))) - (for-each (λ (loc) (send (srcloc-source loc) end-edit-sequence)) locs) - - (when first-loc - (send first-file set-caret-owner (get-focus-snip) 'global)))))) + (set! internal-reset-callback + (λ () + (set! error-ranges #f) + (when definitions-text + (send definitions-text set-error-arrows #f)) + (set! internal-reset-callback void) + (for-each (λ (x) (x)) resets))))) + + (let* ([first-loc (and (pair? locs) (car locs))] + [first-file (and first-loc (srcloc-source first-loc))] + [first-start (and first-loc (- (srcloc-position first-loc) 1))] + [first-span (and first-loc (srcloc-span first-loc))]) + + (when first-loc + (let ([first-finish (+ first-start first-span)]) + (when (eq? first-file definitions-text) ;; only move set the cursor in the defs window + (send first-file set-position first-start first-start)) + (send first-file scroll-to-position first-start #f first-finish))) + + (for-each (λ (loc) (send (srcloc-source loc) end-edit-sequence)) locs) + + (when first-loc + (send first-file set-caret-owner (get-focus-snip) 'global))))) (define/public (reset-highlighting) (reset-error-ranges)) @@ -713,7 +715,13 @@ TODO ;; specialization ;; - (define/override (after-io-insertion) (send context ensure-rep-shown this)) + (define/override (after-io-insertion) + (let ([canvas (get-active-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (let ([tab (send definitions-text get-tab)]) + (when (eq? (send frame get-current-tab) tab) + (send context ensure-rep-shown this))))))) (define/augment (after-insert start len) (inner (void) after-insert start len) @@ -1050,12 +1058,7 @@ TODO (define/private init-evaluation-thread ; =Kernel= (λ () - (let ([default (preferences:get drscheme:language-configuration:settings-preferences-symbol)] - [frame (get-top-level-window)]) - (if frame - (let ([defs (send frame get-definitions-text)]) - (set! user-language-settings (send defs get-next-settings))) - (set! user-language-settings default))) + (set! user-language-settings (send definitions-text get-next-settings)) (set! user-custodian (make-custodian)) ; (custodian-limit-memory user-custodian 10000000 user-custodian) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index d80839d147..f9c7876b7f 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -1221,7 +1221,7 @@ module browser threading seems wrong. (when execute-menu-item (send execute-menu-item enable #f)) (send execute-button enable #f) - (send file-menu:create-new-tab-item enable #f) + ;(send file-menu:create-new-tab-item enable #f) (inner (void) disable-evaluation)) (define/public-final (enable-evaluation-in-tab tab) @@ -1232,7 +1232,7 @@ module browser threading seems wrong. (when execute-menu-item (send execute-menu-item enable #t)) (send execute-button enable #t) - (send file-menu:create-new-tab-item enable #t) + ;(send file-menu:create-new-tab-item enable #t) (inner (void) enable-evaluation)) (inherit set-label) diff --git a/collects/test-suite/tool.ss b/collects/test-suite/tool.ss index 0a9db3a05c..399313bcbb 100644 --- a/collects/test-suite/tool.ss +++ b/collects/test-suite/tool.ss @@ -135,7 +135,7 @@ ;; Require the test-case macro into every new namespace when a program is run. (define require-macro-mixin (mixin ((class->interface drscheme:rep:text%)) () - (inherit get-user-namespace get-canvas) + (inherit get-user-namespace get-definitions-text) #;((is-a?/c area<%>) . -> . (is-a?/c frame%)) ;; The frame containing the given area @@ -150,11 +150,11 @@ ;; Overriden to reset test case boxes (define/override (reset-highlighting) (super reset-highlighting) - (let ([text (send (find-frame (get-canvas)) get-definitions-text)]) + (let ([defs-text (get-definitions-text)]) ;(if (send text delay-reset) ; (send text delay-reset false) ; (send text reset-test-case-boxes)))) - (send text reset-test-case-boxes))) + (send defs-text reset-test-case-boxes))) #;(-> void) ;; Called when the program is execute to reset the rep:text