forked from marko/svitak
Eager parsing on seperate thread
This commit is contained in:
parent
e1682a861a
commit
a41828dbbd
3 changed files with 100 additions and 90 deletions
|
|
@ -22,7 +22,7 @@ import Control.Monad.Except (runExceptT)
|
|||
import System.FilePath (takeDirectory, (</>), normalise)
|
||||
import Data.List (find)
|
||||
import Text.HTML.TagSoup (parseTags, innerText, Tag(..))
|
||||
|
||||
import Control.Concurrent.Async (Async)
|
||||
import Codec.Epub.Parse (getSpine, getMetadata, getManifest)
|
||||
import qualified Codec.Epub.Data.Metadata as DMeta
|
||||
import qualified Codec.Epub.Data.Manifest as DMan
|
||||
|
|
@ -38,6 +38,9 @@ data AppState = AppState
|
|||
, cSpine :: [FilePath]
|
||||
, bTitle :: T.Text
|
||||
, cTags :: Maybe [Tag T.Text]
|
||||
, activeTask :: Maybe (Async ())
|
||||
, cAllChapters :: [[Tag T.Text]]
|
||||
, taskVersion :: Integer
|
||||
}
|
||||
|
||||
data EpubEnv = EpubEnv
|
||||
|
|
|
|||
159
app/UI.hs
159
app/UI.hs
|
|
@ -5,6 +5,8 @@ module UI (runApp) where
|
|||
import qualified GI.Gtk as Gtk
|
||||
import qualified GI.Gdk as Gdk
|
||||
import qualified GI.Gio as Gio
|
||||
import qualified GI.GLib as GLib
|
||||
import qualified GI.GLib.Constants as GLibConst
|
||||
import qualified GI.WebKit as WebKit
|
||||
import qualified GI.Gtk.Enums as GtkEnums
|
||||
import qualified Data.Text as T
|
||||
|
|
@ -12,98 +14,101 @@ import qualified Data.Text as T
|
|||
import Data.List (find)
|
||||
import Data.GI.Base (AttrOp(..))
|
||||
import Control.Monad.Reader (runReaderT)
|
||||
import Control.Concurrent.STM (newTVarIO, readTVar, atomically, modifyTVar, readTVarIO)
|
||||
import Control.Concurrent.STM (newTVarIO, readTVar, atomically, modifyTVar)
|
||||
import Text.HTML.TagSoup (renderTags)
|
||||
|
||||
import Control.Concurrent.Async (async)
|
||||
import Codec.Epub.Data.Metadata (metaTitles, titleType, titleText)
|
||||
import EpubParser (EpubEnv(..), AppState(..), resolveSpine, getChapter, getChapterTitle)
|
||||
import Persistence (saveLastRead, loadLastRead)
|
||||
|
||||
runApp :: EpubEnv -> IO ()
|
||||
runApp env' = do
|
||||
app <- Gtk.applicationNew (Just "com.svitak.reader.v2") []
|
||||
app <- Gtk.applicationNew (Just "com.svitak.reader.v2") []
|
||||
|
||||
_ <- Gtk.on app #activate $ do
|
||||
ispine <- runReaderT resolveSpine env'
|
||||
_ <- Gtk.on app #activate $ do
|
||||
|
||||
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 loadingState = AppState
|
||||
{ cEnv = env'
|
||||
, cIdx = 0
|
||||
, cTags = Nothing
|
||||
, cSpine = []
|
||||
, bTitle = "Svitak - Loading..."
|
||||
, zoomlvl = 1.0
|
||||
, activeTask = Nothing
|
||||
, cAllChapters = []
|
||||
, taskVersion = 0
|
||||
}
|
||||
|
||||
let initState = AppState
|
||||
{ cEnv = env'
|
||||
, cIdx = 0
|
||||
, cTags = Nothing
|
||||
, cSpine = ispine
|
||||
, bTitle = T.pack rawTitle
|
||||
, zoomlvl = 1.0
|
||||
}
|
||||
stateTVar <- newTVarIO loadingState
|
||||
|
||||
stateTVar <- newTVarIO initState
|
||||
window <- Gtk.applicationWindowNew app
|
||||
webView <- WebKit.webViewNew
|
||||
Gtk.set window [ #defaultWidth := 800, #defaultHeight := 600, #child := webView ]
|
||||
|
||||
window <- Gtk.applicationWindowNew app
|
||||
webView <- WebKit.webViewNew
|
||||
|
||||
Gtk.set window [ #defaultWidth := 800, #defaultHeight := 600, #child := webView ]
|
||||
-- load all chapters on another thread
|
||||
let loadChapter index = do
|
||||
st <- atomically $ readTVar stateTVar
|
||||
let chapters = cAllChapters st
|
||||
if null chapters || index < 0 || index >= length chapters
|
||||
then pure ()
|
||||
else do
|
||||
let tags = chapters !! index
|
||||
let html = renderTags tags
|
||||
let fullTitle = bTitle st <> " - " <> getChapterTitle tags
|
||||
Gtk.set window [ #title := fullTitle ]
|
||||
WebKit.webViewLoadHtml webView html Nothing
|
||||
atomically $ modifyTVar stateTVar $ \s -> s { cIdx = index }
|
||||
_ <- async $ saveLastRead (bookPath env') index
|
||||
pure ()
|
||||
|
||||
let loadChapter index = do
|
||||
-- keyboard handling
|
||||
keyCtrl <- Gtk.eventControllerKeyNew
|
||||
Gtk.eventControllerSetPropagationPhase keyCtrl GtkEnums.PropagationPhaseCapture
|
||||
|
||||
_ <- Gtk.on keyCtrl #keyPressed $ \keyval _ _ -> do
|
||||
stNow <- atomically $ readTVar stateTVar
|
||||
case keyval of
|
||||
Gdk.KEY_Right -> loadChapter (cIdx stNow + 1) >> pure True
|
||||
Gdk.KEY_Left -> loadChapter (cIdx stNow - 1) >> pure True
|
||||
Gdk.KEY_equal -> do
|
||||
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 (zoomlvl stNow - 0.1)
|
||||
atomically $ modifyTVar stateTVar $ \s -> s { zoomlvl = newZ }
|
||||
WebKit.webViewSetZoomLevel webView newZ
|
||||
pure True
|
||||
_ -> pure False
|
||||
|
||||
st <- readTVarIO stateTVar
|
||||
let env = cEnv st
|
||||
let spine = cSpine st
|
||||
|
||||
if null spine
|
||||
then Gtk.set window [ #title := "Svitak - Empty Book" ]
|
||||
else do
|
||||
let safeIdx = max 0 (min index (length spine - 1))
|
||||
let filename = spine !! safeIdx
|
||||
Gtk.widgetAddController window keyCtrl
|
||||
#present window
|
||||
|
||||
newTags <- runReaderT (getChapter filename) env
|
||||
-- start eager parse
|
||||
_ <- async $ do
|
||||
ispine <- runReaderT resolveSpine env'
|
||||
allChapters <- runReaderT (mapM getChapter ispine) env'
|
||||
|
||||
let titles = metaTitles (eMetadata env')
|
||||
let rawT = case find (\t -> titleType t == Just "main") titles of
|
||||
Just t -> titleText t
|
||||
Nothing -> if null titles then "Unknown" else titleText (head titles)
|
||||
|
||||
-- UPDATE: Atomic transaction to update the state
|
||||
atomically $ modifyTVar stateTVar $ \s ->
|
||||
s { cIdx = safeIdx, cTags = Just newTags }
|
||||
atomically $ modifyTVar stateTVar $ \s -> s
|
||||
{ cSpine = ispine
|
||||
, cAllChapters = allChapters
|
||||
, bTitle = T.pack rawT
|
||||
}
|
||||
|
||||
saveLastRead (bookPath env) safeIdx
|
||||
_ <- GLib.idleAdd GLibConst.PRIORITY_DEFAULT $ do
|
||||
maybeSaved <- loadLastRead
|
||||
case maybeSaved of
|
||||
Just (path, idx) | path == bookPath env' -> loadChapter idx
|
||||
_ -> loadChapter 0
|
||||
pure False
|
||||
pure ()
|
||||
pure ()
|
||||
|
||||
let fullTitle = bTitle st <> " - " <> getChapterTitle newTags
|
||||
Gtk.set window [ #title := fullTitle ]
|
||||
WebKit.webViewLoadHtml webView (renderTags newTags) Nothing
|
||||
|
||||
-- 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 (cEnv st1) -> loadChapter idx
|
||||
_ -> loadChapter 0
|
||||
|
||||
-- Keyboard handling (Now cleaner)
|
||||
keyCtrl <- Gtk.eventControllerKeyNew
|
||||
Gtk.eventControllerSetPropagationPhase keyCtrl GtkEnums.PropagationPhaseCapture
|
||||
|
||||
_ <- Gtk.on keyCtrl #keyPressed $ \keyval _ _ -> do
|
||||
stNow <- atomically $ readTVar stateTVar
|
||||
case keyval of
|
||||
Gdk.KEY_Right -> loadChapter (cIdx stNow + 1) >> pure True
|
||||
Gdk.KEY_Left -> loadChapter (cIdx stNow - 1) >> pure True
|
||||
Gdk.KEY_equal -> do
|
||||
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 (zoomlvl stNow - 0.1)
|
||||
atomically $ modifyTVar stateTVar $ \s -> s { zoomlvl = newZ }
|
||||
WebKit.webViewSetZoomLevel webView newZ
|
||||
pure True
|
||||
_ -> pure False
|
||||
|
||||
Gtk.widgetAddController window keyCtrl
|
||||
#present window
|
||||
|
||||
_ <- Gio.applicationRun app Nothing
|
||||
pure ()
|
||||
_ <- Gio.applicationRun app Nothing
|
||||
pure ()
|
||||
|
|
|
|||
|
|
@ -72,7 +72,9 @@ executable svitak
|
|||
tagsoup,
|
||||
text >= 2.1.2,
|
||||
zip-archive >= 0.4.3.2,
|
||||
stm >=2.5.3.1
|
||||
stm >=2.5.3.1,
|
||||
gi-glib >= 2.0.30,
|
||||
async >= 2.2.6
|
||||
|
||||
hs-source-dirs: app
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
Loading…
Reference in a new issue