svitak/app/UI.hs

{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | 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 Data.Bifunctor (first)
import Control.Concurrent.Async (async)
import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar, readTVar, modifyTVar')
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 Control.Monad.Except
import Control.Monad.IO.Class (liftIO)
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 qualified GI.JavaScriptCore as JSC
import Persistence (loadLastRead, saveLastRead)
import State (initialState)
import Types
  ( AppState (..),
    BookInfo (..),
    BookStructure (..),
    Chapter (..),
    ChapterIndex (..),
    ChapterRef (..),
    TocEntry (..),
    UserAction (..),
    ReadMode(..),
    Html(..),
    PlainText(..),
  )

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

-- | Delegates focus to an internal @GtkText@, so the window's focus widget
-- is a descendant of the entry.
searchFocused :: Ctx -> IO Bool
searchFocused ctx = do
  mfocus <- Gtk.windowGetFocus (appWindow (ctxWidgets ctx))
  case mfocus of
    Nothing -> pure False
    Just f -> Gtk.widgetIsAncestor f (appSearch (ctxWidgets ctx))

wireEvents :: Ctx -> IO ()
wireEvents ctx = do
  let dispatch = handleAction ctx
  keyCtrl <- Gtk.eventControllerKeyNew
  Gtk.eventControllerSetPropagationPhase keyCtrl GtkEnums.PropagationPhaseCapture
  _ <- on keyCtrl #keyPressed $ \keyval _ _ -> do
    -- The controller is in capture phase, so it sees keys before the focused
    -- search box. While the user is typing a query, let every key through
    -- untouched (otherwise letters like `p`/`f` fire commands and the arrows
    -- page the view — the latter crashes in scrolling mode via `turnPage`).
    searching <- searchFocused ctx
    if searching
      then pure False
      else case keyval of
        Gdk.KEY_Right -> dispatch NextPage >> pure True
        Gdk.KEY_Left -> dispatch PrevPage >> pure True
        Gdk.KEY_Page_Down -> dispatch NextChapter >> pure True
        Gdk.KEY_Page_Up -> dispatch PrevChapter >> pure True
        Gdk.KEY_equal -> dispatch ZoomIn >> pure True
        Gdk.KEY_minus -> dispatch ZoomOut >> pure True
        Gdk.KEY_p -> dispatch ToggleMode >> pure True
        Gdk.KEY_f -> dispatch SearchFocus >> 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
      Gdk.KEY_Escape -> Gtk.setEditableText entry "" >> WebKit.findControllerSearchFinish fc >> Gtk.widgetGrabFocus (appWebView (ctxWidgets ctx)) >> snapPagination ctx >> pure True
      _ -> pure False
  Gtk.widgetAddController entry searchKeys

  _ <- on entry #searchChanged $ do
    q <- Gtk.editableGetText entry
    if T.null q
      then WebKit.findControllerSearchFinish fc >> snapPagination ctx
      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 <- runExceptT $ do
      file <- pickerGetFile dg result
      path <- getFilePath file

      env <- extractEnv path

      liftIO $ loadBook env ctx

    either putStrLn pure outcome

pickerGetFile :: Gtk.FileDialog -> Gio.AsyncResult -> ExceptT String IO Gio.File
pickerGetFile dg result =
  ExceptT $ first (const "picker cancelled or failed")
    <$> (try (Gtk.fileDialogOpenFinish dg result) :: IO (Either SomeException Gio.File))

getFilePath :: Gio.File -> ExceptT String IO FilePath
getFilePath file = do
  mp <- liftIO $ Gio.fileGetPath file
  maybe (throwError "selected file has no local path") pure mp


extractEnv :: FilePath -> ExceptT String IO EpubEnv
extractEnv path =
  ExceptT $ first ("open failed: " ++) <$> openEpub path

--------------------------------------------------------------------------------
-- Navigation + rendering
--------------------------------------------------------------------------------

handleAction :: Ctx -> UserAction -> IO ()
handleAction ctx action = do
  st <- readTVarIO (ctxState ctx)
  let wv = appWebView (ctxWidgets ctx)
  let entry = appSearch (ctxWidgets 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) StartTop
    PrevChapter -> goto ctx (stIndex st - 1) StartTop
    GoToChapter i frag -> goto ctx i (startOfFrag frag)
    -- `turnPage` only exists in Paginated mode (it's injected by `pageScript`).
    -- In Scrolling mode there's nothing to page within, so move by chapter.
    NextPage -> case stMode st of
      Paginated -> evalJSBool wv "turnPage(1)" $ \moved ->
        unless moved $ goto ctx (stIndex st + 1) StartTop
      Scrolling -> goto ctx (stIndex st + 1) StartTop
    PrevPage -> case stMode st of
      Paginated -> evalJSBool wv "turnPage(-1)" $ \moved ->
        unless moved $ goto ctx (stIndex st - 1) StartLast
      Scrolling -> goto ctx (stIndex st - 1) StartTop
    ToggleMode -> do
      let newMode = if stMode st == Paginated then Scrolling else Paginated
      atomically $ modifyTVar' (ctxState ctx) $ \s -> s { stMode = newMode }
      goto ctx (stIndex st) StartTop
    SearchFocus -> void $ Gtk.widgetGrabFocus entry

-- | Where to land when a chapter loads: the first page, a specific TOC
-- @#fragment@'s page, or the last page (used when paging backwards into the
-- previous chapter).
data StartAt = StartTop | StartFrag T.Text | StartLast

-- | Map a raw TOC fragment (possibly empty) to a landing position.
startOfFrag :: T.Text -> StartAt
startOfFrag f = if T.null f then StartTop else StartFrag f

-- | Move to a chapter (clamped), render it if needed, land at @start@, and
-- remember the position. Neighbours are preloaded afterwards.
goto :: Ctx -> ChapterIndex -> StartAt -> IO ()
goto ctx target start = 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 start
      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 start)
    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 ()

