TextClip.hs

-- |This module provides \"text clipping\" routines.  These routines
-- are responsible for ensuring that logical characters are clipped
-- properly when being laid out in a given physical region.  This is a
-- bit tricky because some Unicode characters use two terminal columns
-- and others (most) use one.  We have to take this into account when
-- truncating text to fit into rendering regions, so we concentrate
-- that logic here under the name of a \"clipping rectangle\" and
-- functions to apply it.
--
-- Clipping functionality is provided in two forms: one- and
-- two-dimensional clipping.  The former is useful for clipping a
-- single line of text at a given offset and up to a given width.  The
-- latter is useful for clipping a list of lines with respect to a 2-D
-- clipping rectangle.
module Graphics.Vty.Widgets.TextClip
    ( ClipRect(..)
    , clip1d
    , clip2d
    , updateRect
    )
where

import Control.Applicative
import Data.Maybe
import qualified Data.Text as T
import Graphics.Vty.Widgets.Util
    ( Phys(..)
    , chWidth
    )

-- |The type of clipping rectangles for 2-D clipping operations.  All
-- values are 'Phys' values to indicate that we are dealing explicitly
-- with physical column measurements rather than logical character
-- positions.
data ClipRect =
    ClipRect { clipLeft :: Phys
             -- ^The left margin of the clipping rectangle.
             , clipTop :: Phys
             -- ^The top row of the clipping rectangle.
             , clipWidth :: Phys
             -- ^The width, in columns, of the clipping rectangle.
             , clipHeight :: Phys
             -- ^The height, in rows, of the clipping rectangle.
             }
    deriving (Eq, Show)

-- |One-dimensional text clipping.  Takes the left clipping margin, a
-- clipping width, and a text string.  For example, @clip1d n w s@
-- clips the string @s@ so that the result includes characters in @s@
-- starting at position @n@ and including characters using no more
-- than @w@ columns in width.  Returns the clipped text plus 'Bool's
-- indicating whether wide characters were \"sliced\" on either side
-- (left and right, respectively) of the clipping region.  This
-- function guarantees that the text returned will always fit within
-- the specified clipping region.  Since wide characters may be sliced
-- during clipping, this may return a text string smaller than the
-- clipping region.
clip1d :: Phys -> Phys -> T.Text -> (T.Text, Bool, Bool)
clip1d _ 0 _ = (T.empty, False, False)
clip1d start len t = (T.pack result2, lSlice, rSlice)

    where
      pairs = [ (c, chWidth c) | c <- T.unpack t ]

      exploded = concat $ mkExp <$> pairs
      mkExp (a, i) = Just a : replicate (fromEnum i - 1) Nothing

      -- First clip up to the starting position.
      clip1 = drop (fromEnum start) exploded
      -- Then clip according to the width.
      clip2 = take (fromEnum len) clip1
      -- Rest is whatever was left after clipping to the width.
      rest = drop (fromEnum len) clip1

      rSlice = length rest > 0 && head rest == Nothing
      lSlice = length clip1 > 0 && head clip1 == Nothing

      result1 = catMaybes clip2
      result2 = if rSlice
                then init result1
                else result1

-- |Two-dimensional text clipping.  Returns clipping data for each
-- line as returned by 'clip1d', with the added behavior that it
-- returns at most 'clipHeight' lines of text and uses 'clipTop' as
-- the offset when clipping rows.
clip2d :: ClipRect -> [T.Text] -> [(T.Text, Bool, Bool)]
clip2d rect ls = clip1d left len <$> visibleLines
        where
          visibleLines = take (fromEnum height) $ drop (fromEnum top) ls
          left = clipLeft rect
          top = clipTop rect
          len = clipWidth rect
          height = clipHeight rect

-- |Given a physical point and a clipping rectangle, adjust the
-- clipping rectangle so that the point falls just inside the
-- rectangle.  If the point is already within the rectangle, return
-- the rectangle unmodified.  NB: this assumes that the physical
-- position given has passed whatever validation checks are relevant
-- for the user of the 'ClipRect'.  This function just performs a
-- rectangle transformation.
updateRect :: (Phys, Phys) -> ClipRect -> ClipRect
updateRect (row, col) oldRect = adjustLeft $ adjustTop oldRect
    where
      adjustLeft old
          | col < clipLeft oldRect = old { clipLeft = col }
          | col >= clipLeft oldRect + clipWidth oldRect =
              old { clipLeft = col - clipWidth old + 1 }
          | otherwise = old

      adjustTop old
          | row < clipTop oldRect = old { clipTop = row }
          | row >= clipTop oldRect + clipHeight oldRect =
              old { clipTop = row - clipHeight old + 1 }
          | otherwise = old