Debugging and demo for the cursor drift

This is for owickstrom#53

examples/LaggyUIDemo.hs

@@ -0,0 +1,39 @@
+module LaggyUIDemo where
+
+import Control.Monad (void)
+import Control.Concurrent
+import qualified GI.Gtk as Gtk
+import qualified GI.Gdk as Gdk
+import qualified GI.GLib as GLib
+
+-- Demo of what happens when your render loop is too slow
+-- Type really fast and observe the cursor drifting to the beginning
+
+main :: IO ()
+main = do
+  void $ Gtk.init Nothing
+
+  win <- Gtk.windowNew Gtk.WindowTypeToplevel
+  void $ Gtk.onWidgetDestroy win Gtk.mainQuit
+
+  box <- Gtk.boxNew Gtk.OrientationVertical 2
+  entry <- Gtk.entryNew
+  chan <- newChan
+
+  void $ Gtk.onEditableChanged entry $ do
+    str <- Gtk.entryGetText entry
+    writeChan chan str
+
+  void $ forkOS $ sequence_ $ repeat $ do
+    str <- readChan chan
+    threadDelay 100000 -- some arbitrary delay, the equivalent of updating the
+    -- state and generating a new view
+    Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do
+      Gtk.entrySetText entry str
+      return False
+
+  Gtk.containerAdd box entry
+  Gtk.containerAdd win box
+
+  Gtk.widgetShowAll win
+  Gtk.main

examples/Main.hs

@@ -18,6 +18,7 @@ import qualified ManyBoxes
 import qualified MenuBar
 import qualified Paned
 import qualified Todo
+import qualified LaggyUIDemo
 
 main :: IO ()
 main =
@@ -35,6 +36,7 @@ main =
                  , ("Paned", Paned.main)
                  , ("Dialog", Dialog.main)
                  , ("Todo", Todo.main)
+                 , ("LaggyUIDemo", LaggyUIDemo.main)
                  ]
   in getArgs >>= \case
     [example] ->

examples/Todo.hs

@@ -12,6 +12,7 @@ import qualified Data.Vector.Mutable           as MVector
 import qualified GI.Gtk                        as Gtk
 import           GI.Gtk.Declarative
 import qualified GI.Gtk.Declarative.App.Simple as GtkS
