adjust drracket frame startup to conform to new checks
I don't think that there was a bug behind this change. There may have been and it is probably now easier to reason about this code than it was before, but I think that this code was probably using object?, not checking directly with undefined) properly.
This commit is contained in:
Robby Findler
Matthew Flatt
parent
7f7428b1e6
commit
f8813474d4
|
|
@ -1359,7 +1359,7 @@
|
|||
(define frame-mixin
|
||||
(mixin (drracket:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:size-pref<%>)
|
||||
(drracket:unit:frame<%>)
|
||||
(init filename)
|
||||
(init-field filename)
|
||||
(inherit set-label-prefix get-show-menu
|
||||
get-menu%
|
||||
get-area-container
|
||||
|
|
@ -2483,28 +2483,29 @@
|
|||
|
||||
(update-shown)
|
||||
|
||||
;; with-handlers prevents bad calls to set-percentages
|
||||
;; might still leave GUI in bad state, however.
|
||||
(with-handlers ([exn:fail? (λ (x) (void))])
|
||||
(send resizable-panel set-percentages
|
||||
(let loop ([canvases orig-canvases]
|
||||
[percentages orig-percentages])
|
||||
(cond
|
||||
[(null? canvases)
|
||||
(error 'split "couldn't split; didn't find canvas")]
|
||||
[(null? percentages)
|
||||
(error 'split "wrong number of percentages: ~s ~s"
|
||||
orig-percentages
|
||||
(send resizable-panel get-children))]
|
||||
[else (let ([canvas (car canvases)])
|
||||
(if (eq? canvas-to-be-split canvas)
|
||||
(list* (/ (car percentages) 2)
|
||||
(/ (car percentages) 2)
|
||||
(cdr percentages))
|
||||
(cons
|
||||
(car percentages)
|
||||
(loop (cdr canvases)
|
||||
(cdr percentages)))))]))))
|
||||
(let ([new-percentages
|
||||
(let loop ([canvases orig-canvases]
|
||||
[percentages orig-percentages])
|
||||
(cond
|
||||
[(null? canvases)
|
||||
(error 'split "couldn't split; didn't find canvas")]
|
||||
[(null? percentages)
|
||||
(error 'split "wrong number of percentages: ~s ~s"
|
||||
orig-percentages
|
||||
(send resizable-panel get-children))]
|
||||
[else (let ([canvas (car canvases)])
|
||||
(if (eq? canvas-to-be-split canvas)
|
||||
(list* (/ (car percentages) 2)
|
||||
(/ (car percentages) 2)
|
||||
(cdr percentages))
|
||||
(cons
|
||||
(car percentages)
|
||||
(loop (cdr canvases)
|
||||
(cdr percentages)))))]))])
|
||||
;; with-handlers prevents bad calls to set-percentages
|
||||
;; might still leave GUI in bad state, however.
|
||||
(with-handlers ([exn:fail? (λ (x) (void))])
|
||||
(send resizable-panel set-percentages new-percentages)))
|
||||
|
||||
(set-visible-region new-canvas ox oy ow oh cursor-y)
|
||||
(set-visible-region canvas-to-be-split ox oy ow oh cursor-y)
|
||||
|
|
@ -2889,18 +2890,9 @@
|
|||
|
||||
(define/override (get-editor) definitions-text)
|
||||
(define/override (get-canvas)
|
||||
(initialize-definitions-canvas)
|
||||
(initialize-gui)
|
||||
definitions-canvas)
|
||||
|
||||
(define (create-definitions-canvas)
|
||||
(new (drracket:get/extend:get-definitions-canvas)
|
||||
[parent resizable-panel]
|
||||
[editor definitions-text]))
|
||||
|
||||
(define/private (initialize-definitions-canvas)
|
||||
(unless definitions-canvas
|
||||
(set! definitions-canvas (create-definitions-canvas))))
|
||||
|
||||
;; wire the definitions text to the interactions text and initialize it.
|
||||
(define/private (init-definitions-text tab)
|
||||
(let ([defs (send tab get-defs)]
|
||||
|
|
@ -4405,7 +4397,29 @@
|
|||
;
|
||||
;
|
||||
|
||||
(define definitions-canvas #f)
|
||||
(define resizable-panel 'uninit-resizable-panel)
|
||||
(define button-panel 'uninit-button-panel)
|
||||
(define toolbar/rest-panel 'uninit-toolbar/rest-panel)
|
||||
(define top-outer-panel 'uninit-top-outer-panel)
|
||||
(define top-panel 'uninit-top-panel)
|
||||
(define name-panel 'uninit-name-panel)
|
||||
(define tabs-panel 'uninit-tabs-panel)
|
||||
(define func-defs-canvas 'uninit-func-defs-canvas)
|
||||
(define definitions-canvases 'uninit-definitions-canvases)
|
||||
(define interactions-canvas 'uninit-interactions-canvas)
|
||||
(define interactions-canvases 'uninit-interactions-canvases)
|
||||
(define break-button 'unint-break-button)
|
||||
(define execute-button 'unint-execute-button)
|
||||
(define panel-with-tabs 'uninit-panel-with-tabs)
|
||||
(define bug-icon 'uninit-bug-icon)
|
||||
(define language-message 'uninit-language-message)
|
||||
(define running-canvas 'uninit-running-canvas)
|
||||
(define color-status-canvas 'uninit-color-status-canvas)
|
||||
|
||||
(define teachpack-items null)
|
||||
|
||||
|
||||
(define definitions-canvas 'uninit-definitions-canvas)
|
||||
(define definitions-text (new (drracket:get/extend:get-definitions-text)))
|
||||
|
||||
;; tabs : (listof tab)
|
||||
|
|
@ -4433,13 +4447,6 @@
|
|||
1
|
||||
0))))
|
||||
|
||||
(super-new
|
||||
[filename filename]
|
||||
[style '(toolbar-button fullscreen-button)]
|
||||
[size-preferences-key 'drracket:window-size]
|
||||
[position-preferences-key 'drracket:window-position])
|
||||
|
||||
(initialize-menus)
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -4460,45 +4467,12 @@
|
|||
; ; ;
|
||||
|
||||
|
||||
(define toolbar/rest-panel (new vertical-panel% [parent (get-area-container)]))
|
||||
|
||||
;; most contain only top-panel (or nothing)
|
||||
(define top-outer-panel (new horizontal-panel%
|
||||
[parent toolbar/rest-panel]
|
||||
[alignment '(right top)]
|
||||
[stretchable-height #f]))
|
||||
|
||||
[define top-panel (make-object horizontal-panel% top-outer-panel)]
|
||||
[define name-panel (new horizontal-panel%
|
||||
(parent top-panel)
|
||||
(alignment '(left center))
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f))]
|
||||
(define panel-with-tabs (new vertical-panel%
|
||||
(parent (get-definitions/interactions-panel-parent))))
|
||||
(define tabs-panel (new tab-panel%
|
||||
(font small-control-font)
|
||||
(parent panel-with-tabs)
|
||||
(stretchable-height #f)
|
||||
(style '(deleted no-border))
|
||||
(choices '("first name"))
|
||||
(callback (λ (x y)
|
||||
(let ([sel (send tabs-panel get-selection)])
|
||||
(when sel
|
||||
(change-to-nth-tab sel)))))))
|
||||
[define resizable-panel (new (if (preferences:get 'drracket:defs/ints-horizontal)
|
||||
horizontal-dragable/def-int%
|
||||
vertical-dragable/def-int%)
|
||||
(unit-frame this)
|
||||
(parent panel-with-tabs))]
|
||||
|
||||
(initialize-definitions-canvas)
|
||||
[define definitions-canvases (list definitions-canvas)]
|
||||
[define interactions-canvas (new (drracket:get/extend:get-interactions-canvas)
|
||||
(parent resizable-panel)
|
||||
(editor interactions-text))]
|
||||
[define interactions-canvases (list interactions-canvas)]
|
||||
|
||||
(define color-valid? #t)
|
||||
(define/public (set-color-status! v?)
|
||||
(when color-status-canvas
|
||||
(set! color-valid? v?)
|
||||
(send color-status-canvas refresh-now)))
|
||||
|
||||
(define/public (get-definitions-canvases)
|
||||
;; before definition, just return null
|
||||
|
|
@ -4511,79 +4485,13 @@
|
|||
interactions-canvases
|
||||
null))
|
||||
|
||||
(define/public (get-definitions-canvas) definitions-canvas)
|
||||
(define/public (get-definitions-canvas)
|
||||
(unless (object? definitions-canvas)
|
||||
(error 'get-definitions-canvas
|
||||
"cannot call this method too early in the class initialization process"))
|
||||
definitions-canvas)
|
||||
(define/public (get-interactions-canvas) interactions-canvas)
|
||||
|
||||
(set! save-button
|
||||
(new switchable-button%
|
||||
[parent top-panel]
|
||||
[callback (λ (x) (when definitions-text
|
||||
(save)
|
||||
(send definitions-canvas focus)))]
|
||||
[bitmap save-bitmap]
|
||||
[alternate-bitmap small-save-bitmap]
|
||||
[label (string-constant save-button-label)]))
|
||||
(register-toolbar-button save-button)
|
||||
|
||||
(set! name-message (new drs-name-message% [parent name-panel]))
|
||||
(send name-message stretchable-width #t)
|
||||
(send name-message set-allow-shrinking 160)
|
||||
[define teachpack-items null]
|
||||
[define break-button (void)]
|
||||
[define execute-button (void)]
|
||||
[define button-panel (new panel:horizontal-discrete-sizes%
|
||||
[parent top-panel]
|
||||
[stretchable-width #t]
|
||||
[alignment '(right center)])]
|
||||
(define/public (get-execute-button) execute-button)
|
||||
(define/public (get-break-button) break-button)
|
||||
(define/public (get-button-panel) button-panel)
|
||||
|
||||
(inherit get-info-panel)
|
||||
|
||||
(define color-status-canvas
|
||||
(let ()
|
||||
(define on-string "()")
|
||||
(define color-status-canvas
|
||||
(new canvas%
|
||||
[parent (get-info-panel)]
|
||||
[style '(transparent)]
|
||||
[stretchable-width #f]
|
||||
[paint-callback
|
||||
(λ (c dc)
|
||||
(when (number? th)
|
||||
(unless color-valid?
|
||||
(let-values ([(cw ch) (send c get-client-size)])
|
||||
(send dc set-font small-control-font)
|
||||
(send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))]))
|
||||
(define-values (tw th ta td)
|
||||
(send (send color-status-canvas get-dc) get-text-extent
|
||||
on-string small-control-font))
|
||||
(send color-status-canvas min-width (inexact->exact (ceiling tw)))
|
||||
color-status-canvas))
|
||||
(define color-valid? #t)
|
||||
(define/public (set-color-status! v?)
|
||||
(when color-status-canvas
|
||||
(set! color-valid? v?)
|
||||
(send color-status-canvas refresh-now)))
|
||||
|
||||
(define running-canvas
|
||||
(new running-canvas% [parent (get-info-panel)]))
|
||||
|
||||
(define bug-icon
|
||||
(let* ([info-panel (get-info-panel)]
|
||||
[btn
|
||||
(new switchable-button%
|
||||
[parent info-panel]
|
||||
[callback (λ (x) (show-saved-bug-reports-window))]
|
||||
[bitmap very-small-planet-bitmap]
|
||||
[vertical-tight? #t]
|
||||
[label (string-constant show-planet-contract-violations)])])
|
||||
(send btn set-label-visible #f)
|
||||
(send info-panel change-children
|
||||
(λ (l)
|
||||
(cons btn (remq* (list btn) l))))
|
||||
btn))
|
||||
(define/private (set-bug-label v)
|
||||
(if (null? v)
|
||||
(send bug-icon show #f)
|
||||
|
|
@ -4594,77 +4502,190 @@
|
|||
'drracket:saved-bug-reports
|
||||
(λ (p v)
|
||||
(set-bug-label v))))
|
||||
|
||||
(define/public (get-execute-button) execute-button)
|
||||
(define/public (get-break-button) break-button)
|
||||
(define/public (get-button-panel) button-panel)
|
||||
|
||||
[define func-defs-canvas (new func-defs-canvas%
|
||||
(parent name-panel)
|
||||
(frame this))]
|
||||
|
||||
(inherit get-info-panel get-label)
|
||||
|
||||
(set! execute-button
|
||||
(new switchable-button%
|
||||
[parent button-panel]
|
||||
[callback (λ (x) (execute-callback))]
|
||||
[bitmap execute-bitmap]
|
||||
[label (string-constant execute-button-label)]))
|
||||
(register-toolbar-button execute-button #:number 100)
|
||||
|
||||
(set! break-button
|
||||
(new switchable-button%
|
||||
[parent button-panel]
|
||||
[callback (λ (x) (send current-tab break-callback))]
|
||||
[bitmap break-bitmap]
|
||||
[label (string-constant break-button-label)]))
|
||||
(register-toolbar-button break-button #:number 101)
|
||||
|
||||
(send top-panel change-children
|
||||
(λ (l)
|
||||
(list name-panel save-button button-panel)))
|
||||
|
||||
(send top-panel stretchable-height #f)
|
||||
(inherit get-label)
|
||||
(let ([m (send definitions-canvas get-editor)])
|
||||
(set-save-init-shown?
|
||||
(and m (send m is-modified?))))
|
||||
|
||||
(define language-message
|
||||
(let* ([info-panel (get-info-panel)]
|
||||
[p (new vertical-panel%
|
||||
[parent info-panel]
|
||||
[alignment '(left center)])]
|
||||
[language-message (new language-label-message% [parent p] [frame this])])
|
||||
(send info-panel change-children
|
||||
(define/private (initialize-gui)
|
||||
(unless (object? top-outer-panel)
|
||||
(set! toolbar/rest-panel (new vertical-panel% [parent (get-area-container)]))
|
||||
|
||||
;; most contain only top-panel (or nothing)
|
||||
(set! top-outer-panel (new horizontal-panel%
|
||||
[parent toolbar/rest-panel]
|
||||
[alignment '(right top)]
|
||||
[stretchable-height #f]))
|
||||
|
||||
(set! top-panel (make-object horizontal-panel% top-outer-panel))
|
||||
(set! name-panel (new horizontal-panel%
|
||||
(parent top-panel)
|
||||
(alignment '(left center))
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)))
|
||||
(set! panel-with-tabs (new vertical-panel%
|
||||
(parent (get-definitions/interactions-panel-parent))))
|
||||
(set! tabs-panel (new tab-panel%
|
||||
(font small-control-font)
|
||||
(parent panel-with-tabs)
|
||||
(stretchable-height #f)
|
||||
(style '(deleted no-border))
|
||||
(choices '("first name"))
|
||||
(callback (λ (x y)
|
||||
(let ([sel (send tabs-panel get-selection)])
|
||||
(when sel
|
||||
(change-to-nth-tab sel)))))))
|
||||
(set! resizable-panel (new (if (preferences:get 'drracket:defs/ints-horizontal)
|
||||
horizontal-dragable/def-int%
|
||||
vertical-dragable/def-int%)
|
||||
(unit-frame this)
|
||||
(parent panel-with-tabs)))
|
||||
|
||||
(set! definitions-canvas (new (drracket:get/extend:get-definitions-canvas)
|
||||
[parent resizable-panel]
|
||||
[editor definitions-text]))
|
||||
(set! definitions-canvases (list definitions-canvas))
|
||||
(set! interactions-canvas (new (drracket:get/extend:get-interactions-canvas)
|
||||
(parent resizable-panel)
|
||||
(editor interactions-text)))
|
||||
(set! interactions-canvases (list interactions-canvas))
|
||||
|
||||
(set! save-button
|
||||
(new switchable-button%
|
||||
[parent top-panel]
|
||||
[callback (λ (x) (when definitions-text
|
||||
(save)
|
||||
(send definitions-canvas focus)))]
|
||||
[bitmap save-bitmap]
|
||||
[alternate-bitmap small-save-bitmap]
|
||||
[label (string-constant save-button-label)]))
|
||||
(register-toolbar-button save-button)
|
||||
|
||||
(set! name-message (new drs-name-message% [parent name-panel]))
|
||||
(send name-message stretchable-width #t)
|
||||
(send name-message set-allow-shrinking 160)
|
||||
(set! button-panel (new panel:horizontal-discrete-sizes%
|
||||
[parent top-panel]
|
||||
[stretchable-width #t]
|
||||
[alignment '(right center)]))
|
||||
(set! color-status-canvas
|
||||
(let ()
|
||||
(define on-string "()")
|
||||
(define color-status-canvas
|
||||
(new canvas%
|
||||
[parent (get-info-panel)]
|
||||
[style '(transparent)]
|
||||
[stretchable-width #f]
|
||||
[paint-callback
|
||||
(λ (c dc)
|
||||
(when (number? th)
|
||||
(unless color-valid?
|
||||
(let-values ([(cw ch) (send c get-client-size)])
|
||||
(send dc set-font small-control-font)
|
||||
(send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))]))
|
||||
(define-values (tw th ta td)
|
||||
(send (send color-status-canvas get-dc) get-text-extent
|
||||
on-string small-control-font))
|
||||
(send color-status-canvas min-width (inexact->exact (ceiling tw)))
|
||||
color-status-canvas))
|
||||
|
||||
(set! running-canvas (new running-canvas% [parent (get-info-panel)]))
|
||||
|
||||
(set! bug-icon
|
||||
(let* ([info-panel (get-info-panel)]
|
||||
[btn
|
||||
(new switchable-button%
|
||||
[parent info-panel]
|
||||
[callback (λ (x) (show-saved-bug-reports-window))]
|
||||
[bitmap very-small-planet-bitmap]
|
||||
[vertical-tight? #t]
|
||||
[label (string-constant show-planet-contract-violations)])])
|
||||
(send btn set-label-visible #f)
|
||||
(send info-panel change-children
|
||||
(λ (l)
|
||||
(cons btn (remq* (list btn) l))))
|
||||
btn))
|
||||
|
||||
(set! func-defs-canvas (new func-defs-canvas%
|
||||
(parent name-panel)
|
||||
(frame this)))
|
||||
|
||||
(set! execute-button
|
||||
(new switchable-button%
|
||||
[parent button-panel]
|
||||
[callback (λ (x) (execute-callback))]
|
||||
[bitmap execute-bitmap]
|
||||
[label (string-constant execute-button-label)]))
|
||||
(register-toolbar-button execute-button #:number 100)
|
||||
|
||||
(set! break-button
|
||||
(new switchable-button%
|
||||
[parent button-panel]
|
||||
[callback (λ (x) (send current-tab break-callback))]
|
||||
[bitmap break-bitmap]
|
||||
[label (string-constant break-button-label)]))
|
||||
(register-toolbar-button break-button #:number 101)
|
||||
|
||||
(send top-panel change-children
|
||||
(λ (l)
|
||||
(list* p
|
||||
(remq* (list p)
|
||||
l))))
|
||||
language-message))
|
||||
(list name-panel save-button button-panel)))
|
||||
|
||||
(send top-panel stretchable-height #f)
|
||||
(let ([m (send definitions-canvas get-editor)])
|
||||
(set-save-init-shown?
|
||||
(and m (send m is-modified?))))
|
||||
|
||||
(set! language-message
|
||||
(let* ([info-panel (get-info-panel)]
|
||||
[p (new vertical-panel%
|
||||
[parent info-panel]
|
||||
[alignment '(left center)])]
|
||||
[language-message (new language-label-message% [parent p] [frame this])])
|
||||
(send info-panel change-children
|
||||
(λ (l)
|
||||
(list* p
|
||||
(remq* (list p)
|
||||
l))))
|
||||
language-message))
|
||||
|
||||
(update-save-message)
|
||||
(update-save-button)
|
||||
(language-changed)
|
||||
(set-delegated-text definitions-text)
|
||||
|
||||
(cond
|
||||
[filename
|
||||
(set! definitions-shown? #t)
|
||||
(set! interactions-shown? #f)]
|
||||
[else
|
||||
(set! definitions-shown? #t)
|
||||
(set! interactions-shown? #t)])
|
||||
|
||||
(update-shown)
|
||||
|
||||
(when (= 2 (length (send resizable-panel get-children)))
|
||||
(send resizable-panel set-percentages
|
||||
(let ([p (preferences:get 'drracket:unit-window-size-percentage)])
|
||||
(list p (- 1 p)))))
|
||||
|
||||
(set-label-prefix (string-constant drscheme))
|
||||
(set! newest-frame this)
|
||||
;; a callback might have happened that initializes set-color-status! before the
|
||||
;; definitions text is connected to the frame, so we do an extra initialization
|
||||
;; now, once we know we have the right connection
|
||||
(set-color-status! (send definitions-text is-lexer-valid?))
|
||||
(send definitions-canvas focus)))
|
||||
|
||||
(update-save-message)
|
||||
(update-save-button)
|
||||
(language-changed)
|
||||
(set-delegated-text definitions-text)
|
||||
(super-new
|
||||
[filename filename]
|
||||
[style '(toolbar-button)]
|
||||
[size-preferences-key 'drracket:window-size]
|
||||
[position-preferences-key 'drracket:window-position])
|
||||
|
||||
(cond
|
||||
[filename
|
||||
(set! definitions-shown? #t)
|
||||
(set! interactions-shown? #f)]
|
||||
[else
|
||||
(set! definitions-shown? #t)
|
||||
(set! interactions-shown? #t)])
|
||||
|
||||
(update-shown)
|
||||
|
||||
(when (= 2 (length (send resizable-panel get-children)))
|
||||
(send resizable-panel set-percentages
|
||||
(let ([p (preferences:get 'drracket:unit-window-size-percentage)])
|
||||
(list p (- 1 p)))))
|
||||
|
||||
(set-label-prefix (string-constant drscheme))
|
||||
(set! newest-frame this)
|
||||
;; a callback might have happened that initializes set-color-status! before the
|
||||
;; definitions text is connected to the frame, so we do an extra initialization
|
||||
;; now, once we know we have the right connection
|
||||
(set-color-status! (send definitions-text is-lexer-valid?))
|
||||
(send definitions-canvas focus)))
|
||||
(initialize-menus)))
|
||||
|
||||
;; get-define-popup-name : (or/c #f (cons/c string? string?) (list/c string? string? string))
|
||||
;; boolean
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user