QML reads in new treads UI changes and does max 10 updates per second

src/EffectfulQML.hs

@@ -4,21 +4,39 @@
 
 module EffectfulQML where
 
-import Control.Monad (forM_, when)
+import Control.Monad (forM_, void, when)
 import Effectful
+import Effectful.Concurrent
+import Effectful.Concurrent.Async (async)
+import Effectful.Concurrent.STM (TQueue, atomically, flushTQueue, newTQueueIO, readTQueue, writeTQueue)
 import Effectful.Dispatch.Dynamic (EffectHandler, interpret)
 import Effectful.State.Static.Shared (State, evalState, get, gets, put)
 import Effectful.TH
 import Graphics.QML qualified as QML
 
 import Logging
-import Types (AppState(..), UIReferences(..), UIUpdates(..))
+import Types (AppState(..), UIReferences(..), UIUpdates(..), emptyUpdates)
 
+
+-- | Effectful QML state.
 data EffectfulQMLState = EffectfulQMLState
   { signalKey :: Maybe (QML.SignalKey (IO ()))
   , rootObjRef :: Maybe (QML.ObjRef ())
+  , uiRefs :: UIReferences
+  , queue :: Maybe (TQueue UIUpdates)
   }
 
+
+-- | Initial effectful QML state.
+initialEffectfulQMLState :: EffectfulQMLState
+initialEffectfulQMLState = EffectfulQMLState Nothing Nothing initialUIRefs Nothing
+
+
+-- | Initial UI references.
+initialUIRefs :: UIReferences
+initialUIRefs = UIReferences Nothing Nothing Nothing Nothing Nothing
+
+
 -- | Define the effects for QML operations.
 data EffectfulQML :: Effect where
   RunEngineLoop :: QML.EngineConfig -> QML.SignalKey (IO ()) -> QML.ObjRef () -> EffectfulQML m ()
@@ -33,51 +51,51 @@ type instance DispatchOf EffectfulQML = Dynamic
 
 makeEffect ''EffectfulQML
 
+
 -- | Handler for the QML effects.
 runEffectfulQML
-  :: (IOE :> es, Logging :> es, State AppState :> es)
-  => Eff (EffectfulQML : State EffectfulQMLState : es) a
+  :: (IOE :> es, Concurrent :> es, Logging :> es, State EffectfulQMLState :> es, State AppState :> es)
+  => Eff (EffectfulQML : es) a
   -> Eff es a
-runEffectfulQML action = evalState (EffectfulQMLState Nothing Nothing) $ interpret handleEffectfulQML action
-  where
-    handleEffectfulQML
-      :: (IOE :> es, Logging :> es, State AppState :> es)
-      => EffectHandler EffectfulQML (State EffectfulQMLState : es)
-    handleEffectfulQML _ = \case
-      RunEngineLoop config changeKey ctx -> do
-        put $ EffectfulQMLState (Just changeKey) (Just ctx)
+runEffectfulQML = interpret $ \_ -> \case
+    RunEngineLoop config changeKey ctx -> do
+        q <- newTQueueIO
+        put $ EffectfulQMLState (Just changeKey) (Just ctx) initialUIRefs (Just q)
+        void $ async $ do
+          uiUpdates <- atomically $ readTQueue q
+          moreUpdates <- atomically $ flushTQueue q
+          let combinedUpdates = uiUpdates <> mconcat moreUpdates
+
+          refs <- gets uiRefs
+
+          when (profilesChanged combinedUpdates) $ forM_ (profileObjRef refs) (liftIO . QML.fireSignal changeKey)
+          when (followsChanged combinedUpdates) $ forM_ (followsObjRef refs) (liftIO . QML.fireSignal changeKey)
+          when (chatsChanged combinedUpdates) $ forM_ (chatObjRef refs) (liftIO . QML.fireSignal changeKey)
+          when (dmRelaysChanged combinedUpdates) $ forM_ (dmRelaysObjRef refs) (liftIO . QML.fireSignal changeKey)
+          when (generalRelaysChanged combinedUpdates) $ forM_ (generalRelaysObjRef refs) (liftIO . QML.fireSignal changeKey)
+
+          threadDelay 100000 -- max 10 UI updates per second
+
         liftIO $ QML.runEngineLoop config
 
-      CreateSignalKey -> liftIO $ QML.newSignalKey
+    CreateSignalKey -> liftIO $ QML.newSignalKey
 
-      FireSignal obj -> do
+    FireSignal obj -> do
         st <- get
         case signalKey st of
           Just key -> liftIO $ QML.fireSignal key obj
           Nothing -> logError "No signal key available"
 
