add tests

1 files changed, 531 insertions, 0 deletions

diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..3ada0ea
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,531 @@
+module Main (main) where
+
+import Control.Exception (evaluate)
+import Data.HashMap.Strict qualified as HM
+import Data.Sequence qualified as Seq
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Vector qualified as V
+import System.Clock (Clock(Monotonic), getTime, toNanoSecs)
+import System.Mem (performGC)
+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.Render.CachedRender (CachedRender(..))
+import TextViewport.Render.RenderBuffer
+import TextViewport.Render.RenderCache (RenderCache(..), emptyRenderCacheFor)
+import TextViewport.Render.RenderCache qualified as RC
+import TextViewport.Render.RenderItem
+import TextViewport.Render.RenderState (RenderState, mkRenderState, updateRenderState)
+import TextViewport.Render.RenderState qualified as RS
+import TextViewport.Render.RenderedBuffer (RenderedBuffer(..))
+import TextViewport.Render.RenderedBuffer qualified as RB
+import TextViewport.Render.RenderedItem (RenderedItem(..))
+import TextViewport.Render.RenderedLine (RenderedLine(..))
+import TextViewport.Render.Segmentation
+import TextViewport.Viewport.Instance
+import TextViewport.Viewport.Position (lookupPosition)
+import TextViewport.Viewport.Viewport (Viewport(..), clampViewport, mkViewport)
+import TextViewport.Viewport.Viewport qualified as VP
+
+
+shouldRunUnder :: IO a -> Integer -> IO ()
+shouldRunUnder action maxNs = do
+  performGC
+  t1 <- getTime Monotonic
+  _  <- evaluate =<< action
+  t2 <- getTime Monotonic
+  let dt = toNanoSecs (t2 - t1)
+  dt `shouldSatisfy` (< maxNs)
+
+mkItem :: T.Text -> Item
+mkItem t = Item t NoSegments
+
+mkBuf :: [T.Text] -> Buffer
+mkBuf xs = Buffer.fromList (map mkItem xs)
+
+mkRS :: Int -> [T.Text] -> RenderState
+mkRS w xs = mkRenderState w (mkBuf xs)
+
+
+main :: IO ()
+main = hspec do
+
+  describe "TextViewport" do
+
+    describe "Buffer" do
+
+      describe "Buffer" do
+
+        it "fromList builds a buffer" do
+          Buffer.fromList [mkItem "a", mkItem "b"] `shouldBe`
+            Buffer (Seq.fromList [mkItem "a", mkItem "b"])
+
+        it "modifyItem updates the correct index" do
+          let b = mkBuf ["a","b","c"]
+              b' = Buffer.modifyItem 1 (\itm -> itm { itemText = "X" }) b
+          Buffer.toSeq b' `shouldBe`
+            Seq.fromList [mkItem "a", mkItem "X", mkItem "c"]
+
+        it "insertItem inserts at index" do
+          let b = mkBuf ["a","c"]
+              b' = Buffer.insertItem 1 (mkItem "b") b
+          Buffer.toSeq b' `shouldBe`
+            Seq.fromList [mkItem "a", mkItem "b", mkItem "c"]
+
+        it "deleteItem removes the correct index" do
+          let b = mkBuf ["a","b","c"]
+              b' = Buffer.deleteItem 1 b
+          Buffer.toSeq b' `shouldBe`
+            Seq.fromList [mkItem "a", mkItem "c"]
+
+        it "appendItem appends" do
+          let b = mkBuf ["a","b"]
+              b' = Buffer.appendItem (mkItem "c") b
+          Buffer.toSeq b' `shouldBe`
+            Seq.fromList [mkItem "a", mkItem "b", mkItem "c"]
+
+        it "modifyItem should fail on out-of-bounds index" do
+          evaluate (Buffer.modifyItem 99 id (Buffer.fromList [])) `shouldThrow` anyException
+
+        it "insertItem should reject out-of-bounds index" do
+          let b = Buffer.fromList []
+              b' = Buffer.insertItem 5 (mkItem "x") b
+          Buffer.toSeq b' `shouldBe` Seq.empty
+
+        it "deleteItem should fail on out-of-bounds index" do
+          let b = Buffer.fromList [mkItem "a"]
+          evaluate (Buffer.deleteItem 5 b) `shouldThrow` anyException
+
+        it "modifyItem should run in logarithmic time" do
+          let n  = 200000
+              ix = n `div` 2
+              buf = Buffer.fromList (replicate n (mkItem "x"))
+          shouldRunUnder (pure $! Buffer.modifyItem ix id buf) 2000000
+
+        it "insertItem should run in sublinear time" do
+          let n  = 200000
+              ix = n `div` 2
+              buf = Buffer.fromList (replicate n (mkItem "x"))
+          shouldRunUnder (pure $! Buffer.insertItem ix (mkItem "y") buf) 2000000
+
+
+      describe "Item & SegmentStrategy" do
+
+        it "Hyphenator Eq instance should consider identical hyphenators equal" do
+          let hy = H.german_1996
+          (hy == hy) `shouldBe` True
+
+        it "HyphenateSegments with same hyphenator and same cache should be equal" do
+          let hy = H.german_1996
+              s1 = HyphenateSegments hy HM.empty
+              s2 = HyphenateSegments hy HM.empty
+          s1 == s2 `shouldBe` True
+
+        it "Show Hyphenator should reflect differences between hyphenators" do
+          let hy1 = H.german_1996
+              hy2 = H.english_US
+          show hy1 `shouldNotBe` show hy2
+
+        it "Show HyphenateSegments should differ for different hyphenators" do
+          let hy1 = H.german_1996
+              hy2 = H.english_US
+              s1  = HyphenateSegments hy1 HM.empty
+              s2  = HyphenateSegments hy2 HM.empty
+          show s1 `shouldNotBe` show s2
+
+        it "Show HyphenateSegments should not expose internal cache structure" do
+          let hy = H.german_1996
+              s  = HyphenateSegments hy (HM.fromList [("a",[("a","")])])
+          show s `shouldNotContain` "fromList"
+
+
+    describe "Render" do
+
+      describe "CachedRender" do
+        pure ()
+
+
+      describe "RenderBuffer" do
+
+        it "renderBuffer produces lines" do
+          let b = mkBuf ["hello world"]
+              (_, rb) = renderBuffer 10 b (RC.emptyRenderCacheFor b)
+          RB.flatten rb `shouldSatisfy` (not . null)
+
+        it "renderBuffer should reject mismatched cache size" do
+          let buf = Buffer.fromList [Item "a" NoSegments]
+              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]
+              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]
+              (cache1, _) = renderBuffer 10 buf (emptyRenderCacheFor buf)
+              (_, rb2) = renderBuffer 5 buf cache1
+          length (RB.flatten rb2) `shouldSatisfy` (> 1)
+
+        it "renderBuffer should skip unchanged items" do
+          let n = 200000
+              buf = Buffer.fromList (replicate n (mkItem "hello world"))
+              cache0 = emptyRenderCacheFor buf
+          (cache1, _) <- pure $! renderBuffer 10 buf cache0
+          shouldRunUnder (pure $! renderBuffer 10 buf cache1) 500000
+
+
+        it "updateRenderedItem should reject mismatched rendered buffer size" do
+          let buf = Buffer.fromList [Item "a" NoSegments]
+              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]
+              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]
+              (cache0, rb0) = renderBuffer 10 buf0 (emptyRenderCacheFor buf0)
+              buf1 = Buffer.fromList [Item "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"]
+              (cache0, rb0) = renderBuffer 10 buf0 (emptyRenderCacheFor buf0)
+              buf1 = Buffer.fromList [Item "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]
+              cache = emptyRenderCacheFor buf
+          evaluate (updateRenderedItem 10 (-1) buf cache (RenderedBuffer Seq.empty))
+            `shouldThrow` anyException
+
+
+      describe "RenderCache" do
+
+        it "emptyRenderCacheFor builds empty cache" do
+          let b = mkBuf ["a","b"]
+          RC.emptyRenderCacheFor b `shouldSatisfy` const True
+
+        it "resizeCache keeps size in sync with buffer" do
+          let b = mkBuf ["a","b","c"]
+              c0 = RC.emptyRenderCacheFor (mkBuf ["x"])
+              c1 = RC.resizeCache b c0
+          RC.length c1 `shouldBe` 3
+
+
+      describe "RenderItem" do
+
+        it "renderItem should invalidate cache when strategy changes" do
+          let old = CachedRender
+                      { crWidth    = 10
+                      , crStrategy = NoSegments
+                      , crText     = "hello world"
+                      , crRendered = RenderedItem mempty
+                      }
+              newItem = Item "hello world" FixedWidthSegments
+              new = renderItem 10 0 newItem (Just old)
+          crStrategy new `shouldBe` FixedWidthSegments
+
+        it "renderItem should not reuse cache from a different item index" do
+          let old = CachedRender
+                      { crWidth    = 10
+                      , crStrategy = NoSegments
+                      , crText     = "hello world"
+                      , crRendered = RenderedItem mempty
+                      }
+              itm = Item "hello world" NoSegments
+              new = renderItem 10 999 itm (Just old)
+          crRendered new `shouldNotBe` crRendered old
+
+        it "renderItem should reject non-positive width" do
+          let itm = Item "hello" NoSegments
+          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
+                      , crText     = "Schifffahrt"
+                      , crRendered = RenderedItem mempty
+                      }
+              itm = Item "Schifffahrt" (HyphenateSegments H.german_1996 mempty)
+              new = renderItem 5 0 itm (Just old)
+          crRendered new `shouldNotBe` crRendered old
+
+
+      describe "RenderState" do
+
+        it "mkRenderState renders all items" do
+          let rs = mkRS 10 ["hello","world"]
+          RS.rsLineCount rs `shouldSatisfy` (> 0)
+
+        it "modifyItemRS updates item and re-renders" do
+          let rs  = mkRS 10 ["a","b","c"]
+              rs' = RS.modifyItemRS 1 (\itm -> itm { itemText = "X" }) rs
+          RS.rsBuffer rs' `shouldBe`
+            Buffer.fromList [mkItem "a", mkItem "X", mkItem "c"]
+
+        it "insertItem inserts and re-renders" do
+          let rs  = mkRS 10 ["a","c"]
+              rs' = RS.insertItem 1 (mkItem "b") rs
+          RS.rsBuffer rs' `shouldBe`
+            Buffer.fromList [mkItem "a", mkItem "b", mkItem "c"]
+
+        it "deleteItem removes and re-renders" do
+          let rs  = mkRS 10 ["a","b","c"]
+              rs' = RS.deleteItem 1 rs
+          RS.rsBuffer rs' `shouldBe`
+            Buffer.fromList [mkItem "a", mkItem "c"]
+
+        it "appendItem appends and re-renders" do
+          let rs  = mkRS 10 ["a","b"]
+              rs' = RS.appendItem (mkItem "c") rs
+          RS.rsBuffer rs' `shouldBe`
+            Buffer.fromList [mkItem "a", mkItem "b", mkItem "c"]
+
+        it "clearBuffer empties buffer" do
+          let rs  = mkRS 10 ["a","b"]
+              rs' = RS.clearBuffer rs
+          RS.rsLineCount rs' `shouldBe` 0
+
+        it "updateRenderState should invalidate cache when width changes" do
+          let rs0 = mkRenderState 10 (Buffer.fromList [Item "hello world" NoSegments])
+              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 (Buffer.fromList [])))
+            `shouldThrow` anyException
+
+        it "insertItem should reject out-of-bounds index" do
+          let rs = mkRenderState 10 (Buffer.fromList [])
+              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])
+          evaluate (RS.deleteItem 5 rs) `shouldThrow` anyException
+
+        it "replaceItem should handle out-of-bounds index consistently" do
+          let rs = mkRenderState 10 (Buffer.fromList [])
+          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])
+              rs' = RS.clearBuffer rs
+          RS.rsWidth rs' `shouldBe` 0
+
+        it "appendItem should be O(1) amortized" do
+          let n  = 200000
+              buf = Buffer.fromList (replicate n (mkItem "x"))
+          shouldRunUnder (pure $! Buffer.appendItem (mkItem "y") buf) 1000000
+
+
+      describe "RenderedBuffer" do
+        pure ()
+
+
+      describe "RenderedItem" do
+
+        it "RenderedItem should reject lines from different item indices" do
+          let l1 = RenderedLine "abc" 0 0 0
+              l2 = RenderedLine "xyz" 99 0 0
+              ri = RenderedItem (V.fromList [l1, l2])
+          evaluate (riLines ri) `shouldThrow` anyException
+
+        it "RenderedItem should not accept lines with negative rlLineIx" do
+          let badLine = RenderedLine "oops" 0 (-1) 0
+              ri = RenderedItem (V.singleton badLine)
+          evaluate (riLines ri) `shouldThrow` anyException
+
+
+      describe "RenderedLine" do
+
+        it "RenderedLine should not allow negative indices" do
+          evaluate (RenderedLine "abc" (-1) 0 0) `shouldThrow` anyException
+
+        it "RenderedLine should not allow rlCharStart beyond text length" do
+          evaluate (RenderedLine "abc" 0 0 10) `shouldThrow` anyException
+
+        it "RenderedLine Show should produce a stable, parseable format" do
+          show (RenderedLine "abc" 1 2 3) `shouldBe` "RenderedLine(\"abc\",1,2,3)"
+
+        it "RenderedLine should not allow negative rlLineIx" do
+          evaluate (RenderedLine "abc" 0 (-3) 0) `shouldThrow` anyException
+
+
+      describe "Segmentation" do
+
+        it "chunkFixed splits long tokens" do
+          chunkFixed 4 "abcdefgh" `shouldBe`
+            ["abcd","efgh"]
+
+        it "scanOffsetsWithNewlines counts offsets correctly" do
+          scanOffsetsWithNewlines ["a","b","c"] `shouldBe` [0,2,4]
+
+        it "scanOffsetsFrom applies offset" do
+          scanOffsetsFrom 10 ["a","b","c"] `shouldBe` [10,11,12]
+
+        it "breakWordSafe wraps long words" do
+          breakWordSafe 5 ["abcdefgh"] `shouldBe`
+            ["abcde","fgh"]
+
+        it "hyphenateWord splits German words" do
+          let hy = H.german_1996
+          hyphenateWord hy "Schifffahrt" `shouldSatisfy` (not . null)
+
+        it "scoreCandidate is deterministic for identical candidates" do
+          let c = ("abcdefghijk", ["abcdefgh","ijk"], False)
+          scoreCandidate 8 c `shouldBe` scoreCandidate 8 c
+
+        it "applyStrategy NoSegments should not drop text beyond width" do
+          let v = applyStrategy NoSegments 4 0 "abcdefgh"
+          V.toList (V.map rlText v) `shouldBe` ["abcd","efgh"]
+
+        it "applyStrategy NoSegments should compute correct offsets for wrapped lines" do
+          let v = applyStrategy NoSegments 4 0 "abcdefgh"
+          map rlCharStart (V.toList v) `shouldBe` [0,4]
+
+        it "chunkFixed should return [] for empty text" do
+          chunkFixed 5 "" `shouldBe` []
+
+        it "scanOffsetsFrom should include newline spacing like scanOffsetsWithNewlines" do
+          scanOffsetsFrom 0 ["abc","def"] `shouldBe` [0,4]
+
+        it "HyphenateSegments should return updated cache" do
+          let dict = H.german_1996
+              cache0 = HM.empty
+              _v = applyStrategy (HyphenateSegments dict cache0) 5 0 "Schifffahrt"
+          cache0 `shouldNotBe` (HM.empty :: HM.HashMap Text [(Text, Text)])
+
+        it "lineCandidates should preserve candidate order" do
+          let dict = H.german_1996
+              (cs, _) = lineCandidates dict 10 HM.empty ["a","b","c"]
+          map (\(t,_,_) -> t) cs `shouldBe` ["a","a b","a b c"]
+
+        it "breakWordSafe should not split grapheme clusters" do
+          let family = "👨\8205👩\8205👧\8205👦"
+          breakWordSafe 1 [family] `shouldBe` [family]
+
+        it "scoreCandidate should not always penalize short lines" do
+          scoreCandidate 10 ("a",[],False) < scoreCandidate 10 ("a-",[],True)
+            `shouldBe` True
+
+
+    describe "Viewport" do
+
+      describe "Instance" do
+
+        it "mkViewportInstance builds consistent state" do
+          let vi = mkViewportInstance 10 3 (mkBuf ["a","b","c"])
+          length (visibleLines vi) `shouldBe` 3
+
+        it "scrollUpI clamps correctly" do
+          let vi  = mkViewportInstance 10 3 (mkBuf ["a","b","c","d","e"])
+              vi' = scrollUpI 10 vi
+          vpOffset (viView vi') `shouldBe` 0
+
+        it "scrollDownI clamps correctly" do
+          let vi  = mkViewportInstance 10 3 (mkBuf ["a","b","c","d","e"])
+              vi' = scrollDownI 10 vi
+              rs  = viRender vi
+          vpOffset (viView vi') `shouldBe` (RS.rsLineCount rs - 3)
+
+        it "modifyItemI updates both buffer and renderstate" do
+          let vi  = mkViewportInstance 10 3 (mkBuf ["a","b","c"])
+              vi' = modifyItemI 1 (\itm -> itm { itemText = "X" }) vi
+          RS.rsBuffer (viRender vi') `shouldBe`
+            Buffer.fromList [mkItem "a", mkItem "X", mkItem "c"]
+
+        it "lookupPositionI returns correct coordinates" do
+          let vi = mkViewportInstance 10 3 (mkBuf ["hello","world"])
+          lookupPositionI 1 0 vi `shouldBe` Just (0,1)
+
+        it "visibleLines should clamp offset to available lines" do
+          let vi = mkViewportInstance 10 3 (Buffer.fromList [mkItem "a"])
+              vi' = vi { viView = (viView vi) { vpOffset = 999 } }
+          visibleLines vi' `shouldNotBe` []
+
+        it "applyToInstance should clamp using updated render state" do
+          let vi0 = mkViewportInstance 10 3 (Buffer.fromList [mkItem "hello"])
+              vi1 = applyToInstance (VP.scrollDown 1) vi0
+              vi2 = modifyItemI 0 (\_ -> mkItem "hello\nworld\nagain") vi1
+          vpOffset (viView vi2) `shouldBe` (RS.rsLineCount (viRender vi1) - 3)
+
+        it "lookupPositionI should interpret y relative to viewport offset" do
+          let vi = mkViewportInstance 10 3 (Buffer.fromList [mkItem "hello", mkItem "world", mkItem "again"])
+              vi' = scrollDownI 1 vi
+          lookupPositionI 0 0 vi' `shouldBe` Just (0,1)
+
+
+      describe "Position" do
+
+        it "lookupPosition should reject x beyond line length" do
+          let rl = RenderedLine "abc" 0 0 0
+              rb = RB.fromList [RenderedItem (V.singleton rl)]
+              vp = Viewport 10 1 0
+          lookupPosition 99 0 vp rb `shouldBe` Nothing
+
+        it "lookupPosition should reject negative coordinates" do
+          let rl = RenderedLine "abc" 0 0 0
+              rb = RB.fromList [RenderedItem (V.singleton rl)]
+              vp = Viewport 10 1 0
+          lookupPosition (-1) (-1) vp rb `shouldBe` Nothing
+
+
+      describe "Viewport" do
+
+        it "mkViewport should reject non-positive width/height" do
+          let rs = mkRenderState 10 (Buffer.fromList [])
+          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"])
+              vp = Viewport 10 5 0
+          vpOffset (VP.alignBottom rs vp) `shouldBe` 3
+
+        it "scrollBy should not allow negative offsets" do
+          let vp = Viewport 10 3 0
+          vpOffset (VP.scrollBy (-5) vp) `shouldBe` 0
+
+        it "pageUp should not scroll above top" do
+          let vp = Viewport 10 3 0
+          vpOffset (VP.pageUp vp) `shouldBe` 0
+
+        it "clampViewport should reject non-positive viewport height" do
+          let rs = mkRenderState 10 (Buffer.fromList [mkItem "a"])
+              vp = Viewport 10 0 0
+          evaluate (clampViewport rs vp) `shouldThrow` anyException
+
+        it "mkViewport starts at bottom" do
+          let rs = mkRS 10 ["a","b","c","d","e"]
+              vp = VP.mkViewport 10 2 rs
+          vpOffset vp `shouldBe` (RS.rsLineCount rs - 2)
+
+        it "scrollUp decreases offset" do
+          let rs = mkRS 10 ["a","b","c","d"]
+              vp = VP.mkViewport 10 2 rs
+              vp' = VP.scrollUp 1 vp
+          vpOffset vp' `shouldBe` (vpOffset vp - 1)
+
+        it "scrollDown increases offset" do
+          let rs = mkRS 10 ["a","b","c","d"]
+              vp = VP.mkViewport 10 2 rs
+              vp' = VP.scrollDown 1 vp
+          vpOffset vp' `shouldBe` (vpOffset vp + 1)
+
+        it "alignTop sets offset 0" do
+          vpOffset (VP.alignTop (Viewport 10 3 99)) `shouldBe` 0