moved the warning into the frame (out of the interactions window)
svn: r15557
This commit is contained in:
Robby Findler
parent
287bbaf14c
commit
47a473c885
|
|
@ -138,14 +138,16 @@ TODO
|
|||
insert-prompt
|
||||
get-context))
|
||||
|
||||
|
||||
(define context<%>
|
||||
(interface ()
|
||||
ensure-rep-shown ;; (interactions-text -> void)
|
||||
;; make the rep visible in the frame
|
||||
|
||||
needs-execution ;; (-> boolean)
|
||||
;; ask if things have changed that would mean the repl is out
|
||||
;; of sync with the program being executed in it.
|
||||
repl-submit-happened ;; (-> boolean)
|
||||
;; notify the context that an evaluation is about to
|
||||
;; happen in the REPL (so it can show a warning about
|
||||
;; the language/etc is out of sync if neccessary).
|
||||
|
||||
enable-evaluation ;; (-> void)
|
||||
;; make the context enable all methods of evaluation
|
||||
|
|
@ -895,8 +897,7 @@ TODO
|
|||
(end-edit-sequence)
|
||||
(when locked? (lock #t))))
|
||||
|
||||
(field (already-warned? #f)
|
||||
(show-no-user-evaluation-message? #t))
|
||||
(field (show-no-user-evaluation-message? #t))
|
||||
|
||||
;; use this to be able to kill the evaluator without the popup dialog
|
||||
(define/public (set-show-no-user-evaluation-message? b)
|
||||
|
|
@ -988,13 +989,7 @@ TODO
|
|||
[lst (last old-regions)])
|
||||
(reset-regions (append abl (list (list (list-ref lst 0) (last-position))))))
|
||||
|
||||
(let ([needs-execution (send context needs-execution)])
|
||||
(when (if (preferences:get 'drscheme:execute-warning-once)
|
||||
(and (not already-warned?)
|
||||
needs-execution)
|
||||
needs-execution)
|
||||
(set! already-warned? #t)
|
||||
(insert-warning needs-execution)))
|
||||
(send context repl-submit-happened)
|
||||
|
||||
;; lets us know we are done with this one interaction
|
||||
;; (since there may be multiple expressions at the prompt)
|
||||
|
|
@ -1607,7 +1602,6 @@ TODO
|
|||
|
||||
(set! setting-up-repl? #f)
|
||||
|
||||
(set! already-warned? #f)
|
||||
(reset-regions (list (list (last-position) (last-position))))
|
||||
(set-unread-start-point (last-position))
|
||||
(set-insertion-point (last-position))
|
||||
|
|
|
|||
|
|
@ -600,6 +600,15 @@ module browser threading seems wrong.
|
|||
[execute-settings (preferences:get drscheme:language-configuration:settings-preferences-symbol)]
|
||||
[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 (set-next-settings _next-settings [update-prefs? #t])
|
||||
|
|
@ -642,11 +651,6 @@ module browser threading seems wrong.
|
|||
(define/pubment (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?)
|
||||
(let ([execute-lang (drscheme:language-configuration:language-settings-language execute-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))))))
|
||||
|
||||
(define/pubment (set-needs-execution-message msg)
|
||||
(set! needs-execution-state msg))
|
||||
(set-needs-execution-state! msg))
|
||||
(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)
|
||||
(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))
|
||||
(define/pubment (already-warned?)
|
||||
already-warned-state)
|
||||
|
|
@ -676,12 +681,12 @@ module browser threading seems wrong.
|
|||
(define/augment (after-insert x y)
|
||||
(unless ignore-edits?
|
||||
(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))
|
||||
(define/augment (after-delete x y)
|
||||
(unless ignore-edits?
|
||||
(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))
|
||||
|
||||
(define/override (is-special-first-line? l)
|
||||
|
|
@ -1229,6 +1234,21 @@ module browser threading seems wrong.
|
|||
(send frame enable-evaluation-in-tab this))
|
||||
(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)
|
||||
(let ([filename (send defs get-filename)])
|
||||
(if (and (path? filename)
|
||||
|
|
@ -1236,8 +1256,6 @@ module browser threading seems wrong.
|
|||
(let-values ([(base _1 _2) (split-path (normalize-path filename))])
|
||||
base)
|
||||
#f)))
|
||||
(define/public (needs-execution)
|
||||
(send defs needs-execution))
|
||||
|
||||
(define/pubment (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-revert-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
|
||||
|
|
@ -1714,9 +1765,10 @@ module browser threading seems wrong.
|
|||
(alignment '(left center))
|
||||
(stretchable-width #f))]
|
||||
[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%
|
||||
'drscheme:logging-size-percentage)
|
||||
[parent planet-status-outer-panel])]
|
||||
[parent execute-warning-outer-panel])]
|
||||
[trans-outer-panel (new vertical-panel% [parent logger-outer-panel])]
|
||||
[root (make-object cls trans-outer-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-panel (new vertical-panel% [parent logger-parent-panel]))
|
||||
(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%
|
||||
(parent trans-outer-panel)
|
||||
(stretchable-height #f)))
|
||||
|
|
@ -2737,7 +2796,7 @@ module browser threading seems wrong.
|
|||
(on-tab-change old-tab current-tab)
|
||||
(send tab update-log)
|
||||
(send tab update-planet-status)
|
||||
|
||||
(send tab update-execute-warning-gui)
|
||||
(restore-visible-tab-regions)
|
||||
(for-each (λ (defs-canvas) (send defs-canvas refresh))
|
||||
definitions-canvases)
|
||||
|
|
@ -4004,6 +4063,41 @@ module browser threading seems wrong.
|
|||
(set! newest-frame this)
|
||||
(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)))))))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user