getMode :: Ctx -> IO ReadMode
getMode ctx = stMode <$> readTVarIO (ctxState ctx)

display :: Ctx -> Chapter -> StartAt -> IO ()
display ctx chapter start = do
  mode <- getMode ctx
  setWindowTitle ctx (chapterIndex chapter) (chapterTitle chapter)
  WebKit.webViewLoadHtml (appWebView (ctxWidgets ctx)) (wrapHtml (chapterHtml chapter) start mode) Nothing

showLoading :: Ctx -> ChapterRef -> IO ()
showLoading ctx ref = do
  mode <- getMode ctx
  setWindowTitle ctx (refIndex ref) (refTitle ref)
  WebKit.webViewLoadHtml (appWebView (ctxWidgets ctx)) (wrapHtml (Html "<p style=\"opacity:0.5\">Loading…</p>") StartTop mode) 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 :: Html -> StartAt -> ReadMode -> T.Text
wrapHtml (Html body) start mode =
  T.concat
    [ "<!DOCTYPE html><html><head><meta charset=\"utf-8\"><style>",
      ( case mode of
          Paginated -> paginatedCss
          Scrolling -> scrollCss
      ),
      "</style></head><body>",
      body,
      -- The page controller only exists in paginated mode; scroll mode is a
      -- plain, natively-scrolling document with no injected script.
      ( case mode of
          Paginated -> pageScript <> startScript start
          Scrolling -> ""
      ),
      "</body></html>"
    ]
  where
    -- Paginated layout: the body is a CSS multi-column box. Each column is
    -- half the viewport, so two columns (a two-page spread) show at once, like
    -- an open book. html clips the overflow; we reveal the next spread by
    -- translating the body left by N*100vw (one viewport = one spread). Each
    -- top-level block fills its 50vw column; horizontal padding gives the page
    -- its side margins, and the inner paddings meet to form the centre gutter.
    paginatedCss =
      T.concat
        [ "*{box-sizing:border-box;}",
          "html,body{height:100%;margin:0;padding:0;}",
          "html{overflow:hidden;}",
          "body{height:100vh;column-width:50vw;column-gap:0;column-fill:auto;",
          "font-family:Georgia,serif;line-height:1.6;}",
          "body>*{padding-left:3rem;padding-right:3rem;}",
          "img{max-width:100%;height:auto;}"
        ]
    -- Scroll layout: an ordinary centred, vertically-scrolling web page. No
    -- columns, no transform, no page controller.
    scrollCss =
      T.concat
        [ "html,body{height:100%;margin:0;padding:0;}",
          "body{max-width:42rem;margin:0 auto;padding:2rem 1rem;overflow-y:auto;",
          "font-family:Georgia,serif;line-height:1.6;}",
          "img{max-width:100%;height:auto;}"
        ]
    -- The JS "page controller": a dumb rendering primitive. `off` is the
    -- current page index. turnPage returns false when it would run off either
    -- end, which is the signal Haskell uses to flip to the prev/next chapter.
    pageScript =
      "<script>var off=0;"
        <> "function pages(){return Math.max(1,Math.ceil(document.body.scrollWidth/window.innerWidth));}"
        <> "function apply(){document.body.style.transform='translateX('+(-off*100)+'vw)';}"
        <> "function turnPage(d){var n=off+d;if(n<0||n>=pages())return false;off=n;apply();return true;}"
        <> "function goToPage(p){off=Math.max(0,Math.min(p,pages()-1));apply();}"
        <> "window.addEventListener('resize',function(){goToPage(off);});</script>"
    -- Where to land once the page controller is defined. StartLast waits for
    -- 'load' so images have sized and pages() reflects the true total width.
    startScript StartTop = ""
    startScript StartLast =
      "<script>window.addEventListener('load',function(){goToPage(pages()-1);});</script>"
    -- On a TOC #fragment jump, translate the anchor's x-offset into a page
    -- index (scrollIntoView is a no-op once overflow is hidden).
    startScript (StartFrag f) =
      let safe = T.filter (\c -> c /= '"' && c /= '\\') f
       in "<script>var el=document.getElementById(\"" <> safe <> "\");if(el)goToPage(Math.floor(el.offsetLeft/window.innerWidth));</script>"


