Implement STM Concurrency

add stm to project file

app/UI.hs

@@ -12,7 +12,7 @@ import qualified Data.Text as T
 import Data.List (find)
 import Data.GI.Base (AttrOp(..))
 import Control.Monad.Reader (runReaderT)
-import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
+import Control.Concurrent.STM (newTVarIO, readTVar, atomically, modifyTVar, readTVarIO)
 import Text.HTML.TagSoup (renderTags)
 
 import Codec.Epub.Data.Metadata (metaTitles, titleType, titleText)
@@ -25,33 +25,32 @@ runApp env' = do
 
   _ <- Gtk.on app #activate $ do
     ispine <- runReaderT resolveSpine env'
-    
-    let titles = metaTitles (eMetadata env')
 
-    -- checks for the title marked as main otherwise takes the first one
+    let titles = metaTitles (eMetadata env')
     let rawTitle = case find (\t -> titleType t == Just "main") titles of
                      Just t  -> titleText t
                      Nothing -> if null titles then "Unknown Book" else titleText (head titles)
 
     let initState = AppState 
-          { cEnv = env'
-          , cIdx = 0
-          , cTags = Nothing
-          , cSpine = ispine
-          , bTitle = T.pack rawTitle
+          { cEnv    = env'
+          , cIdx    = 0
+          , cTags   = Nothing
+          , cSpine  = ispine
+          , bTitle  = T.pack rawTitle
           , zoomlvl = 1.0 
           }
 
-    stateMVar <- newMVar initState
+    stateTVar <- newTVarIO initState
 
     window <- Gtk.applicationWindowNew app
     webView <- WebKit.webViewNew
-
-    Gtk.set window [#defaultWidth  := 800 , #defaultHeight := 600 , #child := webView]
+    
+    Gtk.set window [ #defaultWidth := 800, #defaultHeight := 600, #child := webView ]
 
     let loadChapter index = do
-          st <- readMVar stateMVar
-          let env = cEnv st
+
+          st <- readTVarIO stateTVar
+          let env   = cEnv st
           let spine = cSpine st
           
           if null spine 
@@ -62,48 +61,43 @@ runApp env' = do
 
               newTags <- runReaderT (getChapter filename) env
 
-              let newState = st { cIdx = safeIdx, cTags = Just newTags }
-              _ <- swapMVar stateMVar newState
+              -- UPDATE: Atomic transaction to update the state
+              atomically $ modifyTVar stateTVar $ \s -> 
+                s { cIdx = safeIdx, cTags = Just newTags }
 
               saveLastRead (bookPath env) safeIdx
 
-              let chapterTitle = getChapterTitle newTags
-              Gtk.set window [ #title := (bTitle st <> " - " <> chapterTitle) ]
-
+              let fullTitle = bTitle st <> " - " <> getChapterTitle newTags
+              Gtk.set window [ #title := fullTitle ]
               WebKit.webViewLoadHtml webView (renderTags newTags) Nothing
 
-    -- loading progress
-    st1 <- readMVar stateMVar
-    let env = cEnv st1
-    let spine = cSpine st1
-    
-    if null spine 
-      then Gtk.set window [#title := "Svitak - No Chapters Found"]
+    -- Initial load logic using STM
+    st1 <- atomically $ readTVar stateTVar
+    if null (cSpine st1)
+      then Gtk.set window [ #title := "Svitak - No Chapters Found" ]
       else do
         maybeSaved <- loadLastRead
         case maybeSaved of
-          Just (path, idx) | path == bookPath env -> loadChapter idx
+          Just (path, idx) | path == bookPath (cEnv st1) -> loadChapter idx
           _ -> loadChapter 0
 
-    -- keyboard handling
+    -- Keyboard handling (Now cleaner)
     keyCtrl <- Gtk.eventControllerKeyNew
     Gtk.eventControllerSetPropagationPhase keyCtrl GtkEnums.PropagationPhaseCapture
 
     _ <- Gtk.on keyCtrl #keyPressed $ \keyval _ _ -> do
-      stNow <- readMVar stateMVar
-      let curr = cIdx stNow
-      let z = zoomlvl stNow
+      stNow <- atomically $ readTVar stateTVar
       case keyval of
-        Gdk.KEY_Right -> loadChapter (curr + 1) >> pure True
-        Gdk.KEY_Left  -> loadChapter (curr - 1) >> pure True
+        Gdk.KEY_Right -> loadChapter (cIdx stNow + 1) >> pure True
+        Gdk.KEY_Left  -> loadChapter (cIdx stNow - 1) >> pure True
         Gdk.KEY_equal -> do
-          let newZ = z + 0.1
-          _ <- swapMVar stateMVar stNow { zoomlvl = newZ }
+          let newZ = zoomlvl stNow + 0.1
+          atomically $ modifyTVar stateTVar $ \s -> s { zoomlvl = newZ }
           WebKit.webViewSetZoomLevel webView newZ
           pure True
         Gdk.KEY_minus -> do
-          let newZ = max 0.1 (z - 0.1)
-          _ <- swapMVar stateMVar stNow { zoomlvl = newZ }
+          let newZ = max 0.1 (zoomlvl stNow - 0.1)
+          atomically $ modifyTVar stateTVar $ \s -> s { zoomlvl = newZ }
           WebKit.webViewSetZoomLevel webView newZ
           pure True
         _             -> pure False

svitak.cabal

@@ -71,7 +71,8 @@ executable svitak
                       scalpel >= 0.6.2.2,
                       tagsoup,
                       text >= 2.1.2,
-                      zip-archive >= 0.4.3.2
+                      zip-archive >= 0.4.3.2,
+                      stm >=2.5.3.1
 
     hs-source-dirs:   app
     default-language: Haskell2010