Refactor ui.gadgets.glass to correctly position debugger popup

basis/ui/gadgets/glass/glass.factor

@@ -1,32 +1,51 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces ui.gadgets ui.gadgets.worlds
-ui.gestures ;
+ui.gestures math.rectangles math.rectangles.positioning
+combinators ;
 IN: ui.gadgets.glass
 
 GENERIC: hide-glass-hook ( gadget -- )
 
 M: gadget hide-glass-hook drop ;
 
-TUPLE: glass < gadget ;
-
-: <glass> ( child loc -- glass )
-    >>loc glass new-gadget swap add-gadget ;
-
-M: glass layout* gadget-child prefer ;
-
-M: glass ungraft* gadget-child hide-glass-hook ;
-
 : hide-glass ( world -- )
     [ [ unparent ] when* f ] change-glass drop ;
 
-: show-glass ( world child loc -- )
-    <glass>
-    [ [ hide-glass ] [ hand-clicked set-global ] bi* ]
-    [ [ add-gadget ] [ >>glass ] bi drop ]
-    2bi ;
+<PRIVATE
+
+TUPLE: glass < gadget visible-rect owner ;
+
+: <glass> ( owner child visible-rect -- glass )
+    glass new-gadget
+        swap >>visible-rect
+        swap add-gadget
+        swap >>owner ;
+    
+: visible-rect ( glass -- rect )
+    [ visible-rect>> ] [ owner>> ] bi screen-loc offset-rect ;
+
+M: glass layout*
+    {
+        [ gadget-child ]
+        [ visible-rect ]
+        [ gadget-child pref-dim ]
+        [ find-world dim>> ]
+    } cleave popup-loc >>loc prefer ;
+
+M: glass ungraft* gadget-child hide-glass-hook ;
+
+: add-glass ( glass world -- )
+    dup hide-glass swap [ add-gadget ] [ >>glass ] bi drop ;
 
 \ glass H{
     { T{ button-down } [ find-world [ hide-glass ] when* ] }
     { T{ drag } [ update-clicked drop ] }
-} set-gestures
+} set-gestures
+
+PRIVATE>
+
+: show-glass ( owner child visible-rect -- )
+    <glass>
+    dup gadget-child hand-clicked set
+    dup owner>> find-world add-glass ;

basis/ui/gadgets/menus/menus.factor

@@ -1,18 +1,13 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: locals accessors kernel math namespaces sequences math.vectors
-math.rectangles.positioning colors colors.constants math.rectangles
-ui.commands ui.operations ui.gadgets ui.gadgets.buttons
-ui.gadgets.worlds ui.gestures ui.gadgets.theme ui.gadgets.packs
-ui.gadgets.glass ui.gadgets.borders ;
+USING: colors.constants kernel locals math.rectangles
+namespaces sequences ui.commands ui.gadgets ui.gadgets.borders
+ui.gadgets.buttons ui.gadgets.glass ui.gadgets.packs
+ui.gadgets.theme ui.gadgets.worlds ui.gestures ui.operations ;
 IN: ui.gadgets.menus
 
-: menu-loc ( world menu -- loc )
-    [ hand-loc get { 0 0 } <rect> ] 2dip
-    pref-dim swap dim>> popup-loc ;
-
 : show-menu ( owner menu -- )
-    [ find-world ] dip 2dup menu-loc show-glass ;
+    [ find-world ] dip hand-loc get { 0 0 } <rect> show-glass ;
 
 :: <menu-item> ( target hook command -- button )
     command command-name [

basis/ui/tools/listener/popups/popups.factor

@@ -26,25 +26,19 @@ popup H{
 } set-gestures
 
 : caret-loc ( interactor element -- loc )
-    [ drop screen-loc ] [
-        [
-            [ [ editor-caret ] [ model>> ] bi ] dip
-            prev-elt
-        ] [ drop ] 2bi
-        loc>point
-    ] 2bi v+ ;
+    [
+        [ [ editor-caret ] [ model>> ] bi ] dip
+        prev-elt
+    ] [ drop ] 2bi
+    loc>point ;
 
 : relevant-rect ( popup -- rect )
     [ interactor>> ] [ element>> ] bi
     [ caret-loc ] [ drop caret-dim { 0 1 } v+ ] 2bi
     <rect> ;
 
-: listener-popup-loc ( popup -- loc )
-    [ relevant-rect ] [ pref-dim ] [ interactor>> find-world dim>> ] tri
-    popup-loc ;
-
 : show-popup ( interactor element popup -- )
     <popup>
     [ dup interactor>> (>>popup) ]
-    [ [ interactor>> find-world ] [ ] [ listener-popup-loc ] tri show-glass ]
+    [ [ interactor>> ] [ ] [ relevant-rect ] tri show-glass ]
     bi ;