-      NotifyRelayStatus -> do
+    NotifyRelayStatus -> do
         st <- get
-        refs <- gets @AppState uiRefs
-        case signalKey st of
-          Just key -> do
-            forM_ (dmRelaysObjRef refs) (liftIO . QML.fireSignal key)
-            forM_ (generalRelaysObjRef refs) (liftIO . QML.fireSignal key)
-          Nothing -> logError "No signal key available"
+        case queue st of
+          Just q -> do
+            let updates = emptyUpdates { dmRelaysChanged = True, generalRelaysChanged = True }
+            atomically $ writeTQueue q updates
+          Nothing -> logError "No queue available"
 
-      Notify u -> do
+    Notify u -> do
         st <- get
-        refs <- gets @AppState uiRefs
-        case signalKey st of
-          Just key -> do
-            when (profilesChanged u) $ forM_ (profileObjRef refs) (liftIO . QML.fireSignal key)
-            when (followsChanged u) $ forM_ (followsObjRef refs) (liftIO . QML.fireSignal key)
-            when (chatsChanged u) $ forM_ (chatObjRef refs) (liftIO . QML.fireSignal key)
-            when (dmRelaysChanged u) $ forM_ (dmRelaysObjRef refs) (liftIO . QML.fireSignal key)
-            when (generalRelaysChanged u) $ forM_ (generalRelaysObjRef refs) (liftIO . QML.fireSignal key)
-            -- there is no obj ref for publish status
-            --when (publishStatusChanged u) $ forM_ (publishStatusObjRef refs) (liftIO . QML.fireSignal key)
-            -- there is no obj ref for notices
-            --when (noticesChanged u) $ forM_ (noticesObjRef refs) (liftIO . QML.fireSignal key)
-          Nothing -> logError "No signal key available"
-
+        case queue st of
+          Just q -> atomically $ writeTQueue q u
+          Nothing -> logError "No queue available"

src/Futr.hs

