Merge git://factorcode.org/git/factor

extra/tools/test/ui/ui.factor

@@ -1,5 +1,5 @@
 USING: dlists ui.gadgets kernel ui namespaces io.streams.string
-io ;
+io ui.private ;
 IN: tools.test.ui
 
 ! We can't print to stdio here because that might be a pane

extra/ui/backend/backend.factor

@@ -7,7 +7,9 @@ SYMBOL: ui-backend
 
 HOOK: set-title ui-backend ( string world -- )
 
-HOOK: (open-world-window) ui-backend ( world -- )
+HOOK: (open-window) ui-backend ( world -- )
+
+HOOK: (close-window) ui-backend ( handle -- )
 
 HOOK: raise-window ui-backend ( world -- )
 

extra/ui/gadgets/editors/editors-tests.factor

@@ -1,5 +1,5 @@
 USING: ui.gadgets.editors tools.test kernel io io.streams.plain
-definitions namespaces ui.gadgets
+definitions namespaces ui.gadgets ui.private
 ui.gadgets.grids prettyprint documents ui.gestures
 tools.test.inference tools.test.ui models ;
 

extra/ui/gadgets/gadgets-tests.factor

@@ -2,7 +2,7 @@ IN: temporary
 USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
 namespaces models kernel tools.test.inference dlists math
 math.parser ui sequences hashtables assocs io arrays
