[Draft] Multiple top-level windows (and some questions)

examples/Main.hs

@@ -18,6 +18,7 @@ import qualified ManyBoxes
 import qualified MenuBar
 import qualified Notebook
 import qualified Paned
+import qualified Windows
 
 main :: IO ()
 main =
@@ -36,6 +37,7 @@ main =
           , ("CSS"              , CSS.main)
           , ("Paned"            , Paned.main)
           , ("Dialog"           , Dialog.main)
+          , ("Windows"          , Windows.main)
           ]
   in  getArgs >>= \case
         [example] -> case lookup example examples of

examples/Windows.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Windows where
+
+import           Control.Concurrent            (threadDelay)
+import           Control.Monad                 (void)
+import           Data.Text                     (pack)
+import           Data.Vector                   (Vector)
+import qualified Data.Vector                   as Vector
+import           Pipes.Prelude                 (repeatM)
+
+import           GI.Gtk                        (Box (..), Button (..),
+                                                Label (..), Orientation (..),
+                                                Window (..))
+import           GI.Gtk.Declarative
+import           GI.Gtk.Declarative.App.Simple
+
+type State = Vector (Maybe Int)
+
+data Event
+  = IncrAll
+  | AddWindow
+  | CloseWindow Int
+  | RemoveWindow
+  | Closed
+
+view' :: State -> AppView Window Event
+view' ns =
+  bin
+      Window
+      [ #title := "Windows"
+      , on #deleteEvent (const (True, Closed))
+      , #widthRequest := 200
+      , #heightRequest := 300
+      ]
+    $  container Box [#orientation := OrientationVertical, #spacing := 4, #margin := 4]
+    $  [addButton, removeButton ns]
+    <> Vector.imap windowLabel ns
+
+addButton :: BoxChild Event
+addButton = BoxChild defaultBoxChildProperties
+  $ widget Button [#label := "Add Window", on #clicked AddWindow]
+
+removeButton :: State -> BoxChild Event
+removeButton ns = BoxChild defaultBoxChildProperties $ widget
+  Button
+  [ #label := "Remove Window"
+  , #sensitive := (ns /= mempty)
+  , on #clicked RemoveWindow
+  ]
+
+windowLabel :: Int -> Maybe Int -> BoxChild Event
+windowLabel i n =
+  BoxChild defaultBoxChildProperties { padding = 4 }
+    $ windowHost (window i <$> n)
+    $ windowChild i n
+
+window :: Int -> Int -> Bin Window Event
+window i x = bin
+  Window
+  [ #title := pack ("Window " <> show i)
+  , on #deleteEvent (const (True, CloseWindow i))
+  ]
+  (widget Label [#label := pack ("Open for " <> show x <> " seconds")])
+
+windowChild :: Int -> Maybe Int -> Widget Event
+windowChild i = \case
+  Nothing -> widget Label [#label := pack ("Window " <> show i <> " Closed")]
+  Just _  -> widget Label [#label := pack ("Window " <> show i <> " Open")]
+
+update' :: State -> Event -> Transition State Event
+update' ns = \case
+  IncrAll       -> Transition (fmap succ <$> ns) (return Nothing)
+  AddWindow     -> Transition (ns `Vector.snoc` Just 1) (return Nothing)
+  CloseWindow i -> Transition
+    (Vector.imap (\i' n -> if i' == i then Nothing else n) ns)
+    (return Nothing)
+  RemoveWindow -> Transition (Vector.init ns) (return Nothing)
+  Closed       -> Exit
+
+main :: IO ()
+main = void $ run App
+  { view         = view'
+  , update       = update'
+  , inputs       = [incrPeriodically]
+  , initialState = []
+  }
+  where incrPeriodically = repeatM $ IncrAll <$ threadDelay (1000 * 1000)

examples/examples.cabal

@@ -31,6 +31,7 @@ executable example
                       , MenuBar
                       , Notebook
                       , Paned
+                      , Windows
   build-depends:        base >=4.10 && <5
                       , async
                       , bytestring

gi-gtk-declarative-app-simple/src/GI/Gtk/Declarative/App/Simple.hs

@@ -134,7 +134,7 @@ runLoop App {..} = do
             sub      <- subscribe newMarkup newState (publishEvent events)
             return (newState, sub)
           Replace createNew -> runUI $ do
-            Gtk.widgetDestroy =<< someStateWidget oldState
+            destroy oldState oldMarkup
             cancel oldSubscription
             newState <- createNew
             Gtk.widgetShowAll =<< someStateWidget newState

gi-gtk-declarative/gi-gtk-declarative.cabal

@@ -52,6 +52,7 @@ library
                       , GI.Gtk.Declarative.State
                       , GI.Gtk.Declarative.Widget
                       , GI.Gtk.Declarative.Widget.Conversions
+                      , GI.Gtk.Declarative.WindowHost
   build-depends:        base                   >=4.10 && <5
                       , containers             >= 0.6 && < 0.7
                       , data-default-class     >= 0.1  && <0.2

gi-gtk-declarative/src/GI/Gtk/Declarative.hs

@@ -42,3 +42,4 @@ import           GI.Gtk.Declarative.Widget     as Export
 import           GI.Gtk.Declarative.Widget.Conversions
                                                as Export
                                                 ( )
+import           GI.Gtk.Declarative.WindowHost as Export

gi-gtk-declarative/src/GI/Gtk/Declarative/Bin.hs

@@ -106,7 +106,7 @@ instance (Gtk.IsBin parent) => Patchable (Bin parent) where
               case patch oldChildState oldChild newChild of
                 Modify  modify    -> SomeState . StateTreeBin top' <$> modify
                 Replace createNew -> do
-                  Gtk.widgetDestroy =<< someStateWidget oldChildState
+                  destroy oldChildState oldChild
                   newChildState <- createNew
                   childWidget   <- someStateWidget newChildState
                   Gtk.widgetShow childWidget
@@ -118,6 +118,14 @@ instance (Gtk.IsBin parent) => Patchable (Bin parent) where
             else Replace (create (Bin ctor newAttributes newChild))
       _ -> Replace (create (Bin ctor newAttributes newChild))
 
+  destroy (SomeState st) (Bin _ _ child) = do
+    case st of
+      StateTreeBin node childState -> do
+        destroy childState child
+        Gtk.toWidget (stateTreeWidget node) >>= Gtk.widgetDestroy
+      _ ->
+        error "Bin destroy method called with non-StateTreeBin state"
+
 --
 -- EventSource
 --

gi-gtk-declarative/src/GI/Gtk/Declarative/Container.hs

@@ -127,6 +127,14 @@ instance
                   (unChildren newChildren)
               else Replace (create new)
       _ -> Replace (create new)
+
+  destroy (SomeState (st :: StateTree stateType w c e cs)) (Container _ _ (children :: Children child e2)) = do
+    case st of
+      StateTreeContainer top childStates -> do
+        sequence_ (Vector.zipWith destroy childStates (unChildren children))
+        Gtk.toWidget (stateTreeWidget top) >>= Gtk.widgetDestroy
+      _ ->
+        error "Container destroy method called with non-StateTreeContainer state"
 
 --
 -- EventSource

gi-gtk-declarative/src/GI/Gtk/Declarative/Container/Box.hs

@@ -57,6 +57,7 @@ instance Patchable BoxChild where
   create = create . child
   patch s b1 b2 | properties b1 == properties b2 = patch s (child b1) (child b2)
                 | otherwise                      = Replace (create b2)
+  destroy s b = destroy s (child b)
 
 instance EventSource BoxChild where
   subscribe BoxChild {..} = subscribe child

gi-gtk-declarative/src/GI/Gtk/Declarative/Container/Grid.hs

@@ -54,6 +54,7 @@ instance Patchable GridChild where
   create = create . child
   patch s b1 b2 | properties b1 == properties b2 = patch s (child b1) (child b2)
                 | otherwise                      = Replace (create b2)
+  destroy s b = destroy s (child b)
 
 instance EventSource GridChild where
   subscribe GridChild {..} = subscribe child
@@ -68,4 +69,3 @@ instance IsContainer Gtk.Grid GridChild where
   replaceChild grid gridChild' _i old new = do
     Gtk.widgetDestroy old
     appendChild grid gridChild' new
-

gi-gtk-declarative/src/GI/Gtk/Declarative/Container/MenuItem.hs

@@ -66,7 +66,7 @@ menuItem
   -> MenuItem event
 menuItem item attrs = MenuItem . Bin item attrs
 
--- | Construct a sub menu for a 'Gtk.Menu', wit a text label and the
+-- | Construct a sub menu for a 'Gtk.Menu', with a text label and the
 -- child menu items.
 subMenu :: Text -> Vector (MenuItem event) -> MenuItem event
 subMenu label = SubMenu label . container Gtk.Menu mempty
@@ -104,6 +104,14 @@ instance Patchable MenuItem where
     -- TODO: case for l1 /= l2
     _ -> Replace (create (SubMenu l2 c2))
   patch _ _ b2 = Replace (create b2)
+  destroy state (MenuItem (c :: Bin i e)) =
+    destroy state c
+  destroy (SomeState st) (SubMenu _ c) = case st of
+    StateTreeBin top childState -> do
+      destroy childState c
+      Gtk.toWidget (stateTreeWidget top) >>= Gtk.widgetDestroy
+    _ ->
+      error "Cannot destroy SubMenu with non-StateTreeBin state"
 
 instance EventSource MenuItem where
   subscribe (MenuItem item     ) state          cb = subscribe item state cb

gi-gtk-declarative/src/GI/Gtk/Declarative/Container/Paned.hs

@@ -69,6 +69,7 @@ pane paneProperties paneChild = Pane { .. }
 instance Patchable Pane where
   create = create . paneChild
   patch s b1 b2 = patch s (paneChild b1) (paneChild b2)
+  destroy s b = destroy s (paneChild b)
 
 instance EventSource Pane where
   subscribe Pane {..} = subscribe paneChild

gi-gtk-declarative/src/GI/Gtk/Declarative/Container/Patch.hs

@@ -76,11 +76,14 @@ patchInContainer (StateTreeContainer top children) container os' ns' = do
     -- widget in the corresponding place, we need to replace the GTK widget with
     -- one created from the declarative widget.
     (i, Just oldChildState, Nothing, Just new) -> do
+      error "this shouldn't happen!"
+      {-
       newChildState  <- create new
       oldChildWidget <- someStateWidget oldChildState
       newChildWidget <- someStateWidget newChildState
       replaceChild container new i oldChildWidget newChildWidget
       return (Vector.singleton newChildState)
+      -}
 
     -- When there is a new declarative widget, or one that lacks a corresponding
     -- GTK widget, create and add it.
@@ -92,8 +95,8 @@ patchInContainer (StateTreeContainer top children) container os' ns' = do
 
     -- When a declarative widget has been removed, remove the GTK widget from
     -- the container.
-    (_i, Just childState, Just _, Nothing) -> do
-      Gtk.widgetDestroy =<< someStateWidget childState
+    (_i, Just oldChildState, Just old, Nothing) -> do
+      destroy oldChildState old
       return Vector.empty
 
     -- When there are more old declarative widgets than GTK widgets, we can

gi-gtk-declarative/src/GI/Gtk/Declarative/CustomWidget.hs

@@ -118,6 +118,9 @@ instance
                   )
               | otherwise -> Replace (create new)
       _ -> Replace (create new)
+
+  destroy state _custom = 
+    someStateWidget state >>= Gtk.widgetDestroy
 
 instance
   (Typeable internalState, Gtk.GObject widget) =>

gi-gtk-declarative/src/GI/Gtk/Declarative/Patch.hs

@@ -34,3 +34,5 @@ class Patchable widget where
   -- | Given two declarative widgets of the same widget type (but not
   -- necessarily of the same event types,) calculate a 'Patch'.
   patch :: SomeState -> widget e1 -> widget e2 -> Patch
+  -- | Given a previously created declarative widget, destroy it.
+  destroy :: SomeState -> widget e -> IO ()

gi-gtk-declarative/src/GI/Gtk/Declarative/SingleWidget.hs

@@ -78,6 +78,8 @@ instance Patchable (SingleWidget widget) where
                 )
             else Replace (create (SingleWidget ctor newAttributes))
       _ -> Replace (create (SingleWidget ctor newAttributes))
+  destroy state _ =
+    someStateWidget state >>= Gtk.widgetDestroy
 
 instance EventSource (SingleWidget widget) where
   subscribe (SingleWidget (_ :: Gtk.ManagedPtr w1 -> w1) props) (SomeState (st :: StateTree

gi-gtk-declarative/src/GI/Gtk/Declarative/Widget.hs

@@ -44,6 +44,7 @@ instance Patchable Widget where
   patch s (Widget (w1 :: t1 e1)) (Widget (w2 :: t2 e2)) = case eqT @t1 @t2 of
     Just Refl -> patch s w1 w2
     _         -> Replace (create w2)
+  destroy s (Widget w) = destroy s w
 
 instance EventSource Widget where
   subscribe (Widget w) = subscribe w