From 299e85b30a3894047a38624920ce8a57b3c29bbf Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 21 Jan 2011 20:18:50 -0700
Subject: [PATCH] add `reparent' to `subwindow<%>'

original commit: b112fd76df4305b178a7e761fe0d29214a37c518
---
 collects/mred/private/mrcanvas.rkt            |  2 +-
 collects/mred/private/mrcontainer.rkt         | 66 ++++++++++++++++++-
 collects/mred/private/mritem.rkt              |  7 +-
 collects/mred/private/mrpanel.rkt             |  5 +-
 collects/mred/private/mrwindow.rkt            | 10 ++-
 collects/mred/private/wx/cocoa/panel.rkt      |  6 +-
 collects/mred/private/wx/cocoa/window.rkt     |  3 +
 collects/mred/private/wx/gtk/panel.rkt        |  4 ++
 collects/mred/private/wx/gtk/window.rkt       |  8 +++
 collects/mred/private/wx/win32/panel.rkt      |  4 ++
 collects/mred/private/wx/win32/window.rkt     |  7 ++
 collects/mred/private/wxitem.rkt              |  3 +
 collects/scribblings/gui/subwindow-intf.scrbl | 13 +++-
 collects/tests/gracket/item.rkt               | 17 ++++-
 14 files changed, 140 insertions(+), 15 deletions(-)

diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt
index b0259ff5..a5350f69 100644
--- a/collects/mred/private/mrcanvas.rkt
+++ b/collects/mred/private/mrcanvas.rkt
@@ -38,7 +38,7 @@
     area%-keywords)
 
   (define basic-canvas%
-    (class100* (make-window% #f (make-subarea% area%)) (canvas<%>) (mk-wx mismatches parent)
+    (class100* (make-subwindow% (make-window% #f (make-subarea% area%))) (canvas<%>) (mk-wx mismatches parent)
       (public
 	[on-char (lambda (e) (send wx do-on-char e))]
 	[on-event (lambda (e) (send wx do-on-event e))]
diff --git a/collects/mred/private/mrcontainer.rkt b/collects/mred/private/mrcontainer.rkt
index c5ff33ee..3e21c2ba 100644
--- a/collects/mred/private/mrcontainer.rkt
+++ b/collects/mred/private/mrcontainer.rkt
@@ -16,7 +16,8 @@
 	   (protect internal-container<%>
 		    check-container-parent
 		    container%-keywords
-		    make-container%)
+		    make-container%
+                    make-subwindow%)
 	   area-container-window<%>
 	   (protect make-area-container-window%))
 
@@ -41,6 +42,10 @@
     [spacing no-val]
     [alignment no-val])
 
+  (define-local-member-name
+    has-wx-child?
+    adopt-wx-child)
+
   (define (make-container% %) ; % implements area<%>
     (class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches parent
 								  ;; for keyword use
@@ -120,7 +125,13 @@
 	[delete-child (entry-point
 		       (lambda (c) 
 			 (check-instance '(method area-container<%> delete-child) subwindow<%> 'subwindow<%> #f c)
-			 (send (get-wx-panel) delete-child (mred->wx c))))])
+			 (send (get-wx-panel) delete-child (mred->wx c))))]
+        [has-wx-child? (lambda (child-wx) ; called in atomic mode
+                         (memq child-wx (send (get-wx-panel) get-children)))]
+        [adopt-wx-child (lambda (child-wx) ; called in atomic mode
+                          (let ([wxp (get-wx-panel)])
+                            (send child-wx set-area-parent wxp)
+                            (send wxp adopt-child child-wx)))])
       (sequence
 	(super-init mk-wx get-wx-panel get-wx-outer-pan mismatches parent)
 	(unless (eq? border no-val) (bdr border))
@@ -133,6 +144,55 @@
   (define (make-area-container-window% %) ; % implements window<%> (and area-container<%>)
     (class100* % (area-container-window<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor) 
       (sequence
-	(super-init mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor)))))
+	(super-init mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor))))
 
 
+  (define (make-subwindow% %)
+    (class %
+      (super-new)
+      (inherit set-parent 
+               get-parent
+               is-shown?
+               show)
+      (define/public (reparent new-parent)
+        (check-container-parent '(subwindow<%> reparent) new-parent)
+        (unless (as-entry
+                 (lambda ()
+                   (let ([p1 (send (mred->wx this) get-top-level)]
+                         [p2 (send (mred->wx new-parent) get-top-level)])
+                     (eq? (send p1 get-eventspace) (send p1 get-eventspace)))))
+          (raise-mismatch-error 
+           (who->name '(subwindow<%> reparent))
+           "current parent's eventspace is not the same as the eventspace of the new parent: "
+           new-parent))
+        (let loop ([p new-parent])
+          (when p
+            (when (eq? p this)
+              (raise-mismatch-error 
+               (who->name '(subwindow<%> reparent))
+               (if (eq? new-parent this)
+                   "cannot set parent to self: "
+                   "cannot set parent to a descedant: ")
+               new-parent))
+            (loop (send p get-parent))))
+        (let* ([added? (memq this (send (get-parent) get-children))]
+               [shown? (and added? (is-shown?))])
+          (when added?
+            (send (get-parent) delete-child this))
+          (as-entry
+           (lambda ()
+             (let ([wx (mred->wx this)])
+               ;; double-check that delete succeeded:
+               (unless (send (get-parent) has-wx-child? wx)
+                 ;; double-check that we're not creating a loop at the wx level:
+                 (unless (let loop ([p (mred->wx new-parent)])
+                           (and p
+                                (or (eq? p wx)
+                                    (loop (send p get-parent)))))
+                   ;; Ok --- really reparent:
+                   (send new-parent adopt-wx-child wx)
+                   (set-parent new-parent))))))
+          (when added?
+            (send new-parent add-child this))
+          (when shown?
+            (show #t)))))))
diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt
index 3dc522cd..36065028 100644
--- a/collects/mred/private/mritem.rkt
+++ b/collects/mred/private/mritem.rkt
@@ -54,9 +54,10 @@
     control%-nofont-keywords)
 
   (define basic-control%
-    (class100* (make-window% #f (make-subarea% area%)) (control<%>) (mk-wx mismatches lbl parent cb cursor
-									   ;; for keyword use
-									   [font no-val])
+    (class100* (make-subwindow% (make-window% #f (make-subarea% area%))) (control<%>) 
+      (mk-wx mismatches lbl parent cb cursor
+             ;; for keyword use
+             [font no-val])
       (rename [super-set-label set-label])
       (private-field [label lbl][callback cb] 
                      [can-bitmap? (or (lbl . is-a? . wx:bitmap%)
diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt
index b395fbee..5db69809 100644
--- a/collects/mred/private/mrpanel.rkt
+++ b/collects/mred/private/mrpanel.rkt
@@ -71,7 +71,10 @@
     area%-keywords)
 
   (define panel%
-    (class100*/kw (make-area-container-window% (make-window% #f (make-subarea% (make-container% area%)))) (subwindow<%>) 
+    (class100*/kw (make-subwindow%
+                   (make-area-container-window% 
+                    (make-window% #f (make-subarea% (make-container% area%)))) )
+                  (subwindow<%>)
 		  [(parent [style null]) panel%-keywords]
       (private-field [wx #f])
       (public [get-initial-label (lambda () #f)])
diff --git a/collects/mred/private/mrwindow.rkt b/collects/mred/private/mrwindow.rkt
index 324d5b15..6755c6d0 100644
--- a/collects/mred/private/mrwindow.rkt
+++ b/collects/mred/private/mrwindow.rkt
@@ -23,7 +23,8 @@
 	   subwindow<%>
 	   (protect make-window%)
            
-           (protect set-get-outer-panel))
+           (protect set-get-outer-panel
+                    set-parent))
 
   (define area<%>
     (interface ()
@@ -39,7 +40,8 @@
     [stretchable-height no-val])
 
   (define-local-member-name
-    set-get-outer-panel)
+    set-get-outer-panel
+    set-parent)
 
   (define area%
     (class100* mred% (area<%>) (mk-wx get-wx-pan get-outer-wx-pan mismatches prnt
@@ -57,6 +59,7 @@
        [get-wx-outer-panel get-outer-wx-pan]
        [parent prnt])
       (public
+        [set-parent (lambda (p) (set! parent p))] ; called in atomic mode
 	[get-parent (lambda () parent)]
 	[get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))]
 	[(minw min-width) (param get-wx-outer-panel min-width)]
@@ -121,7 +124,8 @@
   (define-keywords window%-keywords [enabled #t])
 
   (define subwindow<%> 
-    (interface (window<%> subarea<%>)))
+    (interface (window<%> subarea<%>)
+      reparent))
 
   (define (make-window% top? %) ; % implements area<%>
     (class100* % (window<%>) (mk-wx get-wx-panel get-outer-wx-panel mismatches lbl parent crsr
diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt
index 85864672..efe024f4 100644
--- a/collects/mred/private/wx/cocoa/panel.rkt
+++ b/collects/mred/private/wx/cocoa/panel.rkt
@@ -20,7 +20,7 @@
 (define (panel-mixin %)
   (class %
     (inherit register-as-child on-new-child
-             is-window-enabled?)
+             is-window-enabled? get-cocoa)
 
     (define lbl-pos 'horizontal)
     (define children null)
@@ -30,6 +30,10 @@
     (define/public (get-label-position) lbl-pos)
     (define/public (set-label-position pos) (set! lbl-pos pos))
 
+    (define/public (adopt-child p)
+      ;; in atomic mode
+      (send p set-parent this))
+
     (define/override (fix-dc)
       (for ([child (in-list children)])
         (send child fix-dc)))
diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt
index 878ac069..a6a597da 100644
--- a/collects/mred/private/wx/cocoa/window.rkt
+++ b/collects/mred/private/wx/cocoa/window.rkt
@@ -480,6 +480,9 @@
     (define/public (get-parent)
       parent)
 
+    (define/public (set-parent p)
+      (set! parent p))
+
     (define/public (get-eventspace) eventspace)
 
     (define is-on? #f)
diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt
index 280ad9aa..71e3f642 100644
--- a/collects/mred/private/wx/gtk/panel.rkt
+++ b/collects/mred/private/wx/gtk/panel.rkt
@@ -28,6 +28,10 @@
     (define/public (get-label-position) lbl-pos)
     (define/public (set-label-position pos) (set! lbl-pos pos))
 
+    (define/public (adopt-child child)
+      ;; in atomic mode
+      (send child set-parent this))
+
     (define/override (reset-child-dcs)
       (when (pair? children)
         (for ([child (in-list children)])
diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt
index 18dbf5cf..1f929c0d 100644
--- a/collects/mred/private/wx/gtk/window.rkt
+++ b/collects/mred/private/wx/gtk/window.rkt
@@ -57,6 +57,7 @@
 ;; ----------------------------------------
 
 (define-gtk gtk_container_add (_fun _GtkWidget _GtkWidget -> _void))
+(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
 (define-gtk gtk_widget_realize (_fun _GtkWidget -> _void))
 (define-gtk gtk_widget_add_events (_fun _GtkWidget _int -> _void))
 
@@ -516,6 +517,13 @@
     (define/public (get-height) save-h)
 
     (define/public (get-parent) parent)
+    (define/public (set-parent p)
+      ;; in atomic mode
+      (g_object_ref gtk)
+      (gtk_container_remove (send parent get-client-gtk) gtk)
+      (set! parent p)
+      (gtk_container_add (send parent get-client-gtk) gtk)
+      (g_object_unref gtk))
 
     (define/public (get-top-win) (send parent get-top-win))
 
diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt
index 5d5c7984..ee52fc94 100644
--- a/collects/mred/private/wx/win32/panel.rkt
+++ b/collects/mred/private/wx/win32/panel.rkt
@@ -20,6 +20,10 @@
 
     (super-new)
 
+    (define/public (adopt-child child)
+      ;; in atomic mode
+      (send child set-parent this))
+
     (define children null)
     (define/override (register-child child on?)
       (let ([on? (and on? #t)]
diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt
index 814ad05f..28c33bee 100644
--- a/collects/mred/private/wx/win32/window.rkt
+++ b/collects/mred/private/wx/win32/window.rkt
@@ -71,6 +71,8 @@
 
 (define-user32 WindowFromPoint (_fun _POINT -> _HWND))
 (define-user32 GetParent (_fun _HWND -> _HWND))
+(define-user32 SetParent (_fun _HWND _HWND -> (r : _HWND)
+                               -> (unless r (failed 'SetParent))))
 
 (define-cstruct _NMHDR
   ([hwndFrom _HWND]
@@ -387,6 +389,11 @@
   (define/public (center a b) (void))
 
   (define/public (get-parent) parent)
+  (define/public (set-parent p) 
+    ;; in atomic mode
+    (set! parent p)
+    (SetParent hwnd (send parent get-client-hwnd)))
+
   (define/public (is-frame?) #f)
 
   (define/public (refresh) (void))
diff --git a/collects/mred/private/wxitem.rkt b/collects/mred/private/wxitem.rkt
index 0f84b39c..cd081fa3 100644
--- a/collects/mred/private/wxitem.rkt
+++ b/collects/mred/private/wxitem.rkt
@@ -183,6 +183,9 @@
 	     (let ([w (+ (* 2 (x-margin)) (max hard-min-width (min-width)))]
 		   [h (+ (* 2 (y-margin)) (max hard-min-height (min-height)))])
 	       (list w h)))])
+
+        (public
+          [set-area-parent (lambda (p) (set! first-arg p))])
 	
 	(sequence
 	  (apply super-init (send (car args) get-window) (cdr args))
diff --git a/collects/scribblings/gui/subwindow-intf.scrbl b/collects/scribblings/gui/subwindow-intf.scrbl
index 4cab25c5..69cdd935 100644
--- a/collects/scribblings/gui/subwindow-intf.scrbl
+++ b/collects/scribblings/gui/subwindow-intf.scrbl
@@ -5,6 +5,17 @@
 
 A @scheme[subwindow<%>] is a containee window.
 
+@defmethod[(reparent [new-parent (or/c (is-a?/c frame%) (is-a?/c dialog%) 
+                                       (is-a?/c panel%) (is-a?/c pane%))])
+           void?]{
+
+Removes the window from its current parent and makes it a child of
+@racket[new-parent]. The current and new parents must have the same
+eventspace, and @racket[new-parent] cannot be a descendant of
+@this-obj[].
+
+If @this-obj[] is deleted within its current parent, it remains
+deleted in @racket[new-parent]. Similarly, if @this-obj[] is shown in
+its current parent, it is shown in @racket[new-parent].}
 
 }
-
diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt
index bd0db560..d946bf18 100644
--- a/collects/tests/gracket/item.rkt
+++ b/collects/tests/gracket/item.rkt
@@ -476,14 +476,16 @@
   (add-testers "Text" txt)
   (add-change-label "Text" txt lp #f OTHER-LABEL)
   
-  (let ([items (list l il 
+  (let ([items (list ip
+                     l il 
 		     b ib 
 		     lb
 		     cb icb 
 		     rb irb 
 		     ch
 		     txt)]
-	[names (list "label" "image label"
+	[names (list "panel"
+                     "label" "image label"
 		     "button" "image button"
 		     "list box"
 		     "checkbox" "image checkbox"
@@ -499,6 +501,17 @@
 		     (when (positive? v)
 		       (send (list-ref items (sub1 v)) focus)
 		       (send c set-selection 0)))))
+    (make-object choice%
+		 "Reparent"
+		 (cons "..." names)
+		 lp
+		 (lambda (c e)
+		   (let ([v (send c get-selection)])
+		     (when (positive? v)
+                       (define f (new frame% [label "New Parent"]))
+		       (send (list-ref items (sub1 v)) reparent f)
+                       (send f show #t)
+		       (send c set-selection 0)))))
     (cons (make-object popup-test-canvas% 
 		       items
 		       names