add snap when finishing search

app/UI.hs

@@ -156,22 +156,38 @@ populateSidebar sidebar =
 -- 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 _ _ ->
-    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
+  _ <- 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
@@ -185,14 +201,14 @@ wireEvents ctx = do
     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)) >> 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
+      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
@@ -210,6 +226,7 @@ wireEvents ctx = do
     case drop (fromIntegral i) (displayRows (stRefs st) (stToc st)) of
       (Row _ _ idx frag : _) -> dispatch (GoToChapter idx frag)
       [] -> pure ()
+
   pure ()
 
 --------------------------------------------------------------------------------
@@ -316,10 +333,16 @@ handleAction ctx action = do
     NextChapter -> goto ctx (stIndex st + 1) StartTop
     PrevChapter -> goto ctx (stIndex st - 1) StartTop
     GoToChapter i frag -> goto ctx i (startOfFrag frag)
-    NextPage -> evalJSBool wv "turnPage(1)" $ \moved ->
-      unless moved $ goto ctx (stIndex st + 1) StartTop
-    PrevPage -> evalJSBool wv "turnPage(-1)" $ \moved ->
-      unless moved $ goto ctx (stIndex st - 1) StartLast
+    -- `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 }
@@ -502,13 +525,36 @@ wrapHtml (Html body) start mode =
       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
-      val <- WebKit.webViewEvaluateJavascriptFinish wv res
-      b <- JSC.valueToBoolean val
-      k b)
+      -- 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