+import Control.Concurrent
 
 data Todo = Todo
   { name :: Text
@@ -32,18 +33,18 @@ data Event
 view' :: State -> GtkS.AppView Gtk.Window Event
 view' s = bin
   Gtk.Window
-  [ #title := "Todo App"
-  , on #deleteEvent (const (True, Closed))
+  [
+   on #deleteEvent (const (True, Closed))
   ]
   (container Gtk.Box
-             [#orientation := Gtk.OrientationVertical]
-             [todoList, newTodoForm]
+             []
+             [newTodoForm]
   )
   where
     todoList =
       BoxChild defaultBoxChildProperties { expand = True, fill = True }
         $ container Gtk.Box
-                    [#orientation := Gtk.OrientationVertical]
+                    []
                     (Vector.imap todoItem (todos s))
     todoItem i todo = bin Gtk.CheckButton [#active := completed todo, on #toggled (TodoToggled i)]
       $ widget Gtk.Label
@@ -58,9 +59,11 @@ view' s = bin
     newTodoForm = widget
       Gtk.Entry
       [ #text := currentText s
-      , #placeholderText := "What needs to be done?"
-      , onM #changed (fmap TodoTextChanged . Gtk.entryGetText)
-      , on #activate TodoSubmitted
+      -- , #placeholderText := "What needs to be done?"
+      , onM #changed $ \w -> do
+        threadDelay 100000
+        (fmap TodoTextChanged . Gtk.entryGetText $ w)
+      -- , on #activate TodoSubmitted
       ]
 
 
@@ -82,4 +85,4 @@ mapAt :: Int -> (a -> a) -> Vector a -> Vector a
 mapAt i f = Vector.modify (\v -> MVector.write v i . f =<< MVector.read v i)
 
 main :: IO ()
-main = void $ GtkS.run GtkS.App {GtkS.view = view', GtkS.update = update', GtkS.inputs = [], GtkS.initialState = State {todos = mempty, currentText = mempty}}
+main = void $ GtkS.run GtkS.App {GtkS.view = view', GtkS.update = update', GtkS.inputs = [], GtkS.initialState = State {todos = mempty, currentText = "Buy milk"}}

examples/examples.cabal

@@ -21,6 +21,7 @@ executable example
                       , CSS
                       , CustomWidget
                       , ComboBoxText
+                      , LaggyUIDemo
                       , Dialog
                       , Exit
                       , FileChooserButton
@@ -37,6 +38,7 @@ executable example
                       , gi-gobject
                       , gi-glib
                       , gi-gtk
+                      , gi-gtk-hs
                       , gi-gtk-declarative
                       , gi-gtk-declarative-app-simple
                       , gi-gdk

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

@@ -13,6 +13,7 @@ module GI.Gtk.Declarative.Attributes.Collected
   , collectAttributes
   , constructProperties
   , updateProperties
+  , updatePropertiesSingleWidget
   , updateClasses
   )
 where
@@ -30,6 +31,9 @@ import           GHC.TypeLits
 import           Data.Vector                              ( Vector )
 
 import           GI.Gtk.Declarative.Attributes
+import Control.Concurrent (threadDelay)
+import Control.Monad (when)
+import Debug.Trace (trace)
 
 -- | A collected property key/value pair, to be used when
 -- settings properties when patching widgets.
@@ -105,7 +109,8 @@ updateProperties (widget' :: widget) oldProps newProps = do
       setOps = mconcat
         (HashMap.elems (HashMap.intersectionWith toMaybeSetOp oldProps newProps)
         )
-  GI.set widget' (map (toSetOp (Proxy @widget)) toAdd <> setOps)
+  let props = (map (toSetOp (Proxy @widget)) toAdd <> setOps)
+  GI.set widget' props
  where
   toSetOp
     :: Proxy widget
@@ -122,11 +127,64 @@ updateProperties (widget' :: widget) oldProps newProps = do
       Just Refl | v1 /= v2 -> pure (attr Gtk.:= v2)
       _                    -> mempty
 
+updatePropertiesSingleWidget
+  :: Typeable widget => widget -> CollectedProperties widget -> CollectedProperties widget -> IO ()
+updatePropertiesSingleWidget (widget' :: widget) oldProps newProps = do
+  let toAdd  = HashMap.elems (HashMap.difference newProps oldProps)
+      toAddKeys  = HashMap.keys (HashMap.difference newProps oldProps)
+      setOps = mconcat
+        (HashMap.elems setOpsHM
+        )
+      setOpsHM = (HashMap.intersectionWith toMaybeSetOp oldProps newProps)
+      setOpsKeys = mconcat
+        (HashMap.keys setOpsHM
+        )
+  putStrLn ("updateProperties toAdd: " ++ show toAddKeys ++ " setOps: " ++ show setOpsKeys)
+  -- threadDelay 1000000
+  let props = (map (toSetOp (Proxy @widget)) toAdd <> setOps)
+  mapM_ getOp setOps
+  -- when (not $ null props) $ do
+  GI.set widget' props
+  -- putStrLn ("after updateProperties toAdd: " ++ show toAddKeys ++ " setOps: " ++ show setOpsKeys)
+  -- threadDelay 1000000
+ where
+  getOp :: Gtk.AttrOp widget 'GI.AttrSet -> IO ()
+  getOp (k Gtk.:= (v :: t)) =
+    case eqT @widget @Gtk.Entry of
+      Just Refl -> do
+        putStrLn "Found entry"
+        t <- Gtk.entryGetText widget'
+        putStrLn ("getOp " ++ show t)
+
+      _ -> putStrLn "Got something else"
+  getOp _ = return ()
+  toSetOp
+    :: Proxy widget
+    -> CollectedProperty widget
+    -> Gtk.AttrOp widget 'GI.AttrSet
+  toSetOp _ (CollectedProperty attr value) = attr Gtk.:= value
+
+  toMaybeSetOp
+    :: CollectedProperty widget
+    -> CollectedProperty widget
+    -> [Gtk.AttrOp widget 'GI.AttrSet]
+  toMaybeSetOp (CollectedProperty attr (v1 :: t1)) (CollectedProperty _ (v2 :: t2))
+    = case eqT @t1 @t2 of
+      Just Refl | v1 /= v2 ->
+        case eqT @t1 @Text of
+          Just Refl -> trace ("toMaybeSetOp: " ++ show (v1, v2)) $ pure (attr Gtk.:= v2)
+          _ -> pure (attr Gtk.:= v2)
+      _                    -> mempty
+
 -- | Update the style context's classes to only include the new set of
 -- classes (last argument).
 updateClasses :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO ()
 updateClasses sc old new = do
   let toAdd    = HashSet.difference new old
       toRemove = HashSet.difference old new
+  -- putStrLn ("updateClasses toAdd: " ++ show toAdd ++ " toRemove: " ++ show toRemove)
+  -- threadDelay 1000000
   mapM_ (Gtk.styleContextAddClass sc)    toAdd
   mapM_ (Gtk.styleContextRemoveClass sc) toRemove
+  -- putStrLn ("after updateClasses toAdd: " ++ show toAdd ++ " toRemove: " ++ show toRemove)
+  -- threadDelay 1000000

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

@@ -28,6 +28,7 @@ import           GI.Gtk.Declarative.EventSource
 import           GI.Gtk.Declarative.Patch
 import           GI.Gtk.Declarative.State
 import           GI.Gtk.Declarative.Widget
+import Control.Concurrent (threadDelay)
 
 -- | Declarative version of a /leaf/ widget, i.e. a widget without any children.
 data SingleWidget widget event where
@@ -43,6 +44,7 @@ instance Functor (SingleWidget widget) where
 instance Patchable (SingleWidget widget) where
   create = \case
     SingleWidget ctor attrs -> do
+        putStrLn "Patchable SingleWidget create"
         let collected = collectAttributes attrs
         widget' <- Gtk.new ctor (constructProperties collected)
         Gtk.widgetShow widget'
@@ -56,14 +58,20 @@ instance Patchable (SingleWidget widget) where
         (SingleWidget (ctor :: Gtk.ManagedPtr w2 -> w2) newAttributes) =
     case (st, eqT @w @w1, eqT @w1 @w2) of
       (StateTreeWidget top, Just Refl, Just Refl) -> Modify $ do
+        putStrLn "Patchable SingleWidget Modify"
+        -- threadDelay 1000000
         let w = stateTreeWidget top
         let oldCollected = stateTreeCollectedAttributes top
             newCollected = collectAttributes newAttributes
-        updateProperties w (collectedProperties oldCollected) (collectedProperties newCollected)
-        updateClasses (stateTreeStyleContext top) (collectedClasses oldCollected) (collectedClasses newCollected)
+        updatePropertiesSingleWidget w (collectedProperties oldCollected) (collectedProperties newCollected)
+        -- updateClasses (stateTreeStyleContext top) (collectedClasses oldCollected) (collectedClasses newCollected)
         let top' = top { stateTreeCollectedAttributes = newCollected }
+        putStrLn "After Patchable SingleWidget Modify"
+        -- threadDelay 1000000
         return (SomeState (StateTreeWidget top' { stateTreeCollectedAttributes = newCollected }))
-      _ -> Replace (create (SingleWidget ctor newAttributes))
+      _ -> Replace $ do
+        putStrLn "Patchable SingleWidget Replace"
+        (create (SingleWidget ctor newAttributes))
 
 instance EventSource (SingleWidget widget) where
   subscribe (SingleWidget (_ :: Gtk.ManagedPtr w1 -> w1) props) (SomeState (st :: StateTree stateType w2 child event cs)) cb =