@@ -90,6 +90,7 @@ type FutrEff es = ( State AppState :> es
                   , Publisher :> es
                   , State PKeyMgmt.KeyMgmtState :> es
                   , State RelayPoolState :> es
+                  , State EffectfulQMLState :> es
                   , GiftWrap :> es
                   , EffectfulQML :> es
                   , Logging :> es
@@ -129,10 +130,7 @@ runFutr = interpret $ \_ -> \case
     case bech32ToPubKeyXO npub' of
       Just pk -> do
         modify @AppState $ \st -> st { currentProfile = Just pk }
-        refs <- gets @AppState uiRefs
-        case profileObjRef refs of
-          Just obj' -> fireSignal obj'
-          Nothing -> return ()
+        notify $ emptyUpdates { profilesChanged = True }
       Nothing -> do
         logError $ "Invalid npub, cannot set current profile: " <> npub'
         return ()
@@ -147,9 +145,7 @@ runFutr = interpret $ \_ -> \case
                 let newFollow = Follow pubKeyXO Nothing Nothing
                 let newFollows = newFollow : currentFollows
                 modify $ \st' -> st' { follows = Map.insert userPK newFollows (follows st') }
-                -- Notify follows UI component
-                refs <- gets @AppState uiRefs
-                forM_ (followsObjRef refs) fireSignal
+                notify $ emptyUpdates { followsChanged = True }
             sendFollowListEvent
         Nothing -> return ()
 
@@ -162,9 +158,7 @@ runFutr = interpret $ \_ -> \case
             let currentFollows = Map.findWithDefault [] userPK (follows st)
             let newFollows = filter (\follow -> pubkey follow /= pubKeyXO) currentFollows
             modify $ \st' -> st' { follows = Map.insert userPK newFollows (follows st') }
-            -- Notify follows UI component
-            refs <- gets @AppState uiRefs
-            forM_ (followsObjRef refs) fireSignal
+            notify $ emptyUpdates { followsChanged = True }
             sendFollowListEvent
         Nothing -> return ()
 
@@ -176,8 +170,7 @@ runFutr = interpret $ \_ -> \case
       _ -> return ()
 
     modify $ \st' -> st' { currentChatRecipient = (Just [pubKeyXO], Nothing) }
-    refs <- gets @AppState uiRefs
-    forM_ (chatObjRef refs) fireSignal  -- Notify chat UI component
+    notify $ emptyUpdates { chatsChanged = True }
 
   SendMessage input -> do
     st <- get @AppState

src/Main.hs

@@ -3,11 +3,11 @@ module Main where
 import Effectful
 import Effectful.Concurrent (runConcurrent)
 import Effectful.FileSystem (runFileSystem)
-import Effectful.State.Static.Shared (State,evalState)
-import EffectfulQML
+import Effectful.State.Static.Shared (State, evalState)
 import Graphics.QML qualified as QML
 import System.Environment (setEnv)
 
+import EffectfulQML
 import Futr qualified as Futr
 import Logging (runLoggingStdout)
 import Nostr
@@ -38,13 +38,14 @@ main = do
 
     runEff
         . runLoggingStdout
+        . runConcurrent
         -- state related
         . withInitialState
         -- app related
+        . evalState initialEffectfulQMLState
         . runEffectfulQML
         . runFileSystem
         . runUtil
-        . runConcurrent
         -- nostr related
         . runNostr
         . KeyMgmt.runKeyMgmt
@@ -81,7 +82,7 @@ withInitialState
            : State AppState
            : es) a
     -> Eff es a
-withInitialState = 
-    evalState Types.initialState
+withInitialState
+    = evalState Types.initialState
     . evalState KeyMgmt.initialState
     . evalState Types.initialRelayPoolState

src/Presentation/RelayMgmt.hs

@@ -17,6 +17,7 @@ import Effectful.State.Static.Shared (State, get, modify)
 import Effectful.TH
 import Graphics.QML hiding (fireSignal, runEngineLoop)
 
+import EffectfulQML (EffectfulQMLState(..))
 import Nostr.Keys (keyPairToPubKeyXO)
 import Nostr.RelayPool
 import Nostr.Types hiding (displayName, picture)
@@ -30,6 +31,7 @@ data RelayType = DMRelays | InboxRelays | OutboxRelays
 type RelayMgmgtUIEff es =
   ( State AppState :> es
   , State RelayPoolState :> es
+  , State EffectfulQMLState :> es
   , RelayPool :> es
   , Concurrent :> es
   , Util :> es
@@ -122,7 +124,7 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action
 
         contextClass <- newClass [
           defPropertySigRO' "dmRelays" changeKey $ \obj -> do
-            runE $ modify @AppState $ \s -> s { 
+            runE $ modify @EffectfulQMLState $ \s -> s { 
               uiRefs = (uiRefs s) { dmRelaysObjRef = Just obj } 
             }
             appState <- runE $ get @AppState
@@ -134,7 +136,7 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action
                 mapM (\(relay, _status) -> getPoolObject dmRelayPool (getUri relay)) relaysWithStatus,
 
           defPropertySigRO' "generalRelays" changeKey $ \obj -> do
-            runE $ modify @AppState $ \s -> s { 
+            runE $ modify @EffectfulQMLState $ \s -> s { 
               uiRefs = (uiRefs s) { generalRelaysObjRef = Just obj } 
             }
             appState <- runE $ get @AppState

src/Types.hs

@@ -148,8 +148,6 @@ data AppState = AppState
   -- UI state
   , currentChatRecipient :: (Maybe [PubKeyXO], Maybe SubscriptionId)
   , currentProfile :: Maybe PubKeyXO
-  -- QML References
-  , uiRefs :: UIReferences
   }
 
 -- | UI object references grouped together
@@ -182,5 +180,4 @@ initialState = AppState
   , follows = Map.empty
   , currentChatRecipient = (Nothing, Nothing)
   , currentProfile = Nothing
-  , uiRefs = UIReferences Nothing Nothing Nothing Nothing Nothing
   }

src/UI.hs

@@ -20,6 +20,7 @@ import EffectfulQML
 import Graphics.QML hiding (fireSignal, runEngineLoop)
 import Text.Read (readMaybe)
 
+import EffectfulQML (EffectfulQMLState(..))
 import Logging
 import Nostr.Bech32
 import Nostr.Event
@@ -185,7 +186,7 @@ runUI = interpret $ \_ -> \case
 
         defPropertyConst' "currentProfile" (\_ -> do
           profileObj <- newObject profileClass ()
-          runE $ modify @AppState $ \st -> st { uiRefs = (uiRefs st) { profileObjRef = Just profileObj } }
+          runE $ modify @EffectfulQMLState $ \st -> st { uiRefs = (uiRefs st) { profileObjRef = Just profileObj } }
           return profileObj
         ),
 
@@ -253,7 +254,7 @@ runUI = interpret $ \_ -> \case
             Nothing -> return [],
 
         defPropertySigRO' "messages" changeKey' $ \obj -> do
-          runE $ modify @AppState $ \s -> s { uiRefs = (uiRefs s) { chatObjRef = Just obj } }
+          runE $ modify @EffectfulQMLState $ \s -> s { uiRefs = (uiRefs s) { chatObjRef = Just obj } }
           st <- runE $ get @AppState
           case currentChatRecipient st of
             (Just recipient, _) -> do