marko/svitak
Watch
1
0
Fork
You've already forked svitak
 1
Code Issues Pull requests Projects Releases Wiki Activity Actions

feature: add split page, scrolled or paginated tracking

Browse source
This commit is contained in:
Marko Andjelic 2026-07-06 15:20:05 +01:00
commit 4170a958d1
Signed by: marko
GPG key ID: 9C5E99C8C682FB59
4 changed files with 130 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

5
app/State.hs
View file

@ -6,7 +6,7 @@ module State (initialState) where
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Types (AppState (..), ChapterIndex (..))
import Types (AppState (..), ChapterIndex (..), ReadMode(..))
-- | Empty state shown while the book's structure loads in the background.
initialState :: T.Text -> FilePath -> AppState
@ -22,5 +22,6 @@ initialState title path =
stGen = 0,
stUse = M.empty,
stTick = 0,
stSearchIndex = M.empty
stSearchIndex = M.empty,
stMode = Paginated
}

11
app/Types.hs
View file

@ -24,6 +24,7 @@ module Types
-- * EPUB environment
EpubEnv (..),
EpubAction,
ReadMode(..),
)
where
@ -105,9 +106,14 @@ data AppState = AppState
stGen :: Int,
stUse :: M.Map ChapterIndex Int,
stTick :: Int,
stSearchIndex :: M.Map ChapterIndex T.Text
stSearchIndex :: M.Map ChapterIndex T.Text,
stMode :: ReadMode
}
-- Enable toggling between paginated (2 pages on the screen) or scrolling (single, flowing page)
data ReadMode = Paginated | Scrolling
deriving (Eq)
-- | A user request, produced by the keyboard / sidebar and handled centrally.
-- 'GoToChapter' carries an optional anchor to scroll to within the chapter.
data UserAction
@ -116,6 +122,9 @@ data UserAction
| ZoomIn
| ZoomOut
| GoToChapter ChapterIndex T.Text
| NextPage
| PrevPage
| ToggleMode
-- | Parsed EPUB, carried through the parser as a reader environment.
data EpubEnv = EpubEnv

136
app/UI.hs
View file

@ -7,7 +7,7 @@
module UI (runApp) where
import Control.Concurrent.Async (async)
import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar, readTVar)
import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar, readTVar, modifyTVar')
import Data.List (minimumBy)
import Data.Ord (comparing)
import Data.Maybe (listToMaybe)
@ -26,6 +26,7 @@ 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
@ -37,6 +38,7 @@ import Types
ChapterRef (..),
TocEntry (..),
UserAction (..),
ReadMode(..),
)
-- | Widget handles the rest of the module needs.
@ -155,8 +157,10 @@ wireEvents ctx = do
Gtk.eventControllerSetPropagationPhase keyCtrl GtkEnums.PropagationPhaseCapture
_ <- on keyCtrl #keyPressed $ \keyval _ _ ->
case keyval of
Gdk.KEY_Right -> dispatch NextChapter >> pure True
Gdk.KEY_Left -> dispatch PrevChapter >> pure True
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
_ -> pure False
@ -283,17 +287,36 @@ epPicker window ctx = do
handleAction :: Ctx -> UserAction -> IO ()
handleAction ctx action = do
st <- readTVarIO (ctxState ctx)
let wv = appWebView (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) ""
PrevChapter -> goto ctx (stIndex st - 1) ""
GoToChapter i frag -> goto ctx i frag
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
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
-- | Move to a chapter (clamped), render it if needed, scroll to @frag@, and
-- | 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 -> T.Text -> IO ()
goto ctx target frag = do
goto :: Ctx -> ChapterIndex -> StartAt -> IO ()
goto ctx target start = do
st <- readTVarIO (ctxState ctx)
let refs = stRefs st
total = length refs
@ -305,7 +328,7 @@ goto ctx target frag = do
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 frag
Just chapter -> display ctx chapter start
Nothing -> do
showLoading ctx ref
void $ async $ do
@ -317,7 +340,7 @@ goto ctx target frag = do
atomically $ modifyTVar' (ctxState ctx) $ \s -> insertLRU idx chapter s
postGtk $ do
cur <- stIndex <$> readTVarIO (ctxState ctx)
when (cur == idx) (display ctx chapter frag)
when (cur == idx) (display ctx chapter start)
preload ctx
-- | Bump the tick of an index to track frequency for cache eviction.
@ -362,15 +385,20 @@ cacheRef ctx refs n = do
Right chapter -> atomically $ modifyTVar' (ctxState ctx) $ \s -> s {stCache = M.insert idx chapter (stCache s)}
Left _ -> pure ()
display :: Ctx -> Chapter -> T.Text -> IO ()
display ctx chapter frag = do
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) frag) Nothing
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 "<p style=\"opacity:0.5\">Loading…</p>" "") Nothing
WebKit.webViewLoadHtml (appWebView (ctxWidgets ctx)) (wrapHtml "<p style=\"opacity:0.5\">Loading…</p>" StartTop mode) Nothing
setWindowTitle :: Ctx -> ChapterIndex -> T.Text -> IO ()
setWindowTitle ctx (ChapterIndex i) chapter = do
@ -387,28 +415,78 @@ setZoom ctx level = do
-- | 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 :: T.Text -> T.Text -> T.Text
wrapHtml body frag =
wrapHtml :: T.Text -> StartAt -> ReadMode -> T.Text
wrapHtml body start mode =
T.concat
[ "<!DOCTYPE html><html><head><meta charset=\"utf-8\">",
"<style>",
"body{max-width:42rem;margin:2rem auto;padding:0 1rem;",
"font-family:Georgia,serif;line-height:1.6;}",
"img{max-width:100%;height:auto;}",
[ "<!DOCTYPE html><html><head><meta charset=\"utf-8\"><style>",
( case mode of
Paginated -> paginatedCss
Scrolling -> scrollCss
),
"</style></head><body>",
body,
scrollScript frag,
-- 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
scrollScript "" = ""
scrollScript f =
-- 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 e=document.getElementById(\"" <> safe <> "\");if(e)e.scrollIntoView();</script>"
in "<script>var el=document.getElementById(\"" <> safe <> "\");if(el)goToPage(Math.floor(el.offsetLeft/window.innerWidth));</script>"
---------------------------------------------------------------------
-- Full text search --
---------------------------------------------------------------------
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)
chaptersMatching :: T.Text -> M.Map ChapterIndex T.Text -> [ChapterIndex]
chaptersMatching q = map fst . filter (matches q . snd) . M.toAscList

14
svitak.cabal
View file

@ -58,7 +58,8 @@ executable svitak
Types,
Navigation
build-depends: base,
build-depends: async,
base,
base64-bytestring,
bytestring,
containers,
@ -67,17 +68,17 @@ executable svitak
filepath,
gi-gdk4,
gi-gio,
gi-glib,
gi-gtk,
gi-javascriptcore6,
gi-webkit,
haskell-gi-base,
mtl,
scalpel,
text,
zip-archive,
scalpel-core,
stm,
gi-glib,
async,
scalpel-core
text,
zip-archive
hs-source-dirs: app
default-language: Haskell2010
@ -99,6 +100,7 @@ test-suite svitak-test
containers,
epub-metadata,
filepath,
gi-javascriptcore6,
mtl,
scalpel,
text,