racket/gui: fix problem with reparent and container sequences

In a container sequence, hides and shows are delayed, but
reparenting needs the hide operation to really complete.
This commit is contained in:
Matthew Flatt 2013-08-21 09:20:12 -06:00
parent 3201f1330a
commit 76aa80c0e9
4 changed files with 26 additions and 6 deletions

View File

@ -40,7 +40,8 @@
(define-local-member-name (define-local-member-name
has-wx-child? has-wx-child?
adopt-wx-child) adopt-wx-child
forget-wx-child)
(define (make-container% %) ; % implements area<%> (define (make-container% %) ; % implements area<%>
(class* % (area-container<%> internal-container<%>) (class* % (area-container<%> internal-container<%>)
@ -156,14 +157,14 @@
is-shown? is-shown?
show) show)
(define/public (reparent new-parent) (define/public (reparent new-parent)
(check-container-parent '(subwindow<%> reparent) new-parent) (check-container-parent '(method subwindow<%> reparent) new-parent)
(unless (as-entry (unless (as-entry
(lambda () (lambda ()
(let ([p1 (send (mred->wx this) get-top-level)] (let ([p1 (send (mred->wx this) get-top-level)]
[p2 (send (mred->wx new-parent) get-top-level)]) [p2 (send (mred->wx new-parent) get-top-level)])
(eq? (send p1 get-eventspace) (send p1 get-eventspace))))) (eq? (send p1 get-eventspace) (send p1 get-eventspace)))))
(raise-arguments-error (raise-arguments-error
(who->name '(subwindow<%> reparent)) (who->name '(method subwindow<%> reparent))
"current parent's eventspace is not the same as the eventspace of the new parent" "current parent's eventspace is not the same as the eventspace of the new parent"
"subwindow" this "subwindow" this
"new parent" new-parent)) "new parent" new-parent))
@ -171,7 +172,7 @@
(when p (when p
(when (eq? p this) (when (eq? p this)
(raise-arguments-error (raise-arguments-error
(who->name '(subwindow<%> reparent)) (who->name '(method subwindow<%> reparent))
(if (eq? new-parent this) (if (eq? new-parent this)
"cannot set parent to self" "cannot set parent to self"
"cannot set parent to a descedant") "cannot set parent to a descedant")
@ -192,6 +193,7 @@
(or (eq? p wx) (or (eq? p wx)
(loop (send p get-parent))))) (loop (send p get-parent)))))
;; Ok --- really reparent: ;; Ok --- really reparent:
(send wx ensure-forgotten)
(send new-parent adopt-wx-child wx) (send new-parent adopt-wx-child wx)
(set-parent new-parent)))))) (set-parent new-parent))))))
(when added? (when added?

View File

@ -144,8 +144,15 @@
(set! hidden-child (car children)) (set! hidden-child (car children))
(let ([i (send hidden-child get-info)]) (let ([i (send hidden-child get-info)])
(set-min-width (child-info-x-min i)) (set-min-width (child-info-x-min i))
(set-min-height (child-info-y-min i))))] (set-min-height (child-info-y-min i))))])
(override*
[ensure-forgotten (lambda ()
(for ([c (in-list children)])
(send c ensure-forgotten))
(super ensure-forgotten))])
(public*
[border [border
(case-lambda (case-lambda
[() curr-border] [() curr-border]

View File

@ -226,6 +226,12 @@
(when (zero? seq-count) (when (zero? seq-count)
(delay-updates #f)))] (delay-updates #f)))]
[forget-child
(lambda (child)
(unless (hash-ref show-ht child #t)
(send child show #f))
(hash-remove! show-ht child))]
[show-child [show-child
(lambda (child show?) (lambda (child show?)
(if perform-updates? (if perform-updates?

View File

@ -92,7 +92,12 @@
(is-a? window wx:dialog%)) (is-a? window wx:dialog%))
(set! top-level window)] (set! top-level window)]
[else (loop (send window get-parent))]))) [else (loop (send window get-parent))])))
top-level)]) top-level)]
[ensure-forgotten
(lambda ()
;; This value or its ancestor is going to be adopted elsewhere,
;; so really forget it, make sure it's hidden, etc.
(send (get-top-level) forget-child this))])
(public* (public*
[really-show [really-show
(lambda (on?) (lambda (on?)