externalize segmentation rendererHEADmaster

10 files changed, 80 insertions, 68 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)