suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

moved the warning into the frame (out of the interactions window)

Browse Source 
svn: r15557
This commit is contained in:
Robby Findler 2009-07-25 01:06:22 +00:00
parent 287bbaf14c
commit 47a473c885
2 changed files with 115 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/drscheme/private/rep.ss
View File

@ -138,14 +138,16 @@ TODO
insert-prompt insert-prompt
get-context)) get-context))
(define context<%> (define context<%>
(interface () (interface ()
ensure-rep-shown ;; (interactions-text -> void) ensure-rep-shown ;; (interactions-text -> void)
;; make the rep visible in the frame ;; make the rep visible in the frame
needs-execution ;; (-> boolean) repl-submit-happened ;; (-> boolean)
;; ask if things have changed that would mean the repl is out ;; notify the context that an evaluation is about to
;; of sync with the program being executed in it. ;; happen in the REPL (so it can show a warning about
;; the language/etc is out of sync if neccessary).
enable-evaluation ;; (-> void) enable-evaluation ;; (-> void)
;; make the context enable all methods of evaluation ;; make the context enable all methods of evaluation
@ -895,8 +897,7 @@ TODO
(end-edit-sequence) (end-edit-sequence)
(when locked? (lock #t)))) (when locked? (lock #t))))
(field (already-warned? #f) (field (show-no-user-evaluation-message? #t))
(show-no-user-evaluation-message? #t))
;; use this to be able to kill the evaluator without the popup dialog ;; use this to be able to kill the evaluator without the popup dialog
(define/public (set-show-no-user-evaluation-message? b) (define/public (set-show-no-user-evaluation-message? b)
@ -988,13 +989,7 @@ TODO
[lst (last old-regions)]) [lst (last old-regions)])
(reset-regions (append abl (list (list (list-ref lst 0) (last-position)))))) (reset-regions (append abl (list (list (list-ref lst 0) (last-position))))))
(let ([needs-execution (send context needs-execution)]) (send context repl-submit-happened)
(when (if (preferences:get 'drscheme:execute-warning-once)
(and (not already-warned?)
needs-execution)
needs-execution)
(set! already-warned? #t)
(insert-warning needs-execution)))
;; lets us know we are done with this one interaction ;; lets us know we are done with this one interaction
;; (since there may be multiple expressions at the prompt) ;; (since there may be multiple expressions at the prompt)
@ -1607,7 +1602,6 @@ TODO
(set! setting-up-repl? #f) (set! setting-up-repl? #f)
(set! already-warned? #f)
(reset-regions (list (list (last-position) (last-position)))) (reset-regions (list (list (last-position) (last-position))))
(set-unread-start-point (last-position)) (set-unread-start-point (last-position))
(set-insertion-point (last-position)) (set-insertion-point (last-position))

122
collects/drscheme/private/unit.ss
View File

@ -600,6 +600,15 @@ module browser threading seems wrong.
[execute-settings (preferences:get drscheme:language-configuration:settings-preferences-symbol)] [execute-settings (preferences:get drscheme:language-configuration:settings-preferences-symbol)]
[next-settings execute-settings]) [next-settings execute-settings])
(define/private (set-needs-execution-state! s) (set! needs-execution-state s))
;; get-needs-execution-message : -> (or/c string #f)
;; returns the current warning message if "Run" should be clicked (ie, if the
;; state of the REPL is out of sync with drscheme).
(define/public (get-needs-execution-message)
(or (and (not (this-and-next-language-the-same?))
(string-constant needs-execute-language-changed))
needs-execution-state))
(define/pubment (get-next-settings) next-settings) (define/pubment (get-next-settings) next-settings)
(define/pubment (set-next-settings _next-settings [update-prefs? #t]) (define/pubment (set-next-settings _next-settings [update-prefs? #t])
@ -642,11 +651,6 @@ module browser threading seems wrong.
(define/pubment (after-set-next-settings s) (define/pubment (after-set-next-settings s)
(inner (void) after-set-next-settings s)) (inner (void) after-set-next-settings s))
(define/public (needs-execution)
(or needs-execution-state
(and (not (this-and-next-language-the-same?))
(string-constant needs-execute-language-changed))))
(define/public (this-and-next-language-the-same?) (define/public (this-and-next-language-the-same?)
(let ([execute-lang (drscheme:language-configuration:language-settings-language execute-settings)] (let ([execute-lang (drscheme:language-configuration:language-settings-language execute-settings)]
[next-lang (drscheme:language-configuration:language-settings-language next-settings)]) [next-lang (drscheme:language-configuration:language-settings-language next-settings)])
@ -658,12 +662,13 @@ module browser threading seems wrong.
(drscheme:language-configuration:language-settings-settings next-settings)))))) (drscheme:language-configuration:language-settings-settings next-settings))))))
(define/pubment (set-needs-execution-message msg) (define/pubment (set-needs-execution-message msg)
(set! needs-execution-state msg)) (set-needs-execution-state! msg))
(define/pubment (teachpack-changed) (define/pubment (teachpack-changed)
(set! needs-execution-state (string-constant needs-execute-teachpack-changed))) (set-needs-execution-state! (string-constant needs-execute-teachpack-changed)))
(define/pubment (just-executed) (define/pubment (just-executed)
(set! execute-settings next-settings) (set! execute-settings next-settings)
(set! needs-execution-state #f) (set-needs-execution-state! #f)
(send tab clear-execution-state)
(set! already-warned-state #f)) (set! already-warned-state #f))
(define/pubment (already-warned?) (define/pubment (already-warned?)
already-warned-state) already-warned-state)
@ -676,12 +681,12 @@ module browser threading seems wrong.
(define/augment (after-insert x y) (define/augment (after-insert x y)
(unless ignore-edits? (unless ignore-edits?
(set! really-modified? #t) (set! really-modified? #t)
(set! needs-execution-state (string-constant needs-execute-defns-edited))) (set-needs-execution-state! (string-constant needs-execute-defns-edited)))
(inner (void) after-insert x y)) (inner (void) after-insert x y))
(define/augment (after-delete x y) (define/augment (after-delete x y)
(unless ignore-edits? (unless ignore-edits?
(set! really-modified? #t) (set! really-modified? #t)
(set! needs-execution-state (string-constant needs-execute-defns-edited))) (set-needs-execution-state! (string-constant needs-execute-defns-edited)))
(inner (void) after-delete x y)) (inner (void) after-delete x y))
(define/override (is-special-first-line? l) (define/override (is-special-first-line? l)
@ -1229,6 +1234,21 @@ module browser threading seems wrong.
(send frame enable-evaluation-in-tab this)) (send frame enable-evaluation-in-tab this))
(define/public (get-enabled) enabled?) (define/public (get-enabled) enabled?)
;; current-execute-warning is a snapshot of the needs-execution-message
;; that is taken each time repl submission happens, and it gets reset
;; when "Run" is clicked.
(define current-execute-warning #f)
(define/pubment (repl-submit-happened)
(set! current-execute-warning (send defs get-needs-execution-message))
(update-execute-warning-gui))
(define/public (get-current-execute-warning) current-execute-warning)
(define/public (clear-execution-state)
(set! current-execute-warning #f)
(update-execute-warning-gui))
(define/public (update-execute-warning-gui)
(when (is-current-tab?)
(send frame show/hide-warning-message (get-current-execute-warning))))
(define/public (get-directory) (define/public (get-directory)
(let ([filename (send defs get-filename)]) (let ([filename (send defs get-filename)])
(if (and (path? filename) (if (and (path? filename)
@ -1236,8 +1256,6 @@ module browser threading seems wrong.
(let-values ([(base _1 _2) (split-path (normalize-path filename))]) (let-values ([(base _1 _2) (split-path (normalize-path filename))])
base) base)
#f))) #f)))
(define/public (needs-execution)
(send defs needs-execution))
(define/pubment (can-close?) (define/pubment (can-close?)
(and (send defs can-close?) (and (send defs can-close?)
@ -1396,7 +1414,40 @@ module browser threading seems wrong.
file-menu:get-save-as-item file-menu:get-save-as-item
file-menu:get-revert-item file-menu:get-revert-item
file-menu:get-print-item) file-menu:get-print-item)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; execute warning
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define execute-warning-panel #f)
(define execute-warning-parent-panel #f)
(define execute-warning-canvas #f)
(define/public-final (show/hide-warning-message msg)
(when (and execute-warning-parent-panel
execute-warning-panel)
(cond
[msg
(cond
[execute-warning-canvas
(send execute-warning-canvas set-message msg)]
[else
(set! execute-warning-canvas
(new execute-warning-canvas%
[parent execute-warning-panel]
[message msg]))])
(send execute-warning-parent-panel
change-children
(λ (l) (append (remq execute-warning-panel l)
(list execute-warning-panel))))]
[else
(when execute-warning-canvas
(send execute-warning-parent-panel
change-children
(λ (l) (remq execute-warning-panel l)))
(send execute-warning-canvas set-message #f))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; logging ;; logging
@ -1714,9 +1765,10 @@ module browser threading seems wrong.
(alignment '(left center)) (alignment '(left center))
(stretchable-width #f))] (stretchable-width #f))]
[planet-status-outer-panel (new vertical-panel% [parent _module-browser-parent-panel])] [planet-status-outer-panel (new vertical-panel% [parent _module-browser-parent-panel])]
[execute-warning-outer-panel (new vertical-panel% [parent planet-status-outer-panel])]
[logger-outer-panel (new (make-two-way-prefs-dragable-panel% panel:vertical-dragable% [logger-outer-panel (new (make-two-way-prefs-dragable-panel% panel:vertical-dragable%
'drscheme:logging-size-percentage) 'drscheme:logging-size-percentage)
[parent planet-status-outer-panel])] [parent execute-warning-outer-panel])]
[trans-outer-panel (new vertical-panel% [parent logger-outer-panel])] [trans-outer-panel (new vertical-panel% [parent logger-outer-panel])]
[root (make-object cls trans-outer-panel)]) [root (make-object cls trans-outer-panel)])
(set! module-browser-parent-panel _module-browser-parent-panel) (set! module-browser-parent-panel _module-browser-parent-panel)
@ -1725,6 +1777,13 @@ module browser threading seems wrong.
(set! logger-parent-panel logger-outer-panel) (set! logger-parent-panel logger-outer-panel)
(set! logger-panel (new vertical-panel% [parent logger-parent-panel])) (set! logger-panel (new vertical-panel% [parent logger-parent-panel]))
(send logger-parent-panel change-children (lambda (x) (remq logger-panel x))) (send logger-parent-panel change-children (lambda (x) (remq logger-panel x)))
(set! execute-warning-parent-panel execute-warning-outer-panel)
(set! execute-warning-panel (new vertical-panel%
[parent execute-warning-parent-panel]
[stretchable-height #f]))
(send execute-warning-parent-panel change-children (λ (l) (remq execute-warning-panel l)))
(set! transcript-parent-panel (new horizontal-panel% (set! transcript-parent-panel (new horizontal-panel%
(parent trans-outer-panel) (parent trans-outer-panel)
(stretchable-height #f))) (stretchable-height #f)))
@ -2737,7 +2796,7 @@ module browser threading seems wrong.
(on-tab-change old-tab current-tab) (on-tab-change old-tab current-tab)
(send tab update-log) (send tab update-log)
(send tab update-planet-status) (send tab update-planet-status)
(send tab update-execute-warning-gui)
(restore-visible-tab-regions) (restore-visible-tab-regions)
(for-each (λ (defs-canvas) (send defs-canvas refresh)) (for-each (λ (defs-canvas) (send defs-canvas refresh))
definitions-canvases) definitions-canvases)
@ -4004,6 +4063,41 @@ module browser threading seems wrong.
(set! newest-frame this) (set! newest-frame this)
(send definitions-canvas focus))) (send definitions-canvas focus)))
(define execute-warning-canvas%
(class canvas%
(inherit stretchable-height get-dc get-client-size min-height)
(init-field message)
(define/public (set-message _msg) (set! message _msg))
(define/override (on-paint)
(let ([dc (get-dc)])
(let-values ([(w h) (get-client-size)])
(send dc set-pen "yellow" 1 'solid)
(send dc set-brush "yellow" 'solid)
(send dc draw-rectangle 0 0 w h)
(when message
(let* ([base normal-control-font]
[face (send base get-face)])
(if face
(send dc set-font (send the-font-list find-or-create-font
(send base get-point-size)
face
(send base get-family)
(send base get-style)
'bold))
(send dc set-font (send the-font-list find-or-create-font
(send base get-point-size)
(send base get-family)
(send base get-style)
'bold))))
(let-values ([(tw th _1 _2) (send dc get-text-extent message)])
(send dc draw-text message
(floor (- (/ w 2) (/ tw 2)))
(floor (- (/ h 2) (/ th 2)))))))))
(super-new)
(stretchable-height #f)
(let-values ([(w h d a) (send (get-dc) get-text-extent "Xy")])
(min-height (+ 4 (floor (inexact->exact h)))))))
; ;
; ;