-- | Re-align the paginated view after an in-page find. WebKit reveals a match
-- by scrolling the (multi-column) layout, which leaves the transform-based
-- pager out of sync so several half-pages show at once once the search ends.
-- Reset the scroll offset back to zero and re-apply the current page transform.
-- No-op in scrolling mode, which scrolls natively and needs no fix-up.
snapPagination :: Ctx -> IO ()
snapPagination ctx = do
  mode <- getMode ctx
  when (mode == Paginated) $
    evalJSBool
      (appWebView (ctxWidgets ctx))
      ( T.concat
          [ "var d=document.documentElement,b=document.body;",
            "d.scrollLeft=0;d.scrollTop=0;if(b){b.scrollLeft=0;b.scrollTop=0;}",
            "window.scrollTo(0,0);if(typeof apply==='function'){apply();}true"
          ]
      )
      (\_ -> pure ())

evalJSBool :: WebKit.WebView -> T.Text -> (Bool -> IO ()) -> IO ()
evalJSBool wv src k =
  WebKit.webViewEvaluateJavascript wv src (-1) Nothing Nothing (Nothing :: Maybe Gio.Cancellable)
  (Just $ \_ res -> do
      -- A JS runtime error makes `...Finish` throw; treat that as `False`
      -- rather than letting the exception abort the whole program.
      r <- try (WebKit.webViewEvaluateJavascriptFinish wv res >>= JSC.valueToBoolean)
      case r of
        Right b -> k b
        Left (_ :: SomeException) -> k False)

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

matches :: T.Text -> PlainText -> Bool
matches q (PlainText 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 ()