Marko Andjelic
81c2caaf67
add stGen which gets bumped for every worker thread spawned by loadBook every thread captures stGen when it spawns and before actually loading the book in the main thread, and in the worker thread it checks if myGen == stGen this throws away stale requests, meaning if you try and load another book while one is still loading, it will ignore the one still loading and start loading the latest request
355 lines
14 KiB
Haskell
355 lines
14 KiB
Haskell
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
-- | The GTK4 / WebKit front end. The book's structure loads in the background;
|
|
-- chapters are rendered lazily (and cached) the first time they're visited,
|
|
-- with neighbours preloaded so arrow-key paging feels instant.
|
|
module UI (runApp) where
|
|
|
|
import Control.Concurrent.Async (async)
|
|
import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar, readTVar)
|
|
import Control.Monad (unless, void, when)
|
|
import Data.GI.Base (AttrOp (..), on)
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.Text as T
|
|
import Data.Word (Word32)
|
|
import Control.Exception (SomeException, try)
|
|
import EpubParser (EpubEnv, openEpub) -- brings the `BookInfo EpubEnv` instance into scope
|
|
import qualified GI.GLib as GLib
|
|
import qualified GI.GLib.Constants as GLibConst
|
|
import qualified GI.Gdk as Gdk
|
|
import qualified GI.Gio as Gio
|
|
import qualified GI.Gtk as Gtk
|
|
import qualified GI.Gtk.Enums as GtkEnums
|
|
import qualified GI.WebKit as WebKit
|
|
import Persistence (loadLastRead, saveLastRead)
|
|
import State (initialState)
|
|
import Types
|
|
( AppState (..),
|
|
BookInfo (..),
|
|
BookStructure (..),
|
|
Chapter (..),
|
|
ChapterIndex (..),
|
|
ChapterRef (..),
|
|
TocEntry (..),
|
|
UserAction (..),
|
|
)
|
|
|
|
-- | Widget handles the rest of the module needs.
|
|
data AppWidgets = AppWidgets
|
|
{ appWindow :: Gtk.ApplicationWindow,
|
|
appWebView :: WebKit.WebView,
|
|
appSidebar :: Gtk.ListBox,
|
|
appFileBttn :: Gtk.Button
|
|
}
|
|
|
|
-- | Everything an action handler needs: shared state, widgets, and a way to
|
|
-- render a chapter on demand (closes over the book).
|
|
data Ctx = Ctx
|
|
{ ctxState :: TVar AppState,
|
|
ctxWidgets :: AppWidgets,
|
|
ctxRender :: TVar (ChapterRef -> IO (Either String Chapter))
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Widget tree
|
|
--------------------------------------------------------------------------------
|
|
|
|
buildLayout :: Gtk.Application -> IO AppWidgets
|
|
buildLayout app = do
|
|
window <- Gtk.applicationWindowNew app
|
|
webView <- WebKit.webViewNew
|
|
sidebar <- Gtk.listBoxNew
|
|
header <- Gtk.headerBarNew
|
|
fileBttn <- Gtk.buttonNew
|
|
|
|
|
|
Gtk.listBoxSetSelectionMode sidebar GtkEnums.SelectionModeSingle
|
|
Gtk.widgetAddCssClass sidebar "toc"
|
|
|
|
scrolled <- Gtk.scrolledWindowNew
|
|
Gtk.scrolledWindowSetChild scrolled (Just sidebar)
|
|
Gtk.widgetSetSizeRequest scrolled 260 (-1)
|
|
|
|
paned <- Gtk.panedNew GtkEnums.OrientationHorizontal
|
|
Gtk.panedSetStartChild paned (Just scrolled)
|
|
Gtk.panedSetEndChild paned (Just webView)
|
|
Gtk.panedSetResizeStartChild paned False
|
|
|
|
Gtk.headerBarPackStart header fileBttn
|
|
|
|
Gtk.set window [#defaultWidth := 1000, #defaultHeight := 700, #child := paned]
|
|
Gtk.windowSetTitlebar window $ Just header
|
|
applyStyles window
|
|
pure (AppWidgets window webView sidebar fileBttn)
|
|
|
|
-- | Install the app-wide stylesheet (sidebar rows, selection, headings).
|
|
applyStyles :: Gtk.ApplicationWindow -> IO ()
|
|
applyStyles window = do
|
|
provider <- Gtk.cssProviderNew
|
|
Gtk.cssProviderLoadFromString provider css
|
|
disp <- Gtk.widgetGetDisplay window
|
|
Gtk.styleContextAddProviderForDisplay disp provider appPriority
|
|
where
|
|
appPriority = 600 :: Word32
|
|
css =
|
|
T.concat
|
|
[ ".toc { background: transparent; padding: 4px; }",
|
|
".toc > row { padding: 6px 10px; border-radius: 6px; margin: 1px 4px; }",
|
|
".toc > row:selected { background-color: rgba(90,130,220,0.35); }",
|
|
".toc > row:hover { background-color: rgba(128,128,128,0.14); }",
|
|
"label.toc-top { font-weight: bold; }"
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Sidebar (table of contents)
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | A displayable sidebar row: nesting depth, label, the chapter it jumps to,
|
|
-- and an optional in-page anchor.
|
|
data Row = Row Int T.Text ChapterIndex T.Text
|
|
|
|
-- | Flatten the TOC tree into rows, remembering depth (for indentation) and
|
|
-- the chapter each entry targets. With no TOC, list chapters flatly.
|
|
displayRows :: [ChapterRef] -> [TocEntry] -> [Row]
|
|
displayRows refs toc
|
|
| null toc = [Row 0 (refTitle r) (refIndex r) "" | r <- refs]
|
|
| otherwise = go 0 toc
|
|
where
|
|
pathToIndex = M.fromList [(refPath r, refIndex r) | r <- refs]
|
|
indexOf target = M.findWithDefault (ChapterIndex 0) target pathToIndex
|
|
go depth =
|
|
concatMap
|
|
(\t -> Row depth (tocLabel t) (indexOf (tocTarget t)) (tocFragment t) : go (depth + 1) (tocChildren t))
|
|
|
|
populateSidebar :: Gtk.ListBox -> [Row] -> IO ()
|
|
populateSidebar sidebar =
|
|
mapM_ $ \(Row depth label _ _) -> do
|
|
lbl <- Gtk.labelNew (Just label)
|
|
Gtk.widgetSetHalign lbl GtkEnums.AlignStart
|
|
Gtk.labelSetXalign lbl 0
|
|
Gtk.labelSetWrap lbl True
|
|
Gtk.widgetSetMarginStart lbl (fromIntegral (depth * 14))
|
|
when (depth == 0) (Gtk.widgetAddCssClass lbl "toc-top")
|
|
Gtk.listBoxInsert sidebar lbl (-1)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Events
|
|
--------------------------------------------------------------------------------
|
|
|
|
wireEvents :: Ctx -> IO ()
|
|
wireEvents ctx = do
|
|
let dispatch = handleAction ctx
|
|
keyCtrl <- Gtk.eventControllerKeyNew
|
|
Gtk.eventControllerSetPropagationPhase keyCtrl GtkEnums.PropagationPhaseCapture
|
|
_ <- on keyCtrl #keyPressed $ \keyval _ _ ->
|
|
case keyval of
|
|
Gdk.KEY_Right -> dispatch NextChapter >> pure True
|
|
Gdk.KEY_Left -> dispatch PrevChapter >> pure True
|
|
Gdk.KEY_equal -> dispatch ZoomIn >> pure True
|
|
Gdk.KEY_minus -> dispatch ZoomOut >> pure True
|
|
_ -> pure False
|
|
|
|
Gtk.widgetAddController (appWindow (ctxWidgets ctx)) keyCtrl
|
|
|
|
_ <- on (appFileBttn (ctxWidgets ctx)) #clicked $ epPicker (Just (appWindow (ctxWidgets ctx))) ctx
|
|
_ <- on (appSidebar (ctxWidgets ctx)) #rowActivated $ \row -> do
|
|
i <- Gtk.listBoxRowGetIndex row
|
|
st <- readTVarIO (ctxState ctx)
|
|
case drop (fromIntegral i) (displayRows (stRefs st) (stToc st)) of
|
|
(Row _ _ idx frag : _) -> dispatch (GoToChapter idx frag)
|
|
[] -> pure ()
|
|
pure ()
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Loading
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Load the book's structure off the GTK thread, then populate the sidebar
|
|
-- and open the first (or last-read) chapter back on the main loop.
|
|
loadBook :: (BookInfo a) => a -> Ctx -> IO ()
|
|
loadBook env ctx = do
|
|
myGen <- atomically $ do
|
|
s <- readTVar (ctxState ctx)
|
|
let g = stGen s + 1
|
|
writeTVar (ctxState ctx) (s {stGen = g})
|
|
pure g
|
|
void $
|
|
async $ do
|
|
result <- loadStructure env
|
|
case result of
|
|
Left err -> putStrLn ("Failed to load book: " ++ err)
|
|
Right (BookStructure refs toc) -> do
|
|
committed <- atomically $ do
|
|
s <- readTVar (ctxState ctx)
|
|
let mine = stGen s == myGen
|
|
when mine $ do
|
|
writeTVar (ctxState ctx)
|
|
(s { stRefs = refs, stToc = toc,
|
|
stCache = M.empty, stIndex = ChapterIndex 0,
|
|
stTitle = bookTitle env, stBookPath = bookFilePath env})
|
|
writeTVar (ctxRender ctx) (renderChapter env)
|
|
pure mine
|
|
|
|
when committed $ postGtk $ do
|
|
s <- readTVarIO (ctxState ctx)
|
|
when (stGen s == myGen) $ do
|
|
Gtk.listBoxRemoveAll (appSidebar (ctxWidgets ctx))
|
|
populateSidebar (appSidebar (ctxWidgets ctx)) (displayRows refs toc)
|
|
saved <- loadLastRead
|
|
let start = case saved of
|
|
Just (path, idx) | path == bookFilePath env -> idx
|
|
_ -> ChapterIndex 0
|
|
handleAction ctx (GoToChapter start "")
|
|
|
|
epPicker :: Maybe Gtk.ApplicationWindow -> Ctx -> IO ()
|
|
epPicker window ctx = do
|
|
dg <- Gtk.fileDialogNew
|
|
Gtk.fileDialogOpen dg window (Nothing :: Maybe Gio.Cancellable) $ Just $ \_ result -> do
|
|
outcome <- try (Gtk.fileDialogOpenFinish dg result) :: IO (Either SomeException Gio.File)
|
|
case outcome of
|
|
Left _err -> putStrLn "picker cancelled or failed"
|
|
Right file -> do
|
|
mp <- Gio.fileGetPath file
|
|
case mp of
|
|
Nothing -> putStrLn "selected file has no local path"
|
|
Just path -> do
|
|
env <- openEpub path
|
|
case env of
|
|
Left err -> putStrLn ("open failed: " ++ err)
|
|
Right e -> loadBook e ctx
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Navigation + rendering
|
|
--------------------------------------------------------------------------------
|
|
|
|
handleAction :: Ctx -> UserAction -> IO ()
|
|
handleAction ctx action = do
|
|
st <- readTVarIO (ctxState ctx)
|
|
case action of
|
|
ZoomIn -> setZoom ctx (stZoom st + 0.1)
|
|
ZoomOut -> setZoom ctx (max 0.1 (stZoom st - 0.1))
|
|
NextChapter -> goto ctx (stIndex st + 1) ""
|
|
PrevChapter -> goto ctx (stIndex st - 1) ""
|
|
GoToChapter i frag -> goto ctx i frag
|
|
|
|
-- | Move to a chapter (clamped), render it if needed, scroll to @frag@, and
|
|
-- remember the position. Neighbours are preloaded afterwards.
|
|
goto :: Ctx -> ChapterIndex -> T.Text -> IO ()
|
|
goto ctx target frag = do
|
|
st <- readTVarIO (ctxState ctx)
|
|
let refs = stRefs st
|
|
total = length refs
|
|
when (total > 0) $ do
|
|
let ChapterIndex t = target
|
|
i = max 0 (min (total - 1) t)
|
|
idx = ChapterIndex i
|
|
ref = refs !! i
|
|
atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stIndex = idx}
|
|
void $ async (saveLastRead (stBookPath st) idx)
|
|
case M.lookup idx (stCache st) of
|
|
Just chapter -> display ctx chapter frag
|
|
Nothing -> do
|
|
showLoading ctx ref
|
|
void $ async $ do
|
|
renderFn <- readTVarIO (ctxRender ctx)
|
|
rendered <- renderFn ref
|
|
case rendered of
|
|
Left err -> putStrLn ("render failed: " ++ err)
|
|
Right chapter -> do
|
|
atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stCache = M.insert idx chapter (stCache s)}
|
|
postGtk $ do
|
|
cur <- stIndex <$> readTVarIO (ctxState ctx)
|
|
when (cur == idx) (display ctx chapter frag)
|
|
preload ctx
|
|
|
|
-- | Render the chapters on either side of the current one into the cache.
|
|
preload :: Ctx -> IO ()
|
|
preload ctx = do
|
|
st <- readTVarIO (ctxState ctx)
|
|
let refs = stRefs st
|
|
total = length refs
|
|
ChapterIndex i = stIndex st
|
|
mapM_ (cacheRef ctx refs) (filter (\n -> n >= 0 && n < total) [i - 1, i + 1])
|
|
|
|
cacheRef :: Ctx -> [ChapterRef] -> Int -> IO ()
|
|
cacheRef ctx refs n = do
|
|
let idx = ChapterIndex n
|
|
st <- readTVarIO (ctxState ctx)
|
|
unless (M.member idx (stCache st)) $
|
|
void $
|
|
async $ do
|
|
renderFn <- readTVarIO (ctxRender ctx)
|
|
rendered <- renderFn (refs !! n)
|
|
case rendered of
|
|
Right chapter -> atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stCache = M.insert idx chapter (stCache s)}
|
|
Left _ -> pure ()
|
|
|
|
display :: Ctx -> Chapter -> T.Text -> IO ()
|
|
display ctx chapter frag = do
|
|
setWindowTitle ctx (chapterIndex chapter) (chapterTitle chapter)
|
|
WebKit.webViewLoadHtml (appWebView (ctxWidgets ctx)) (wrapHtml (chapterHtml chapter) frag) Nothing
|
|
|
|
showLoading :: Ctx -> ChapterRef -> IO ()
|
|
showLoading ctx ref = do
|
|
setWindowTitle ctx (refIndex ref) (refTitle ref)
|
|
WebKit.webViewLoadHtml (appWebView (ctxWidgets ctx)) (wrapHtml "<p style=\"opacity:0.5\">Loading…</p>" "") Nothing
|
|
|
|
setWindowTitle :: Ctx -> ChapterIndex -> T.Text -> IO ()
|
|
setWindowTitle ctx (ChapterIndex i) chapter = do
|
|
st <- readTVarIO (ctxState ctx)
|
|
let total = length (stRefs st)
|
|
title = T.pack (show (i + 1)) <> "/" <> T.pack (show total) <> " " <> stTitle st <> " — " <> chapter
|
|
Gtk.set (appWindow (ctxWidgets ctx)) [#title := title]
|
|
|
|
setZoom :: Ctx -> Double -> IO ()
|
|
setZoom ctx level = do
|
|
atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stZoom = level}
|
|
WebKit.webViewSetZoomLevel (appWebView (ctxWidgets ctx)) level
|
|
|
|
-- | Wrap a chapter's @\<body\>@ fragment in a full, styled HTML document
|
|
-- (WebKit renders bare fragments unreliably). If @frag@ names an anchor, a
|
|
-- small script scrolls it into view after load.
|
|
wrapHtml :: T.Text -> T.Text -> T.Text
|
|
wrapHtml body frag =
|
|
T.concat
|
|
[ "<!DOCTYPE html><html><head><meta charset=\"utf-8\">",
|
|
"<style>",
|
|
"body{max-width:42rem;margin:2rem auto;padding:0 1rem;",
|
|
"font-family:Georgia,serif;line-height:1.6;}",
|
|
"img{max-width:100%;height:auto;}",
|
|
"</style></head><body>",
|
|
body,
|
|
scrollScript frag,
|
|
"</body></html>"
|
|
]
|
|
where
|
|
scrollScript "" = ""
|
|
scrollScript f =
|
|
let safe = T.filter (\c -> c /= '"' && c /= '\\') f
|
|
in "<script>var e=document.getElementById(\"" <> safe <> "\");if(e)e.scrollIntoView();</script>"
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Entry point
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Schedule an action to run on the GTK main loop.
|
|
postGtk :: IO () -> IO ()
|
|
postGtk act = void $ GLib.idleAdd GLibConst.PRIORITY_DEFAULT (act >> pure False)
|
|
|
|
activate :: EpubEnv -> Gtk.Application -> IO ()
|
|
activate env app = do
|
|
stateTVar <- newTVarIO (initialState (bookTitle env) (bookFilePath env))
|
|
renderVar <- newTVarIO (renderChapter env)
|
|
widgets <- buildLayout app
|
|
let ctx = Ctx stateTVar widgets renderVar
|
|
wireEvents ctx
|
|
loadBook env ctx
|
|
#present (appWindow widgets)
|
|
|
|
runApp :: EpubEnv -> IO ()
|
|
runApp env = do
|
|
app <- Gtk.new Gtk.Application [#applicationId := "com.svitak.reader", #flags := [Gio.ApplicationFlagsDefaultFlags]]
|
|
_ <- on app #activate (activate env app)
|
|
_ <- Gio.applicationRun app Nothing
|
|
pure ()
|