Split off large chunk of ui.tools.listener.popups and make it generic; put it in ui.gadgets.glass

basis/ui/gadgets/glass/glass.factor

@@ -1,17 +1,14 @@
 ! 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 math.rectangles math.rectangles.positioning
+ui.gadgets.wrappers ui.gestures math.rectangles
-combinators ;
+math.rectangles.positioning combinators ;
 IN: ui.gadgets.glass
 
 GENERIC: hide-glass-hook ( gadget -- )
 
 M: gadget hide-glass-hook drop ;
 
-: hide-glass ( world -- )
-    [ [ unparent ] when* f ] change-glass drop ;
-
 <PRIVATE
 
 TUPLE: glass < gadget visible-rect owner ;
@@ -35,17 +32,51 @@ M: glass layout*
 
 M: glass ungraft* gadget-child hide-glass-hook ;
 
-: add-glass ( glass world -- )
+: (hide-glass) ( gadget -- )
-    dup hide-glass swap [ add-gadget ] [ >>glass ] bi drop ;
+    [ [ unparent ] when* f ] change-glass drop ;
 
-\ glass H{
+: add-glass ( glass world -- )
-    { T{ button-down } [ find-world [ hide-glass ] when* ] }
+    dup (hide-glass) swap [ add-gadget ] [ >>glass ] bi drop ;
-    { T{ drag } [ update-clicked drop ] }
-} set-gestures
 
 PRIVATE>
 
+: hide-glass ( child -- )
+    find-world [ [ (hide-glass) ] [ request-focus ] bi ] when* ;
+
 : show-glass ( owner child visible-rect -- )
     <glass>
     dup gadget-child hand-clicked set
     dup owner>> find-world add-glass ;
+
+\ glass H{
+    { T{ button-down } [ hide-glass ] }
+    { T{ drag } [ update-clicked drop ] }
+} set-gestures
+
+SLOT: popup
+
+<PRIVATE
+
+TUPLE: popup < wrapper owner ;
+
+: <popup> ( owner gadget -- popup )
+    popup new-wrapper
+        swap >>owner ; inline
+
+M: popup hide-glass-hook
+    owner>> f >>popup request-focus ;
+
+PRIVATE>
+
+popup H{
+    { T{ key-down f f "ESC" } [ hide-glass ] }
+} set-gestures
+
+: pass-to-popup ( gesture interactor -- ? )
+    popup>> focusable-child resend-gesture ;
+
+: show-popup ( owner popup visible-rect -- )
+    [ <popup> ] dip
+    [ drop dup owner>> (>>popup) ]
+    [ [ [ owner>> ] keep ] dip show-glass ]
+    2bi ;

basis/ui/tools/listener/completion/completion.factor

@@ -131,7 +131,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
     find-completion-popup
     [ insert-completion ]
     [ accept-completion-hook ]
-    [ nip hide-popup ]
+    [ nip hide-glass ]
     2tri ;
 
 : <completion-table> ( interactor completion-mode -- table )
@@ -140,8 +140,6 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
         monospace-font >>font
         t >>selection-required?
         t >>single-click?
-        transparent >>column-line-color
-        2 >>gap
         30 >>min-cols
         10 >>max-rows
         dup '[ _ accept-completion ] >>action ;
@@ -162,7 +160,7 @@ completion-popup H{
 
 : show-completion-popup ( interactor mode -- )
     [ completion-element ] [ <completion-popup> ] 2bi
-    show-popup ;
+    show-listener-popup ;
 
 : code-completion-popup ( interactor -- )
     dup completion-mode show-completion-popup ;
@@ -182,5 +180,5 @@ completion-popup H{
 
 M: completion-popup handle-gesture ( gesture completion -- ? )
     2dup completion-gesture dup [
-        [ nip find-world hide-glass ] [ invoke-command ] 2bi* f
+        [ nip hide-glass ] [ invoke-command ] 2bi* f
     ] [ 2drop call-next-method ] if ;

basis/ui/tools/listener/listener.factor

@@ -7,7 +7,7 @@ documents documents.elements fry hashtables help help.markup io
 io.styles kernel lexer listener math models models.delay models.filter
 namespaces parser prettyprint quotations sequences strings threads
 tools.vocabs vocabs vocabs.loader vocabs.parser words ui ui.commands
-ui.pens.solid ui.gadgets ui.gadgets.buttons ui.gadgets.editors
+ui.pens.solid ui.gadgets ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors
 ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
 ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
 ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
@@ -293,11 +293,11 @@ M: object accept-completion-hook 2drop ;
 
 :: <debugger-popup> ( interactor error continuation -- popup )
     error continuation error compute-restarts
-    [ interactor hide-popup ] <debugger>
+    [ interactor hide-glass ] <debugger>
     "Error" <labeled-gadget> ;
 
 : debugger-popup ( interactor error continuation -- )
-    [ [ drop one-line-elt ] 2keep ] dip <debugger-popup> show-popup ;
+    [ [ drop one-line-elt ] 2keep ] dip <debugger-popup> show-listener-popup ;
 
 : handle-parse-error ( interactor error -- )
     dup lexer-error? [ 2dup go-to-error error>> ] when
@@ -329,9 +329,6 @@ M: interactor stream-read-quot
         ]
     } cond ;
 
-: pass-to-popup ( gesture interactor -- ? )
-    popup>> focusable-child resend-gesture ;
-
 : interactor-operation ( gesture interactor -- ? )
     [ token-model>> value>> ] keep word-at-caret
     [ nip ] [ gesture>operation ] 2bi dup [ invoke-command f ] [ 2drop t ] if ;

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

@@ -1,30 +1,9 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors documents.elements kernel math math.vectors
+USING: accessors documents.elements kernel math.rectangles
-math.rectangles math.rectangles.positioning sequences ui.gadgets
+math.vectors ui.gadgets.editors ui.gadgets.glass ;
-ui.gadgets.editors ui.gadgets.glass ui.gadgets.tracks
-ui.gadgets.wrappers ui.gadgets.worlds ui.gestures ;
 IN: ui.tools.listener.popups
 
-SLOT: popup
-
-TUPLE: popup < wrapper interactor element ;
-
-: <popup> ( interactor element gadget -- popup )
-    popup new-wrapper
-        swap >>element
-        swap >>interactor ;
-
-M: popup hide-glass-hook
-    interactor>> f >>popup request-focus ;
-
-: hide-popup ( popup -- )
-    find-world hide-glass ;
-
-popup H{
-    { T{ key-down f f "ESC" } [ hide-popup ] }
-} set-gestures
-
 : caret-loc ( interactor element -- loc )
     [
         [ [ editor-caret ] [ model>> ] bi ] dip
@@ -32,13 +11,8 @@ popup H{
     ] [ drop ] 2bi
     loc>point ;
 
-: relevant-rect ( popup -- rect )
+: relevant-rect ( interactor element -- rect )
-    [ interactor>> ] [ element>> ] bi
+    [ caret-loc ] [ drop caret-dim { 0 1 } v+ ] 2bi <rect> ;
-    [ caret-loc ] [ drop caret-dim { 0 1 } v+ ] 2bi
-    <rect> ;
 
-: show-popup ( interactor element popup -- )
+: show-listener-popup ( interactor element popup -- )
-    <popup>
+    [ [ drop ] [ relevant-rect ] 2bi ] dip swap show-popup ;
-    [ dup interactor>> (>>popup) ]
-    [ [ interactor>> ] [ ] [ relevant-rect ] tri show-glass ]
-    bi ;