-prettyprint io.streams.string ;
+prettyprint io.streams.string ui.private ;
 
 [ T{ rect f { 10 10 } { 20 20 } } ]
 [

extra/ui/gadgets/scrollers/scrollers-tests.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: ui.gadgets ui.gadgets.scrollers
+USING: ui.gadgets ui.gadgets.scrollers ui.private
 namespaces tools.test kernel models ui.gadgets.viewports
 ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
 ui.gadgets.sliders math math.vectors arrays sequences

extra/ui/gadgets/scrollers/scrollers.factor

@@ -89,7 +89,7 @@ scroller H{
         3drop
     ] if ;
 
-: (scroll>gadget) ( rect scroller -- )
+: (scroll>gadget) ( gadget scroller -- )
     >r { 0 0 } over pref-dim <rect> swap r>
     [ relative-scroll-rect ] keep
     (scroll>rect) ;

extra/ui/gadgets/worlds/worlds.factor

@@ -115,13 +115,3 @@ world H{
 : close-global ( world global -- )
     dup get-global find-world rot eq?
     [ f swap set-global ] [ drop ] if ;
-
-: focus-gestures ( new old -- )
-    drop-prefix <reversed>
-    T{ lose-focus } swap each-gesture
-    T{ gain-focus } swap each-gesture ;
-
-M: world graft*
-    dup (open-world-window)
-    dup world-title over set-title
-    request-focus ;

extra/ui/tools/browser/browser-tests.factor

@@ -1,6 +1,6 @@
 IN: temporary
 USING: tools.test tools.test.ui ui.tools.browser
-tools.test.inference ;
+tools.test.inference ui.private ;
 
 { 0 1 } [ <browser-gadget> ] unit-test-effect
 [ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test

extra/ui/tools/listener/listener-tests.factor

@@ -1,7 +1,7 @@
 USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
 timers tools.test ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.panes vocabs words tools.test.ui ;
+ui.gadgets.panes vocabs words tools.test.ui ui.private ;
 IN: temporary
 
 timers [ init-timers ] unless

extra/ui/tools/search/search-tests.factor

@@ -1,6 +1,6 @@
 USING: assocs ui.tools.search help.topics io.files io.styles
 kernel namespaces sequences source-files threads timers
-tools.test ui.gadgets ui.gestures vocabs
+tools.test ui.gadgets ui.gestures ui.private vocabs
 vocabs.loader words tools.test.ui debugger ;
 IN: temporary
 

extra/ui/tools/tools-tests.factor

@@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
 ui.tools.search ui.tools.workspace kernel models namespaces
 sequences timers tools.test ui.gadgets ui.gadgets.buttons
 ui.gadgets.labelled ui.gadgets.presentations
-ui.gadgets.scrollers vocabs tools.test.ui ui ;
+ui.gadgets.scrollers vocabs tools.test.ui ui ui.private ;
 IN: temporary
 
 [

extra/ui/tools/walker/walker-tests.factor

@@ -1,6 +1,6 @@
 USING: arrays continuations ui.tools.listener ui.tools.walker
 ui.tools.workspace inspector kernel namespaces sequences threads
-listener tools.test ui ui.gadgets ui.gadgets.worlds
+listener tools.test ui ui.gadgets ui.gadgets.worlds ui.private
 ui.gadgets.packs vectors ui.tools tools.interpreter
 tools.interpreter.debug tools.test.inference tools.test.ui ;
 IN: temporary

extra/ui/tools/workspace/workspace.factor

@@ -70,7 +70,7 @@ M: gadget tool-scroller drop f ;
     [ find-workspace hide-popup ] <debugger>
     "Error" show-titled-popup ;
 
-M: workspace pref-dim* drop { 600 750 } ;
+M: workspace pref-dim* drop { 600 700 } ;
 
 M: workspace focusable-child*
     dup workspace-popup [ ] [ workspace-listener ] ?if ;

extra/ui/ui-docs.factor

@@ -34,7 +34,7 @@ HELP: ui
 HELP: start-ui
 { $description "Called by the UI backend to initialize the platform-independent parts of UI. This word should be called after the backend is ready to start displaying new windows, and before the event loop starts." } ;
 
-HELP: (open-world-window)
+HELP: (open-window)
 { $values { "world" world } }
 { $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
 { $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
@@ -44,11 +44,6 @@ HELP: ui-try
 { $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
 { $notes "This is essentially a graphical variant of " { $link try } "." } ;
 
-HELP: stop-world
-{ $values { "world" world } }
-{ $description "Stops a world." }
-{ $notes "This word should only be called by the UI backend, and not user code." } ;
-
 ARTICLE: "ui-glossary" "UI glossary"
 { $table
     { "color specifier"
@@ -177,9 +172,8 @@ ARTICLE: "ui-backend-windows" "UI backend window management"
 "This word can also be called directly if the UI backend is notified by the window system that window contents have been invalidated. Before and after drawing, two words are called, which the UI backend must implement:"
 { $subsection select-gl-context }
 { $subsection flush-gl-context }
-"If the user clicks the window's close box, you must call the following two words in sequence:"
-{ $subsection stop-world }
-{ $subsection unregister-window } ;
+"If the user clicks the window's close box, you must call the following word:"
+{ $subsection close-window } ;
 
 ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
 "A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."

extra/ui/ui.factor

@@ -28,10 +28,17 @@ SYMBOL: windows
 : unregister-window ( handle -- )
     windows global [ [ first = not ] curry* subset ] change-at ;
 
+<PRIVATE
+
 : raised-window ( world -- )
     windows get-global [ second eq? ] curry* find drop
     windows get-global [ length 1- ] keep exchange ;
 
+: focus-gestures ( new old -- )
+    drop-prefix <reversed>
+    T{ lose-focus } swap each-gesture
+    T{ gain-focus } swap each-gesture ;
+
 : focus-world ( world -- )
     t over set-world-focused?
     dup raised-window
@@ -41,18 +48,27 @@ SYMBOL: windows
     f over set-world-focused?
     focus-path f swap focus-gestures ;
 
+M: world graft*
+    dup (open-window)
+    dup world-title over set-title
+    request-focus ;
+
 : reset-world ( world -- )
+    #! This is used when a window is being closed, but also
+    #! when restoring saved worlds on image startup.
     dup world-fonts clear-assoc
     dup unfocus-world
     f swap set-world-handle ;
 
-: stop-world ( world -- )
-    dup ungraft
+M: world ungraft*
+    dup free-fonts
     dup hand-clicked close-global
     dup hand-gadget close-global
-    dup free-fonts
+    dup world-handle (close-window)
     reset-world ;
 
+PRIVATE>
+
 : open-world-window ( world -- )
     dup pref-dim over set-gadget-dim dup relayout graft ;
 
@@ -60,13 +76,45 @@ SYMBOL: windows
     >r [ 1 track, ] { 0 1 } make-track r>
     f <world> open-world-window ;
 
+: close-window ( gadget -- )
+    find-world [ ungraft ] when* ;
+
 : find-window ( quot -- world )
     windows get values
     [ gadget-child swap call ] curry* find-last nip ; inline
 
+SYMBOL: ui-hook
+
+: init-ui ( -- )
+    <dlist> \ graft-queue set-global
+    <dlist> \ layout-queue set-global
+    V{ } clone windows set-global ;
+
+<PRIVATE
+
+: restore-gadget-later ( gadget -- )
+    dup gadget-graft-state {
+        { { f f } [ ] }
+        { { f t } [ ] }
+        { { t t } [
+            { f f } over set-gadget-graft-state
+        ] }
+        { { t f } [
+            dup unqueue-graft
+            { f f } over set-gadget-graft-state
+        ] }
+    } case graft-later ;
+
+: restore-gadget ( gadget -- )
+    dup restore-gadget-later
+    gadget-children [ restore-gadget ] each ;
+
+: restore-world ( world -- )
+    dup reset-world restore-gadget ;
+
 : restore-windows ( -- )
     windows get [ values ] keep delete-all
-    [ dup reset-world (open-world-window) ] each
+    [ restore-world ] each
     forget-rollover ;
 
 : restore-windows? ( -- ? )
@@ -84,13 +132,6 @@ SYMBOL: windows
         ] dlist-slurp
     ] { } make ;
 
-SYMBOL: ui-hook
-
-: init-ui ( -- )
-    <dlist> \ graft-queue set-global
-    <dlist> \ layout-queue set-global
-    V{ } clone windows set-global ;
-
 : redraw-worlds ( seq -- )
     [ dup update-hand draw-world ] each ;
 
@@ -105,6 +146,8 @@ SYMBOL: ui-hook
 : notify-queued ( -- )
     graft-queue [ notify ] dlist-slurp ;
 
+PRIVATE>
+
 : ui-step ( -- )
     [
         do-timers

extra/ui/windows/windows.factor

@@ -216,14 +216,14 @@ SYMBOL: hWnd
     dup win-hRC wglDeleteContext win32-error=0/f
     dup win-hWnd swap win-hDC ReleaseDC win32-error=0/f ;
 
-: handle-wm-close ( hWnd uMsg wParam lParam -- )
-    3drop
-    window [ world-handle ] keep
-    stop-world
+M: windows-ui-backend (close-window)
     dup win-hWnd unregister-window
     dup cleanup-window
     win-hWnd DestroyWindow win32-error=0/f ;
 
+: handle-wm-close ( hWnd uMsg wParam lParam -- )
+    3drop window ungraft ;
+
 : handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
     3drop window [ focus-world ] when* ;
 
@@ -414,7 +414,7 @@ SYMBOL: hWnd
 : setup-gl ( hwnd -- hDC hRC )
     get-dc dup setup-pixel-format dup get-rc ;
 
-M: windows-ui-backend (open-world-window) ( world -- )
+M: windows-ui-backend (open-window) ( world -- )
     [ rect-dim first2 create-window dup setup-gl ] keep
     [ f <win> ] keep
     [ swap win-hWnd register-window ] 2keep