svitak/app/UI.hs

{-# 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 Data.List (minimumBy)
import Data.Ord (comparing)
import Data.Maybe (listToMaybe)
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 Data.Bits ((.|.))
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,
    appSearch :: Gtk.SearchEntry
  }

-- | 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)),
    ctxPending :: TVar (Maybe T.Text) -- Query to run once the next load finished (text search)
  }

-- | 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
  sEntry <- Gtk.searchEntryNew

  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.headerBarPackEnd header sEntry

  Gtk.set window [#defaultWidth := 1000, #defaultHeight := 700, #child := paned]
  Gtk.windowSetTitlebar window $ Just header
  applyStyles window
  pure (AppWidgets window webView sidebar fileBttn sEntry)

-- | 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

  fc <- WebKit.webViewGetFindController (appWebView (ctxWidgets ctx))
  let entry = (appSearch (ctxWidgets ctx))
  let findOpts = fromIntegral $ fromEnum WebKit.FindOptionsCaseInsensitive .|. fromEnum WebKit.FindOptionsWrapAround

  searchKeys <- Gtk.eventControllerKeyNew
  _ <- on searchKeys #keyPressed $ \keyval _ _ ->
    case keyval of
      Gdk.KEY_Down -> WebKit.findControllerSearchNext fc >> pure True
      Gdk.KEY_Up -> WebKit.findControllerSearchPrevious fc >> pure True
      _ -> pure False
  Gtk.widgetAddController entry searchKeys

  _ <- on entry #searchChanged $ do
    q <- Gtk.editableGetText entry
    if T.null q
      then WebKit.findControllerSearchFinish fc
      else WebKit.findControllerSearch fc q findOpts maxBound
  let runfwd = runSearch ctx nextMatch
  _ <- on entry #activate $ runfwd -- pressing enter while having search text
  _ <- on entry #nextMatch $ runfwd -- pressing Alt + G while having search text
  _ <- on entry #previousMatch $ runSearch ctx prevMatch
  _ <- on (appWebView (ctxWidgets ctx)) #loadChanged $ \ev ->
    when (ev == WebKit.LoadEventFinished) $ do
      mq <- atomically $ readTVar (ctxPending ctx)
      case mq of Just q -> WebKit.findControllerSearch fc q findOpts maxBound; _ -> pure ()
  _ <- on fc #foundText $ \_ -> atomically $ writeTVar (ctxPending ctx) Nothing

  _ <- 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,
                     stSearchIndex = M.empty})
              writeTVar (ctxRender ctx) (renderChapter env)
            pure mine

          when committed $ do
            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 "")

            void $ async $ do -- Initiate plaintext chapter parsing, used in full-book text search
              pairs <- mapM
                (\ref -> do
                    r <- chapterText env ref
                    pure $ case r of
                      Left err  -> Left err
                      Right txt -> Right (refIndex ref, txt))
                refs

              let searchIndex = M.fromList [ (idx, txt) | Right (idx, txt) <- pairs ]

              atomically $ do
                s <- readTVar (ctxState ctx)
                when (stGen s == myGen) $
                  writeTVar (ctxState ctx)
                    (s { stSearchIndex = searchIndex })

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 "<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>"

          ---------------------------------------------------------------------
          --                         Full text search                        --
          ---------------------------------------------------------------------

chaptersMatching :: T.Text -> M.Map ChapterIndex T.Text -> [ChapterIndex]
chaptersMatching q = map fst . filter (matches q . snd) . M.toAscList

matches :: T.Text -> T.Text -> Bool
matches q txt = T.toCaseFold q `T.isInfixOf` T.toCaseFold txt

nextMatch :: ChapterIndex -> [ChapterIndex] -> Maybe ChapterIndex
nextMatch cur hits =
  case filter (> cur) hits of
    (x : _) -> Just x
    [] -> listToMaybe hits

prevMatch :: ChapterIndex -> [ChapterIndex] -> Maybe ChapterIndex
prevMatch cur hits =
  case reverse (filter (< cur) hits) of
    (x : _) -> Just x
    [] -> listToMaybe hits

runSearch :: Ctx -> (ChapterIndex -> [ChapterIndex] -> Maybe ChapterIndex) -> IO ()
runSearch ctx pick = do
  q <- Gtk.editableGetText (appSearch (ctxWidgets ctx))
  unless (T.null q) $ do
    st <- readTVarIO (ctxState ctx)
    let hits = chaptersMatching q (stSearchIndex st)
    case pick (stIndex st) hits of
      Just idx
        | idx /= stIndex st -> do
            _ <- atomically $ writeTVar (ctxPending ctx) (Just q)
            handleAction ctx (GoToChapter idx "")
      _ -> pure ()

--------------------------------------------------------------------------------
-- 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
  pendingVar <- newTVarIO Nothing
  let ctx = Ctx stateTVar widgets renderVar pendingVar
  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 ()