{-# 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)) } -- | The cache will start evicting after exceeding this number using LRU. cacheCap :: Int cacheCap = 7 -------------------------------------------------------------------------------- -- 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 -> insertLRU idx chapter s postGtk $ do cur <- stIndex <$> readTVarIO (ctxState ctx) when (cur == idx) (display ctx chapter frag) preload ctx -- | Bump the tick of an index to track frequency for cache eviction. touch :: ChapterIndex -> AppState -> AppState touch idx s = let t = stTick s + 1 in s { stTick = t, stUse = M.insert idx t (stUse s) } -- | Insert a rendered chapter as MRU or evict the LRU entry. insertLRU :: ChapterIndex -> Chapter -> AppState -> AppState insertLRU idx chapter s0 = let s = touch idx (s0 {stCache = M.insert idx chapter (stCache s0) }) in if M.size (stCache s) <= cacheCap then s else evictLRU s evictLRU :: AppState -> AppState evictLRU s = case M.toList (stUse s) of [] -> s xs -> let victim = fst (minimumBy (comparing snd) xs) in s {stCache = M.delete victim (stCache s), stUse = M.delete victim (stUse s)} -- | 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 "
Loading…
" "") 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 @\@ 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 [ "", "", body, scrollScript frag, "" ] where scrollScript "" = "" scrollScript f = let safe = T.filter (\c -> c /= '"' && c /= '\\') f in "" -------------------------------------------------------------------------------- -- 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 ()