diff --git a/app/UI.hs b/app/UI.hs index 4b4f609..358e8f3 100644 --- a/app/UI.hs +++ b/app/UI.hs @@ -156,38 +156,22 @@ 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 _ _ -> 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 + _ <- 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 Gtk.widgetAddController (appWindow (ctxWidgets ctx)) keyCtrl _ <- on (appFileBttn (ctxWidgets ctx)) #clicked $ epPicker (Just (appWindow (ctxWidgets ctx))) ctx @@ -201,14 +185,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)) >> snapPagination ctx >> pure True + Gdk.KEY_Escape -> Gtk.setEditableText entry "" >> WebKit.findControllerSearchFinish fc >> Gtk.widgetGrabFocus (appWebView (ctxWidgets 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 + 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 @@ -226,7 +210,6 @@ wireEvents ctx = do case drop (fromIntegral i) (displayRows (stRefs st) (stToc st)) of (Row _ _ idx frag : _) -> dispatch (GoToChapter idx frag) [] -> pure () - pure () -------------------------------------------------------------------------------- @@ -333,16 +316,10 @@ 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) - -- `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 + 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 ToggleMode -> do let newMode = if stMode st == Paginated then Scrolling else Paginated atomically $ modifyTVar' (ctxState ctx) $ \s -> s { stMode = newMode } @@ -525,36 +502,13 @@ wrapHtml (Html body) start mode = let safe = T.filter (\c -> c /= '"' && c /= '\\') f in "" - --- | 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) + val <- WebKit.webViewEvaluateJavascriptFinish wv res + b <- JSC.valueToBoolean val + k b) chaptersMatching :: T.Text -> M.Map ChapterIndex PlainText -> [ChapterIndex] chaptersMatching q = map fst . filter (matches q . snd) . M.toAscList