diff options
Diffstat (limited to 'TextViewport.hs')
| -rw-r--r-- | TextViewport.hs | 136 |
1 files changed, 62 insertions, 74 deletions
diff --git a/TextViewport.hs b/TextViewport.hs index e5322c9..13c9762 100644 --- a/TextViewport.hs +++ b/TextViewport.hs @@ -4,9 +4,13 @@ module TextViewport ( Item(..) , Buffer(..) , WrapMode(..) - , Viewport(..) , RenderedLine(..) + , RenderedBuffer , renderBuffer + , flatten + , modifyItem + , updateRenderedItem + , Viewport(..) , defaultViewport , scrollUp , scrollDown @@ -24,81 +28,76 @@ import qualified Data.Text as T newtype Item = Item { unItem :: Text } newtype Buffer = Buffer { unBuffer :: [Item] } +modifyItem :: Int -> (Item -> Item) -> Buffer -> Buffer +modifyItem ix f (Buffer xs) = + Buffer (take ix xs ++ [f (xs !! ix)] ++ drop (ix+1) xs) + -------------------------------------------------------------------------------- --- Rendering +-- Rendering with provenance -------------------------------------------------------------------------------- --- | Rendering mode: either truncate long lines or wrap them. -data WrapMode - = NoWrap -- ^ Hard truncation at viewport width. - | Wrap -- ^ Soft line breaks inserted at viewport width. +data WrapMode = NoWrap | Wrap deriving (Eq, Show) -- | A physical line with provenance. data RenderedLine = RenderedLine { rlText :: !Text - , rlItemIx :: !Int -- ^ index of the item in the Buffer - , rlLineIx :: !Int -- ^ index of the logical line within the item - , rlCharStart :: !Int -- ^ starting character offset within the logical line + , rlItemIx :: !Int + , rlLineIx :: !Int + , rlCharStart :: !Int } deriving (Eq, Show) --- | Render the buffer into a flat list of physical lines. --- Wrapping expands logical lines; truncation keeps one line per logical line. -renderBuffer :: WrapMode -> Int -> Buffer -> [RenderedLine] +-- | RenderedBuffer keeps per-item blocks so we can update only one item. +type RenderedBuffer = [[RenderedLine]] + +flatten :: RenderedBuffer -> [RenderedLine] +flatten = concat + +renderBuffer :: WrapMode -> Int -> Buffer -> RenderedBuffer renderBuffer mode w (Buffer items) = - concat $ zipWith renderItem [0..] items + zipWith (renderItem mode w) [0..] items + +renderItem :: WrapMode -> Int -> Int -> Item -> [RenderedLine] +renderItem mode w itemIx (Item t) = + concat $ zipWith (renderLogicalLine mode w itemIx) [0..] (T.splitOn "\n" t) + +renderLogicalLine :: WrapMode -> Int -> Int -> Int -> Text -> [RenderedLine] +renderLogicalLine mode w itemIx lineIx txt = + case mode of + NoWrap -> + [ RenderedLine (T.take w txt) itemIx lineIx 0 ] + Wrap -> + let chunks = chunk w txt + in zipWith mkChunk [0, w ..] chunks where - renderItem :: Int -> Item -> [RenderedLine] - renderItem itemIx (Item t) = - concat $ zipWith (renderLogicalLine itemIx) [0..] (T.splitOn "\n" t) - - renderLogicalLine :: Int -> Int -> Text -> [RenderedLine] - renderLogicalLine itemIx lineIx txt = - case mode of - NoWrap -> - [ RenderedLine - { rlText = T.take w txt - , rlItemIx = itemIx - , rlLineIx = lineIx - , rlCharStart = 0 - } - ] - - Wrap -> - let chunks = chunk w txt - in zipWith mkChunk [0, w ..] chunks - where - mkChunk off chunkTxt = - RenderedLine - { rlText = chunkTxt - , rlItemIx = itemIx - , rlLineIx = lineIx - , rlCharStart = off - } - - chunk :: Int -> Text -> [Text] - chunk width s - | T.null s = [""] - | otherwise = go s - where - go t - | T.null t = [] - | otherwise = - let (c, r) = T.splitAt width t - in c : go r - --- | Split a line into chunks of at most width characters. --- This is soft wrapping: no hyphenation, no word-boundary logic. -wrapText :: Int -> Text -> [Text] -wrapText w t + mkChunk off chunkTxt = + RenderedLine chunkTxt itemIx lineIx off + +chunk :: Int -> Text -> [Text] +chunk w t | T.null t = [""] | otherwise = go t where go s | T.null s = [] | otherwise = - let (chunk, rest) = T.splitAt w s - in chunk : go rest + let (c, r) = T.splitAt w s + in c : go r + +-------------------------------------------------------------------------------- +-- Incremental re-rendering +-------------------------------------------------------------------------------- + +updateRenderedItem + :: WrapMode + -> Int + -> Int + -> Buffer + -> RenderedBuffer + -> RenderedBuffer +updateRenderedItem mode w itemIx (Buffer items) rb = + let newBlock = renderItem mode w itemIx (items !! itemIx) + in take itemIx rb ++ [newBlock] ++ drop (itemIx+1) rb -------------------------------------------------------------------------------- -- Viewport @@ -131,32 +130,21 @@ visibleLines :: [RenderedLine] -> Viewport -> [RenderedLine] visibleLines rendered vp = take (vpHeight vp) . drop (vpOffset vp) $ rendered - -------------------------------------------------------------------------------- --- Lookup +-- Coordinate lookup -------------------------------------------------------------------------------- --- | Given viewport coordinates (x,y), return: --- (item index, character offset within that item), if visible. lookupPosition - :: Int -- ^ x coordinate in viewport - -> Int -- ^ y coordinate in viewport + :: Int -- ^ x coordinate + -> Int -- ^ y coordinate -> Viewport -> [RenderedLine] - -> Maybe (Int, Int) -- ^ (itemIx, charOffsetInItem) + -> Maybe (Int, Int) -- ^ (itemIx, charOffsetInLogicalLine) lookupPosition x y vp rendered = do let lineIx = vpOffset vp + y rl <- renderedAt lineIx rendered - let charInLogical = rlCharStart rl + x - pure (rlItemIx rl, charInLogical) + pure (rlItemIx rl, rlCharStart rl + x) where renderedAt ix rs | ix < 0 || ix >= length rs = Nothing | otherwise = Just (rs !! ix) - --- | Convert (lineIx, charOffset) into a single absolute offset inside the item. -absoluteCharOffset :: Item -> Int -> Int -> Int -absoluteCharOffset (Item t) lineIx charOff = - let ls = T.splitOn "\n" t - prefix = sum (map T.length (take lineIx ls)) + lineIx -- +lineIx for '\n' - in prefix + charOff |