path: root/test/Spec.hs

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