diff --git a/app/EpubParser.hs b/app/EpubParser.hs index 47f7dac..70fd6dc 100644 --- a/app/EpubParser.hs +++ b/app/EpubParser.hs @@ -63,8 +63,10 @@ instance BookInfo EpubEnv where bookFilePath = bookPath loadStructure env = runExceptT (runReaderT buildStructure env) + renderChapter env ref = runExceptT (runReaderT (renderRef ref) env) + chapterText env ref = runExceptT (runReaderT (readPText ref) env) -------------------------------------------------------------------------------- -- Opening the archive -------------------------------------------------------------------------------- @@ -185,6 +187,25 @@ renderRef ref = do body = fromMaybe "" (scrapeStringLike withImages bodyScraper) in Chapter (refPath ref) (refTitle ref) body (refIndex ref) +stripTags :: T.Text -> T.Text +stripTags = T.unwords . T.words . go + where + go s = case T.break (== '<') s of + (before, rest) + | T.null rest -> before + | otherwise -> before <> " " <> go (T.drop 1 (T.dropWhile (/= '>') rest)) + +-- | Read a chapter file and render its @\@ to plaintext, excluding +-- any tags. +readPText :: ChapterRef -> EpubAction T.Text +readPText ref = do + env <- ask + let InternalPath p = refPath ref + pure $ case findEntry env p of + Nothing -> "" + Just entry -> + stripTags $ fromMaybe "" (scrapeStringLike (decodeEntry entry) bodyScraper) + -- | Grab the contents of @\@, falling back to the whole document. bodyScraper :: Scraper T.Text T.Text bodyScraper = innerHTML "body" <|> innerHTML anySelector diff --git a/app/State.hs b/app/State.hs index 854bdb8..e588ab9 100644 --- a/app/State.hs +++ b/app/State.hs @@ -22,4 +22,5 @@ initialState title path = stGen = 0, stUse = M.empty, stTick = 0, + stSearchIndex = M.empty } diff --git a/app/Types.hs b/app/Types.hs index 257e2fe..5a28b73 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -89,6 +89,9 @@ class BookInfo a where -- | Render a single chapter's body to self-contained HTML, on demand. renderChapter :: a -> ChapterRef -> IO (Either String Chapter) + -- | Extract a single chapter's plain text (tags stripped), for search. + chapterText :: a -> ChapterRef -> IO (Either String T.Text) + -- | Mutable application state, held in a 'Control.Concurrent.STM.TVar'. -- Rendered chapters accumulate in 'stCache' as the reader visits them. data AppState = AppState @@ -102,6 +105,7 @@ data AppState = AppState stGen :: Int, stUse :: M.Map ChapterIndex Int, stTick :: Int, + stSearchIndex :: M.Map ChapterIndex T.Text } -- | A user request, produced by the keyboard / sidebar and handled centrally. diff --git a/app/UI.hs b/app/UI.hs index 8751f53..60365a4 100644 --- a/app/UI.hs +++ b/app/UI.hs @@ -8,11 +8,15 @@ 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 @@ -40,7 +44,8 @@ data AppWidgets = AppWidgets { appWindow :: Gtk.ApplicationWindow, appWebView :: WebKit.WebView, appSidebar :: Gtk.ListBox, - appFileBttn :: Gtk.Button + appFileBttn :: Gtk.Button, + appSearch :: Gtk.SearchEntry } -- | Everything an action handler needs: shared state, widgets, and a way to @@ -48,7 +53,8 @@ data AppWidgets = AppWidgets data Ctx = Ctx { ctxState :: TVar AppState, ctxWidgets :: AppWidgets, - ctxRender :: TVar (ChapterRef -> IO (Either String Chapter)) + 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. @@ -66,7 +72,7 @@ buildLayout app = do sidebar <- Gtk.listBoxNew header <- Gtk.headerBarNew fileBttn <- Gtk.buttonNew - + sEntry <- Gtk.searchEntryNew Gtk.listBoxSetSelectionMode sidebar GtkEnums.SelectionModeSingle Gtk.widgetAddCssClass sidebar "toc" @@ -81,11 +87,12 @@ buildLayout app = do 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) + pure (AppWidgets window webView sidebar fileBttn sEntry) -- | Install the app-wide stylesheet (sidebar rows, selection, headings). applyStyles :: Gtk.ApplicationWindow -> IO () @@ -155,8 +162,35 @@ wireEvents ctx = do _ -> 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) @@ -191,20 +225,39 @@ loadBook env ctx = do writeTVar (ctxState ctx) (s { stRefs = refs, stToc = toc, stCache = M.empty, stIndex = ChapterIndex 0, - stTitle = bookTitle env, stBookPath = bookFilePath env}) + stTitle = bookTitle env, stBookPath = bookFilePath env, + stSearchIndex = M.empty}) 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 "") + 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 @@ -353,6 +406,41 @@ wrapHtml body frag = let safe = T.filter (\c -> c /= '"' && c /= '\\') f in "" + --------------------------------------------------------------------- + -- 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 -------------------------------------------------------------------------------- @@ -366,7 +454,8 @@ activate env app = do stateTVar <- newTVarIO (initialState (bookTitle env) (bookFilePath env)) renderVar <- newTVarIO (renderChapter env) widgets <- buildLayout app - let ctx = Ctx stateTVar widgets renderVar + pendingVar <- newTVarIO Nothing + let ctx = Ctx stateTVar widgets renderVar pendingVar wireEvents ctx loadBook env ctx #present (appWindow widgets)