finish up effectful key mgmt

cabal.project

@@ -1,11 +1,8 @@
 packages:
+    /home/sasa/code/HsQML/
     ./
 tests: True
 
-source-repository-package
-  type: git
-  location: https://github.com/prolic/HsQML/
-  tag: e7fe83f9cc535c66c423d5402d3351c774a5bc2c
 
 source-repository-package
   type: git

futr.cabal

@@ -1,4 +1,4 @@
-cabal-version:      3.12
+cabal-version:      2.4
 name:               futr
 version:            0.1.0.0
 license:            GPL-3.0-only
@@ -29,6 +29,7 @@ executable futr
     hs-source-dirs:   src
 
     other-modules:
+        EffectfulQML
         Nostr.Effects.IDGen
         Nostr.Effects.Logging
         Nostr.Effects.RelayPool
@@ -43,7 +44,6 @@ executable futr
         Nostr.Relay
         Nostr.Types
         Presentation.KeyMgmt
-        QMLEffectful
         Types
 
     default-language: Haskell2010

src/EffectfulQML.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module EffectfulQML where
+
+import Data.Typeable
+import Effectful
+import Effectful.Dispatch.Dynamic (interpret)
+import Effectful.State.Static.Shared (State, get)
+import Effectful.TH
+import Graphics.QML hiding (fireSignal, runEngineLoop)
+import Graphics.QML qualified as QML
+
+-- | Data type to hold a signal key and object reference
+data SignalUpdate
+  = forall tt.
+  ( Typeable tt
+  ) =>
+  SignalUpdate
+  { signalKey :: SignalKey (IO ()),
+    object :: ObjRef tt
+  }
+
+-- | Define the effects for QML operations.
+data EffectfulQML :: Effect where
+  RunEngineLoop :: EngineConfig -> EffectfulQML m ()
+  FireSignal :: EffectfulQML m ()
+
+type instance DispatchOf EffectfulQML = Dynamic
+
+makeEffect ''EffectfulQML
+
+-- | Handler for the QML effects.
+runEffectfulQML :: (IOE :> es, State SignalUpdate :> es) => Eff (EffectfulQML : es) a -> Eff es a
+runEffectfulQML = interpret $ \_ -> \case
+  RunEngineLoop config -> do
+    liftIO $ QML.runEngineLoop config
+  FireSignal -> do
+    SignalUpdate key obj <- get
+    liftIO $ QML.fireSignal key obj

src/Main.hs

@@ -1,71 +1,58 @@
-{-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
-{-# LANGUAGE TypeFamilies         #-}
-
 module Main where
 
 import Control.Concurrent (MVar, modifyMVar_, newMVar, readMVar)
 import qualified Data.Map as Map
 import Data.Text (pack, unpack)
 import Data.Typeable (Typeable)
-import Graphics.QML
+import Effectful
+import Effectful.State.Static.Shared (State, evalState, execState, runState)
+import Graphics.QML qualified as QML
 import System.Environment (setEnv)
 import Text.Read (readMaybe)
 
 import Nostr.Keys (KeyPair, secKeyToKeyPair)
 import Presentation.KeyMgmt
+import QMLEffectful
 import Types
 
-data AppModel = AppModel
-    { keyPair :: Maybe KeyPair
-    , currentScreen :: AppScreen
-    , keyMgmtModel :: MVar KeyMgmtModel
-    } deriving (Typeable)
-
-createContext :: MVar AppModel -> SignalKey (IO ()) -> IO (ObjRef ())
+createContext :: SignalKey (IO ()) -> IO (QML.ObjRef ())
 createContext modelVar changeKey = do
-    let getKeyPair' :: IO (Maybe KeyPair)
-        getKeyPair' = do
-            appModel' <- readMVar modelVar
-            return (keyPair appModel')
-
-        setKeyPair' :: KeyPair -> IO ()
-        setKeyPair' kp = modifyMVar_ modelVar $ \m -> return m { keyPair = Just kp }
+
 
     appModel <- readMVar modelVar
-    keyMgmtObj <- createKeyMgmtCtx (keyMgmtModel appModel) changeKey getKeyPair' setKeyPair'
+    keyMgmtObj <- createKeyMgmtCtx (keyMgmtModel appModel) changeKey
 
-    rootClass <- newClass [
-        defPropertyConst' "ctxKeyMgmt" (\_ -> return keyMgmtObj),
+    rootClass <- QML.newClass [
+        QML.defPropertyConst' "ctxKeyMgmt" (\_ -> return keyMgmtObj),
 
-        defPropertySigRW' "currentScreen" changeKey
+        QML.defPropertySigRW' "currentScreen" changeKey
             (\_ -> fmap (pack . show . currentScreen) (readMVar modelVar))
             (\obj newScreen -> do
                 case readMaybe (unpack newScreen) :: Maybe AppScreen of
                     Just s -> do
                         modifyMVar_ modelVar $ \model -> return model { currentScreen = s }
-                        fireSignal changeKey obj
+                        QML.fireSignal changeKey obj
                     Nothing -> return ()),
 
-        defMethod' "login" $ \this input -> do
+        QML.defMethod' "login" $ \this input -> do
             appModel' <- readMVar modelVar
             keyMgmtModel' <- readMVar $ keyMgmtModel appModel'
             case Map.lookup (AccountId input) (accountMap keyMgmtModel') of
                 Just a -> do
                     modifyMVar_ modelVar $ \m -> return m { keyPair = Just $ secKeyToKeyPair $ nsec a, currentScreen = Home }
-                    fireSignal changeKey this
+                    QML.fireSignal changeKey this
                 Nothing ->
                     return ()
         ]
 
-    rootObj <- newObject rootClass ()
+    rootObj <- QML.newObject rootClass ()
     return rootObj
 
 
 main :: IO ()
 main = do
     accounts <- listAccounts
-    keyMgmtM <- newMVar $ KeyMgmtModel accounts "" ""
+    keyMgmtM <- newMVar $ KeyMgmtModel accounts "" "" "" ""
 
     let appModel = AppModel
             { keyPair = Nothing
@@ -74,7 +61,7 @@ main = do
             }
 
     modelVar <- newMVar appModel
-    changeKey <- newSignalKey :: IO (SignalKey (IO ()))
+    changeKey <- QML.newSignalKey :: IO (QML.SignalKey (IO ()))
     ctx <- createContext modelVar changeKey
 
     let path = "qrc:/qml/main.qml"
@@ -88,9 +75,15 @@ main = do
     setEnv "QT_LOGGING_RULES" "qt.qml.connections=false"
     setEnv "QT_ENABLE_HIGHDPI_SCALING" "1"
 
-    runEngineLoop defaultEngineConfig
-        { initialDocument = fileDocument path
-        , contextObject = Just $ anyObjRef ctx
-        , importPaths = [importPath, importPath', importPath'']
-        , iconPath = Just ":/icons/nostr-purple.png"
-        }
+    let config = QML.defaultEngineConfig
+            { QML.initialDocument = QML.fileDocument path
+            , QML.contextObject = Just $ QML.anyObjRef ctx
+            , QML.importPaths = [importPath, importPath', importPath'']
+            , QML.iconPath = Just ":/icons/nostr-purple.png"
+            }
+
+    let signalUpdate = SignalUpdate changeKey ctx
+
+    runEff $ evalState signalUpdate $ runQMLEffectful $ do
+
+        runEngineLoop config