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

added a close icon to the yellow warning message

Browse Source 
svn: r15611
This commit is contained in:
Robby Findler 2009-07-28 20:40:54 +00:00
parent 8b0b01939a
commit 3c4bdf86fe
3 changed files with 22 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1247,7 +1247,9 @@ module browser threading seems wrong.
(update-execute-warning-gui))
(define/public (update-execute-warning-gui)
(when (is-current-tab?)
(send frame show/hide-warning-message (get-current-execute-warning))))
(send frame show/hide-warning-message
(get-current-execute-warning)
(λ () (clear-execution-state)))))
(define/public (get-directory)
(let ([filename (send defs get-filename)])
@ -1424,7 +1426,7 @@ module browser threading seems wrong.
(define execute-warning-panel #f)
(define execute-warning-parent-panel #f)
(define execute-warning-canvas #f)
(define/public-final (show/hide-warning-message msg)
(define/public-final (show/hide-warning-message msg hide-canvas)
(when (and execute-warning-parent-panel
execute-warning-panel)
(cond
@ -1435,8 +1437,13 @@ module browser threading seems wrong.
[else
(set! execute-warning-canvas
(new execute-warning-canvas%
[stretchable-height #t]
[parent execute-warning-panel]
[message msg]))])
[message msg]))
(new close-icon%
[parent execute-warning-panel]
[bg-color "yellow"]
[callback (λ () (hide-canvas))])])
(send execute-warning-parent-panel
change-children
(λ (l) (append (remq execute-warning-panel l)
@ -1779,7 +1786,7 @@ module browser threading seems wrong.
(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%
(set! execute-warning-panel (new horizontal-panel%
[parent execute-warning-parent-panel]
[stretchable-height #f]))
(send execute-warning-parent-panel change-children (λ (l) (remq execute-warning-panel l)))
@ -4069,6 +4076,7 @@ module browser threading seems wrong.
(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)])
@ -4095,7 +4103,6 @@ module browser threading seems wrong.
(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)))))))

8
collects/mrlib/close-icon.ss
View File

@ -55,7 +55,8 @@
(class canvas%
(inherit get-dc min-width min-height stretchable-width stretchable-height
get-client-size refresh)
(init-field [callback void])
(init-field [callback void]
[bg-color #f])
(init [horizontal-pad 4]
[vertical-pad 4])
(init-masks)
@ -92,6 +93,11 @@
(define/override (on-paint)
(let ([dc (get-dc)])
(let-values ([(cw ch) (get-client-size)])
(when bg-color
(send dc set-brush bg-color 'solid)
(send dc set-pen bg-color 1 'transparent)
(let-values ([(w h) (get-client-size)])
(send dc draw-rectangle 0 0 w h)))
(send dc draw-bitmap icon
(- (/ cw 2) (/ (send icon get-width) 2))
(- (/ ch 2) (/ (send icon get-height) 2))

3
collects/mrlib/scribblings/close-icon.scrbl
View File

@ -13,8 +13,11 @@ provides a clickable close button icon.}
@defclass[close-icon% canvas% ()]{
@defconstructor[([parent (is-a? area-container<%>)]
[callback (-> any) void]
[bg-color (or/c #f string (is-a?/c color%))]
[horizontal-pad positive-integer? 4]
[vertical-pad positive-integer? 4])]{
The @scheme[callback] is called when the close icon is clicked.
If @scheme[bg-color] is specified, it is used as the background color of the icon.
}
}