From a648d77052f04d4731d728fc317a0947b35a3ed5 Mon Sep 17 00:00:00 2001 From: tv Date: Mon, 9 Mar 2026 03:35:50 +0100 Subject: externalize segmentation renderer --- src/TextViewport/Buffer/Buffer.hs | 14 ++++---- src/TextViewport/Buffer/Item.hs | 17 ++-------- src/TextViewport/Render/CachedRender.hs | 5 ++- src/TextViewport/Render/RenderBuffer.hs | 6 ++-- src/TextViewport/Render/RenderCache.hs | 8 ++--- src/TextViewport/Render/RenderItem.hs | 9 +++-- src/TextViewport/Render/RenderState.hs | 28 ++++++++-------- src/TextViewport/Render/Segmentation.hs | 22 ++++++++++-- src/TextViewport/Viewport/Instance.hs | 33 +++++++++--------- src/TextViewport/Viewport/Viewport.hs | 6 ++-- test/Spec.hs | 59 +++++++++++++++++---------------- 11 files changed, 111 insertions(+), 96 deletions(-) diff --git a/src/TextViewport/Buffer/Buffer.hs b/src/TextViewport/Buffer/Buffer.hs index 62ce232..53eb103 100644 --- a/src/TextViewport/Buffer/Buffer.hs +++ b/src/TextViewport/Buffer/Buffer.hs @@ -3,33 +3,33 @@ module TextViewport.Buffer.Buffer where import Data.Sequence qualified as Seq import TextViewport.Buffer.Item (Item) -newtype Buffer a = Buffer { unBuffer :: Seq.Seq (Item a) } +newtype Buffer a seg = Buffer { unBuffer :: Seq.Seq (Item a seg) } deriving (Eq, Show) -- | Build a buffer from a list -fromList :: [Item a] -> Buffer a +fromList :: [Item a seg] -> Buffer a seg fromList xs = Buffer (Seq.fromList xs) -- | Modify an item at index -modifyItem :: Int -> (Item a -> Item a) -> Buffer a -> Buffer a +modifyItem :: Int -> (Item a seg -> Item a seg) -> Buffer a seg -> Buffer a seg modifyItem ix f (Buffer xs) = Buffer (Seq.adjust' f ix xs) -- | Insert an item -insertItem :: Int -> Item a -> Buffer a -> Buffer a +insertItem :: Int -> Item a seg -> Buffer a seg -> Buffer a seg insertItem ix x (Buffer xs) = Buffer (Seq.insertAt ix x xs) -- | Delete an item -deleteItem :: Int -> Buffer a -> Buffer a +deleteItem :: Int -> Buffer a seg -> Buffer a seg deleteItem ix (Buffer xs) = Buffer (Seq.deleteAt ix xs) -- | Append an item -appendItem :: Item a -> Buffer a -> Buffer a +appendItem :: Item a seg -> Buffer a seg -> Buffer a seg appendItem x (Buffer xs) = Buffer (xs Seq.|> x) -- | Extract underlying Seq (if needed) -toSeq :: Buffer a -> Seq.Seq (Item a) +toSeq :: Buffer a seg -> Seq.Seq (Item a seg) toSeq (Buffer xs) = xs diff --git a/src/TextViewport/Buffer/Item.hs b/src/TextViewport/Buffer/Item.hs index b5ea743..00edf7b 100644 --- a/src/TextViewport/Buffer/Item.hs +++ b/src/TextViewport/Buffer/Item.hs @@ -1,21 +1,8 @@ module TextViewport.Buffer.Item where -import Data.Text (Text) -import Data.HashMap.Strict qualified as HM -import Text.Hyphenation qualified as H - -data Item a = Item +data Item a seg = Item { itemText :: a - , itemSegments :: SegmentStrategy a + , itemSegments :: seg } deriving (Eq, Show) - -data SegmentStrategy a - = NoSegments - | FixedWidthSegments - | HyphenateSegments - { hsLang :: H.Language - , hsCache :: HM.HashMap a [(a, a)] - } - deriving (Eq, Show) diff --git a/src/TextViewport/Render/CachedRender.hs b/src/TextViewport/Render/CachedRender.hs index b5af8d4..48be1eb 100644 --- a/src/TextViewport/Render/CachedRender.hs +++ b/src/TextViewport/Render/CachedRender.hs @@ -1,12 +1,11 @@ module TextViewport.Render.CachedRender where -import TextViewport.Buffer.Item (SegmentStrategy) import TextViewport.Render.RenderedItem (RenderedItem) -data CachedRender a = CachedRender +data CachedRender a seg = CachedRender { crWidth :: !Int - , crStrategy :: !(SegmentStrategy a) + , crStrategy :: !seg , crText :: !a , crRendered :: !(RenderedItem a) } diff --git a/src/TextViewport/Render/RenderBuffer.hs b/src/TextViewport/Render/RenderBuffer.hs index fb782f5..b6378ef 100644 --- a/src/TextViewport/Render/RenderBuffer.hs +++ b/src/TextViewport/Render/RenderBuffer.hs @@ -8,8 +8,10 @@ import TextViewport.Render.CachedRender import TextViewport.Render.RenderCache import TextViewport.Render.RenderItem (renderItem) import TextViewport.Render.RenderedBuffer +import TextViewport.Render.Segmentation (Segmenter) -renderBuffer :: (Hashable t, Textual t, Index t ~ Int) => Int -> Buffer t -> RenderCache t -> (RenderCache t, RenderedBuffer t) + +renderBuffer :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> Buffer a seg -> RenderCache a seg -> (RenderCache a seg, RenderedBuffer a) renderBuffer width (Buffer items) (RenderCache cache) = let n = Seq.length items go i (cAcc, rAcc) @@ -23,7 +25,7 @@ renderBuffer width (Buffer items) (RenderCache cache) = in go (i + 1) (cAcc', rAcc') in go 0 (cache, Seq.empty) -updateRenderedItem :: (Hashable t, Textual t, Index t ~ Int) => Int -> Int -> Buffer t -> RenderCache t -> RenderedBuffer t -> (RenderCache t, RenderedBuffer t) +updateRenderedItem :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> Int -> Buffer a seg -> RenderCache a seg -> RenderedBuffer a -> (RenderCache a seg, RenderedBuffer a) updateRenderedItem width itemIx (Buffer items) (RenderCache cache) (RenderedBuffer rb) = let item = Seq.index items itemIx mOld = Seq.index cache itemIx diff --git a/src/TextViewport/Render/RenderCache.hs b/src/TextViewport/Render/RenderCache.hs index dcd65e0..29cd6fc 100644 --- a/src/TextViewport/Render/RenderCache.hs +++ b/src/TextViewport/Render/RenderCache.hs @@ -6,16 +6,16 @@ import TextViewport.Buffer.Buffer (Buffer(Buffer)) import TextViewport.Render.CachedRender (CachedRender) -newtype RenderCache a = RenderCache { unRenderCache :: Seq (Maybe (CachedRender a)) } +newtype RenderCache a seg = RenderCache { unRenderCache :: Seq (Maybe (CachedRender a seg)) } deriving (Eq, Show) -- | Create an empty cache matching the buffer size -emptyRenderCacheFor :: Buffer a -> RenderCache a +emptyRenderCacheFor :: Buffer a seg -> RenderCache a seg emptyRenderCacheFor (Buffer xs) = RenderCache (Seq.replicate (Seq.length xs) Nothing) -- | Resize cache to match buffer length -resizeCache :: Buffer a -> RenderCache a -> RenderCache a +resizeCache :: Buffer a seg -> RenderCache a seg -> RenderCache a seg resizeCache (Buffer xs) (RenderCache cache) = let n = Seq.length xs m = Seq.length cache @@ -24,5 +24,5 @@ resizeCache (Buffer xs) (RenderCache cache) = else Seq.take n cache -- | Number of cached items -length :: RenderCache a -> Int +length :: RenderCache a seg -> Int length (RenderCache xs) = Seq.length xs diff --git a/src/TextViewport/Render/RenderItem.hs b/src/TextViewport/Render/RenderItem.hs index 7e00cf1..0cddb83 100644 --- a/src/TextViewport/Render/RenderItem.hs +++ b/src/TextViewport/Render/RenderItem.hs @@ -5,10 +5,13 @@ import Data.Sequences (Index, Textual) import TextViewport.Buffer.Item (Item(..)) import TextViewport.Render.CachedRender import TextViewport.Render.RenderedItem -import TextViewport.Render.Segmentation (applyStrategy) +import TextViewport.Render.Segmentation (Segmenter(applySeg)) -renderItem :: (Hashable t, Textual t, Index t ~ Int) => Int -> Int -> Item t -> Maybe (CachedRender t) -> CachedRender t +renderItem + :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) + => Int -> Int -> Item a seg -> Maybe (CachedRender a seg) + -> CachedRender a seg renderItem width itemIx (Item txt strategy) mOld = case mOld of Just old @@ -16,7 +19,7 @@ renderItem width itemIx (Item txt strategy) mOld = , crText old == txt -> old _ -> - let linesV = applyStrategy strategy width itemIx txt + let linesV = applySeg strategy width itemIx txt rendered = RenderedItem linesV in CachedRender { crWidth = width diff --git a/src/TextViewport/Render/RenderState.hs b/src/TextViewport/Render/RenderState.hs index 8c0cdef..978ec31 100644 --- a/src/TextViewport/Render/RenderState.hs +++ b/src/TextViewport/Render/RenderState.hs @@ -11,16 +11,18 @@ import TextViewport.Render.RenderBuffer (renderBuffer) import TextViewport.Render.RenderCache (RenderCache(..), emptyRenderCacheFor, resizeCache) import TextViewport.Render.RenderedBuffer (RenderedBuffer(RenderedBuffer)) import TextViewport.Render.RenderedBuffer qualified as RenderedBuffer +import TextViewport.Render.Segmentation (Segmenter) -data RenderState a = RenderState - { rsBuffer :: Buffer a -- original items - , rsCache :: RenderCache a -- per-item cached renders + +data RenderState a seg = RenderState + { rsBuffer :: Buffer a seg -- original items + , rsCache :: RenderCache a seg -- per-item cached renders , rsRendered :: RenderedBuffer a -- fully segmented + hyphenated lines , rsWidth :: Int -- segmenting width , rsLineCount :: Int } deriving (Eq, Show) -mkRenderState :: (Hashable a, Textual a, Index a ~ Int) => Int -> Buffer a -> RenderState a +mkRenderState :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> Buffer a seg -> RenderState a seg mkRenderState width buf = let (cache1, rendered) = renderBuffer width buf (emptyRenderCacheFor buf) in RenderState @@ -32,7 +34,7 @@ mkRenderState width buf = } -- RenderState has to be rebuilt whenever the buffer or the width changes. -updateRenderState :: (Hashable a, Textual a, Index a ~ Int) => Int -> Buffer a -> RenderState a -> RenderState a +updateRenderState :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> Buffer a seg -> RenderState a seg -> RenderState a seg updateRenderState width buf rs = let (cache1, rendered) = renderBuffer width buf (rsCache rs) in rs @@ -43,7 +45,7 @@ updateRenderState width buf rs = , rsLineCount = length (RenderedBuffer.flatten rendered) } -modifyItemRS :: (Hashable a, Textual a, Index a ~ Int) => Int -> (Item a -> Item a) -> RenderState a -> RenderState a +modifyItemRS :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> (Item a seg -> Item a seg) -> RenderState a seg -> RenderState a seg modifyItemRS ix f st = let buf' = Buffer.modifyItem ix f (rsBuffer st) cache' = resizeCache buf' (rsCache st) @@ -54,7 +56,7 @@ modifyItemRS ix f st = , rsLineCount = length (RenderedBuffer.flatten rendered1) } -insertItem :: (Hashable a, Textual a, Index a ~ Int) => Int -> Item a -> RenderState a -> RenderState a +insertItem :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> Item a seg -> RenderState a seg -> RenderState a seg insertItem i newItem st = let Buffer items = rsBuffer st items' = Seq.insertAt i newItem items @@ -67,7 +69,7 @@ insertItem i newItem st = , rsLineCount = length (RenderedBuffer.flatten rendered1) } -deleteItem :: (Hashable a, Textual a, Index a ~ Int) => Int -> RenderState a -> RenderState a +deleteItem :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> RenderState a seg -> RenderState a seg deleteItem i st = let Buffer items = rsBuffer st items' = Seq.deleteAt i items @@ -80,7 +82,7 @@ deleteItem i st = , rsLineCount = length (RenderedBuffer.flatten rendered1) } -replaceItem :: (Hashable a, Textual a, Index a ~ Int) => Int -> Item a -> RenderState a -> RenderState a +replaceItem :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> Item a seg -> RenderState a seg -> RenderState a seg replaceItem i newItem st = let Buffer items = rsBuffer st items' = Seq.update i newItem items @@ -93,11 +95,11 @@ replaceItem i newItem st = , rsLineCount = length (RenderedBuffer.flatten rendered1) } -appendItem :: (Hashable a, Textual a, Index a ~ Int) => Item a -> RenderState a -> RenderState a +appendItem :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Item a seg -> RenderState a seg -> RenderState a seg appendItem newItem st = insertItem (Seq.length (let Buffer xs = rsBuffer st in xs)) newItem st -clearBuffer :: RenderState a -> RenderState a +clearBuffer :: RenderState a seg -> RenderState a seg clearBuffer st = let buf' = Buffer Seq.empty cache' = RenderCache Seq.empty @@ -107,7 +109,7 @@ clearBuffer st = , rsLineCount = 0 } -fromList :: (Hashable a, Textual a, Index a ~ Int) => Int -> [Item a] -> RenderState a +fromList :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> [Item a seg] -> RenderState a seg fromList width xs = let buf = Buffer (Seq.fromList xs) cache0 = RenderCache (Seq.replicate (length xs) Nothing) @@ -120,7 +122,7 @@ fromList width xs = , rsLineCount = length (RenderedBuffer.flatten rendered) } -fromSeq :: (Hashable a, Textual a, Index a ~ Int) => Int -> Seq (Item a) -> RenderState a +fromSeq :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> Seq (Item a seg) -> RenderState a seg fromSeq width items = let buf = Buffer items cache0 = RenderCache (Seq.replicate (Seq.length items) Nothing) diff --git a/src/TextViewport/Render/Segmentation.hs b/src/TextViewport/Render/Segmentation.hs index 3d64748..2ec530a 100644 --- a/src/TextViewport/Render/Segmentation.hs +++ b/src/TextViewport/Render/Segmentation.hs @@ -13,11 +13,29 @@ import Data.Text qualified as T import Data.Vector (Vector) import Data.Vector qualified as V import Text.Hyphenation qualified as H -import TextViewport.Buffer.Item import TextViewport.Render.RenderedLine (RenderedLine(..)) -- TODO qualified -applyStrategy :: (Hashable t, Textual t, Index t ~ Int) => SegmentStrategy t -> Int -> Int -> t -> Vector (RenderedLine t) +-- | User-pluggable segmentation interface +class Segmenter seg a where + applySeg :: seg -> Int -> Int -> a -> Vector (RenderedLine a) + +-- | Built-in segmentation strategies (backwards compatible) +data BuiltinSeg a + = NoSegments + | FixedWidthSegments + | HyphenateSegments + { hsLang :: H.Language + , hsCache :: HM.HashMap a [(a, a)] + } + deriving (Eq, Show) + +-- | Built-in instance +instance (Hashable a, Textual a, Index a ~ Int) => Segmenter (BuiltinSeg a) a where + applySeg = applyStrategy + + +applyStrategy :: (Hashable a, Textual a, Index a ~ Int) => BuiltinSeg a -> Int -> Int -> a -> Vector (RenderedLine a) applyStrategy NoSegments width itemIx txt = let rawLines = S.splitWhen (=='\n') txt diff --git a/src/TextViewport/Viewport/Instance.hs b/src/TextViewport/Viewport/Instance.hs index c3ce338..e1cc560 100644 --- a/src/TextViewport/Viewport/Instance.hs +++ b/src/TextViewport/Viewport/Instance.hs @@ -9,69 +9,70 @@ import TextViewport.Render.RenderState qualified as RenderState import TextViewport.Render.RenderState (RenderState, mkRenderState) import TextViewport.Render.RenderedBuffer qualified as RenderedBuffer import TextViewport.Render.RenderedLine (RenderedLine(..)) -- TODO qualified +import TextViewport.Render.Segmentation (Segmenter) import TextViewport.Viewport.Position (lookupPosition) import TextViewport.Viewport.Viewport (Viewport, clampViewport, mkViewport) import TextViewport.Viewport.Viewport qualified as Viewport -data Instance a = Instance - { viRender :: RenderState a +data Instance a seg = Instance + { viRender :: RenderState a seg , viView :: Viewport } deriving (Show) -mkInstance :: (Hashable a, Textual a, Index a ~ Int) => Int -> Int -> Buffer a -> Instance a +mkInstance :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> Int -> Buffer a seg -> Instance a seg mkInstance width height buf = let rs = mkRenderState width buf vp = mkViewport width height rs in Instance rs vp -visibleLines :: Instance a -> [RenderedLine a] +visibleLines :: Instance a seg -> [RenderedLine a] visibleLines (Instance rs vp) = take (Viewport.vpHeight vp) . drop (Viewport.vpOffset vp) . RenderedBuffer.flatten $ RenderState.rsRendered rs -applyToInstance :: (Viewport -> Viewport) -> Instance a -> Instance a +applyToInstance :: (Viewport -> Viewport) -> Instance a seg -> Instance a seg applyToInstance f (Instance rs vp) = let vp' = f vp in Instance rs (clampViewport rs vp') -applyToInstanceRS :: (RenderState a -> Viewport -> Viewport) -> Instance a -> Instance a +applyToInstanceRS :: (RenderState a seg -> Viewport -> Viewport) -> Instance a seg -> Instance a seg applyToInstanceRS f (Instance rs vp) = let vp' = f rs vp in Instance rs (clampViewport rs vp') -scrollByI :: Int -> Instance a -> Instance a +scrollByI :: Int -> Instance a seg -> Instance a seg scrollByI delta = applyToInstance (Viewport.scrollBy delta) -scrollUpI :: Int -> Instance a -> Instance a +scrollUpI :: Int -> Instance a seg -> Instance a seg scrollUpI delta = applyToInstance (Viewport.scrollUp delta) -scrollDownI :: Int -> Instance a -> Instance a +scrollDownI :: Int -> Instance a seg -> Instance a seg scrollDownI delta = applyToInstance (Viewport.scrollDown delta) -pageUpI :: Instance a -> Instance a +pageUpI :: Instance a seg -> Instance a seg pageUpI = applyToInstance Viewport.pageUp -pageDownI :: Instance a -> Instance a +pageDownI :: Instance a seg -> Instance a seg pageDownI = applyToInstance Viewport.pageDown -alignTopI :: Instance a -> Instance a +alignTopI :: Instance a seg -> Instance a seg alignTopI = applyToInstance Viewport.alignTop -alignBottomI :: Instance a -> Instance a +alignBottomI :: Instance a seg -> Instance a seg alignBottomI = applyToInstanceRS Viewport.alignBottom -modifyItemI :: (Hashable a, Textual a, Index a ~ Int) => Int -> (Item a -> Item a) -> Instance a -> Instance a +modifyItemI :: (Segmenter seg a, Hashable a, Textual a, Index a ~ Int) => Int -> (Item a seg -> Item a seg) -> Instance a seg -> Instance a seg modifyItemI ix f (Instance rs vp) = let buf' = Buffer.modifyItem ix f (RenderState.rsBuffer rs) rs' = mkRenderState (RenderState.rsWidth rs) buf' vp' = clampViewport rs' vp in Instance rs' vp' -lookupPositionI :: Int -> Int -> Instance a -> Maybe (Int, Int) +lookupPositionI :: Int -> Int -> Instance a seg -> Maybe (Int, Int) lookupPositionI x y (Instance rs vp) = lookupPosition x y vp (RenderState.rsRendered rs) ---debugVI :: Instance a -> IO () +--debugVI :: Instance a seg -> IO () --debugVI (Instance rs vp) = do -- putStrLn ("offset = " ++ show (Viewport.vpOffset vp)) -- putStrLn ("height = " ++ show (Viewport.vpHeight vp)) diff --git a/src/TextViewport/Viewport/Viewport.hs b/src/TextViewport/Viewport/Viewport.hs index 65f48e4..36392c7 100644 --- a/src/TextViewport/Viewport/Viewport.hs +++ b/src/TextViewport/Viewport/Viewport.hs @@ -10,7 +10,7 @@ data Viewport = Viewport , vpOffset :: !Int } deriving (Show) -mkViewport :: Int -> Int -> RenderState a -> Viewport +mkViewport :: Int -> Int -> RenderState a seg -> Viewport mkViewport width height rs = alignBottom rs Viewport { vpWidth = width @@ -19,7 +19,7 @@ mkViewport width height rs = } -- any function that sets vpOffset and can overshoot should use clampViewport -clampViewport :: RenderState a -> Viewport -> Viewport +clampViewport :: RenderState a seg -> Viewport -> Viewport clampViewport rs vp = let total = RenderState.rsLineCount rs maxOff = max 0 (total - vpHeight vp) @@ -48,7 +48,7 @@ alignTop :: Viewport -> Viewport alignTop vp = vp { vpOffset = 0 } -alignBottom :: RenderState a -> Viewport -> Viewport +alignBottom :: RenderState a seg -> Viewport -> Viewport alignBottom rs vp = let total = RenderState.rsLineCount rs off = max 0 (total - vpHeight vp) diff --git a/test/Spec.hs b/test/Spec.hs index a886816..fc7ff07 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -11,7 +11,7 @@ import Test.Hspec import Text.Hyphenation qualified as H import TextViewport.Buffer.Buffer (Buffer(..)) import TextViewport.Buffer.Buffer qualified as Buffer -import TextViewport.Buffer.Item (Item(..), SegmentStrategy(..)) +import TextViewport.Buffer.Item (Item(..)) import TextViewport.Render.CachedRender (CachedRender(..)) import TextViewport.Render.RenderBuffer import TextViewport.Render.RenderCache (RenderCache(..), emptyRenderCacheFor) @@ -39,19 +39,22 @@ shouldRunUnder action maxNs = do let dt = toNanoSecs (t2 - t1) dt `shouldSatisfy` (< maxNs) -mkItem :: String -> Item String +mkItem :: String -> Item String (BuiltinSeg String) mkItem t = Item t NoSegments -mkBuf :: [String] -> Buffer String +mkBuf :: [String] -> Buffer String (BuiltinSeg String) mkBuf xs = Buffer.fromList (map mkItem xs) -mkRS :: Int -> [String] -> RenderState String +mkBufSeg :: [String] -> seg -> Buffer String seg +mkBufSeg xs seg = Buffer.fromList (map (flip Item seg) xs) + +mkRS :: Int -> [String] -> RenderState String (BuiltinSeg String) mkRS w xs = mkRenderState w (mkBuf xs) emptyCache :: HM.HashMap String [(String, String)] emptyCache = HM.empty -emptyBuffer :: Buffer String +emptyBuffer :: Buffer String (BuiltinSeg String) emptyBuffer = Buffer.empty emptyStrings :: [String] @@ -138,17 +141,17 @@ main = hspec do RB.flatten rb `shouldSatisfy` (not . null) it "renderBuffer should reject mismatched cache size" do - let buf = Buffer.fromList [Item "a" NoSegments] + let buf = mkBuf ["a"] badCache = RenderCache Seq.empty evaluate (renderBuffer 10 buf badCache) `shouldThrow` anyException it "renderBuffer should reject non-positive width" do - let buf = Buffer.fromList [Item "hello" NoSegments] + let buf = mkBuf ["hello world"] cache = emptyRenderCacheFor buf evaluate (renderBuffer 0 buf cache) `shouldThrow` anyException it "renderBuffer should invalidate cache when width changes" do - let buf = Buffer.fromList [Item "hello world" NoSegments] + let buf = mkBuf ["hello world"] (cache1, _) = renderBuffer 10 buf (emptyRenderCacheFor buf) (_, rb2) = renderBuffer 5 buf cache1 length (RB.flatten rb2) `shouldSatisfy` (> 1) @@ -162,33 +165,33 @@ main = hspec do it "updateRenderedItem should reject mismatched rendered buffer size" do - let buf = Buffer.fromList [Item "a" NoSegments] + let buf = mkBuf ["a"] cache = emptyRenderCacheFor buf rb = RenderedBuffer Seq.empty evaluate (updateRenderedItem 10 0 buf cache rb) `shouldThrow` anyException it "updateRenderedItem should reject non-positive width" do - let buf = Buffer.fromList [Item "a" NoSegments] + let buf = mkBuf ["a"] cache = emptyRenderCacheFor buf rb = RenderedBuffer (Seq.singleton (RenderedItem V.empty)) evaluate (updateRenderedItem 0 0 buf cache rb) `shouldThrow` anyException it "updateRenderedItem should re-render when strategy changes" do - let buf0 = Buffer.fromList [Item "hello world" NoSegments] + let buf0 = mkBuf ["hello world"] (cache0, rb0) = renderBuffer 10 buf0 (emptyRenderCacheFor buf0) - buf1 = Buffer.fromList [Item "hello world" FixedWidthSegments] + buf1 = mkBufSeg ["hello world"] FixedWidthSegments (_, rb1) = updateRenderedItem 10 0 buf1 cache0 rb0 rb1 `shouldNotBe` rb0 it "updateRenderedItem should invalidate cache when strategy changes (cache must differ)" do - let buf0 = Buffer.fromList [mkItem "hello world"] + let buf0 = mkBuf ["hello world"] (cache0, rb0) = renderBuffer 10 buf0 (emptyRenderCacheFor buf0) - buf1 = Buffer.fromList [Item "hello world" FixedWidthSegments] + buf1 = mkBufSeg ["hello world"] FixedWidthSegments (cache1, _) = updateRenderedItem 10 0 buf1 cache0 rb0 cache1 `shouldNotBe` cache0 it "renderBuffer should reject negative indices" do - let buf = Buffer.fromList [Item "a" NoSegments] + let buf = mkBuf ["a"] cache = emptyRenderCacheFor buf evaluate (updateRenderedItem 10 (-1) buf cache (RenderedBuffer Seq.empty)) `shouldThrow` anyException @@ -212,7 +215,7 @@ main = hspec do it "renderItem should invalidate cache when strategy changes" do let old = CachedRender { crWidth = 10 - , crStrategy = NoSegments + , crStrategy = NoSegments :: BuiltinSeg String , crText = "hello world" , crRendered = RenderedItem mempty } @@ -223,7 +226,7 @@ main = hspec do it "renderItem should not reuse cache from a different item index" do let old = CachedRender { crWidth = 10 - , crStrategy = NoSegments + , crStrategy = NoSegments :: BuiltinSeg String , crText = "hello world" , crRendered = RenderedItem mempty } @@ -232,13 +235,13 @@ main = hspec do crRendered new `shouldNotBe` crRendered old it "renderItem should reject non-positive width" do - let itm = Item "hello" NoSegments + let itm = mkItem "hello" evaluate (renderItem 0 0 itm Nothing) `shouldThrow` anyException it "renderItem should invalidate cache when segmentation output changes" do let old = CachedRender { crWidth = 5 - , crStrategy = HyphenateSegments H.German_1996 mempty + , crStrategy = HyphenateSegments H.German_1996 emptyCache , crText = "Schifffahrt" , crRendered = RenderedItem mempty } @@ -283,30 +286,30 @@ main = hspec do RS.rsLineCount rs' `shouldBe` 0 it "updateRenderState should invalidate cache when width changes" do - let rs0 = mkRenderState 10 (Buffer.fromList [Item "hello world" NoSegments]) + let rs0 = mkRS 10 ["hello world"] rs1 = updateRenderState 5 (RS.rsBuffer rs0) rs0 RS.rsLineCount rs1 `shouldSatisfy` (> RS.rsLineCount rs0) it "modifyItemRS should fail on out-of-bounds index" do - evaluate (RS.modifyItemRS 99 id (mkRenderState 10 emptyBuffer)) + evaluate (RS.modifyItemRS 99 id (mkRS 10 [])) `shouldThrow` anyException it "insertItem should reject out-of-bounds index" do - let rs = mkRenderState 10 emptyBuffer + let rs = mkRS 10 [] rs' = RS.insertItem 5 (Item "x" NoSegments) rs RS.rsBuffer rs' `shouldBe` RS.rsBuffer rs it "deleteItem should fail on out-of-bounds index" do - let rs = mkRenderState 10 (Buffer.fromList [Item "a" NoSegments]) + let rs = mkRS 10 ["a"] evaluate (RS.deleteItem 5 rs) `shouldThrow` anyException it "replaceItem should handle out-of-bounds index consistently" do - let rs = mkRenderState 10 emptyBuffer + let rs = mkRS 10 [] evaluate (RS.replaceItem 0 (Item "x" NoSegments) rs) `shouldThrow` anyException it "clearBuffer should reset width or document that width persists" do - let rs = mkRenderState 10 (Buffer.fromList [Item "a" NoSegments]) + let rs = mkRS 10 ["a"] rs' = RS.clearBuffer rs RS.rsWidth rs' `shouldBe` 0 @@ -471,11 +474,11 @@ main = hspec do describe "Viewport" do it "mkViewport should reject non-positive width/height" do - let rs = mkRenderState 10 emptyBuffer + let rs = mkRS 10 [] evaluate (mkViewport 0 0 rs) `shouldThrow` anyException it "alignBottom should place viewport at last line even when height > total lines" do - let rs = mkRenderState 10 (Buffer.fromList [mkItem "a", mkItem "b"]) + let rs = mkRS 10 ["a","b"] vp = Viewport 10 5 0 vpOffset (VP.alignBottom rs vp) `shouldBe` 3 @@ -488,7 +491,7 @@ main = hspec do vpOffset (VP.pageUp vp) `shouldBe` 0 it "clampViewport should reject non-positive viewport height" do - let rs = mkRenderState 10 (Buffer.fromList [mkItem "a"]) + let rs = mkRS 10 ["a"] vp = Viewport 10 0 0 evaluate (clampViewport rs vp) `shouldThrow` anyException -- cgit v1.2.3