add book-wide text search

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 @\<body\>@ 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 @\<body\>@, falling back to the whole document.
 bodyScraper :: Scraper T.Text T.Text
 bodyScraper = innerHTML "body" <|> innerHTML anySelector

app/State.hs

@@ -22,4 +22,5 @@ initialState title path =
       stGen = 0,
       stUse = M.empty,
       stTick = 0,
+      stSearchIndex = M.empty
     }

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.

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,11 +225,13 @@ 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
+          when committed $ do
+            postGtk $ do
               s <- readTVarIO (ctxState ctx)
               when (stGen s == myGen) $ do
                 Gtk.listBoxRemoveAll (appSidebar (ctxWidgets ctx))
@@ -206,6 +242,23 @@ loadBook env ctx = do
                       _ -> 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
@@ -353,6 +406,41 @@ wrapHtml body frag =
       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
 --------------------------------------------------------------------------------
@@ -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)