module Graphics.Vty.Span
where
import Codec.Binary.UTF8.Width ( wcwidth )
import Graphics.Vty.Image
import Graphics.Vty.Picture
import Graphics.Vty.DisplayRegion
import Codec.Binary.UTF8.String ( encode )
import Control.Monad ( forM_ )
import Control.Monad.ST.Strict
import Data.Array.ST
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BInt
import qualified Data.Foldable as Foldable
import Data.Word
import qualified Data.ByteString.UTF8 as BSUTF8
import qualified Data.String.UTF8 as UTF8
import Foreign.Storable ( pokeByteOff )
import GHC.Arr
data SpanOpSequence = SpanOpSequence
{ effected_region :: DisplayRegion
, row_ops :: RowOps
}
type RowOps = Array Word SpanOps
type SpanOps = [SpanOp]
span_ops_columns :: SpanOpSequence -> Word
span_ops_columns ops = region_width $ effected_region ops
span_ops_rows :: SpanOpSequence -> Word
span_ops_rows ops = region_height $ effected_region ops
span_ops_effected_columns :: [SpanOp] -> Word
span_ops_effected_columns in_ops = span_ops_effected_columns' 0 in_ops
where
span_ops_effected_columns' t [] = t
span_ops_effected_columns' t (TextSpan w _ _ : r) = span_ops_effected_columns' (t + w) r
span_ops_effected_columns' t (_ : r) = span_ops_effected_columns' t r
data SpanOp =
AttributeChange !Attr
| TextSpan !Word !Word (UTF8.UTF8 B.ByteString)
deriving Eq
span_op_has_width :: SpanOp -> Maybe (Word, Word)
span_op_has_width (TextSpan ow cw _) = Just (cw, ow)
span_op_has_width _ = Nothing
columns_to_char_offset :: Word -> SpanOp -> Word
columns_to_char_offset cx (TextSpan _ _ utf8_str) =
let str = UTF8.toString utf8_str
in toEnum $ sum $ map wcwidth $ take (fromEnum cx) str
columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"
spans_for_pic :: Picture -> DisplayRegion -> SpanOpSequence
spans_for_pic pic r = SpanOpSequence r $ runSTArray (build_spans pic r)
build_spans :: Picture -> DisplayRegion -> ST s (STArray s Word [SpanOp])
build_spans pic region = do
mrow_ops <- newSTArray (0, region_height region 1) []
if region_height region > 0
then do
ops_for_row mrow_ops (pic_background pic) region (pic_image pic) 0 (region_width region)
forM_ [0 .. region_height region 1] $ \row -> do
end_x <- readSTArray mrow_ops row >>= return . span_ops_effected_columns
if end_x < region_width region
then snoc_bg_fill mrow_ops (pic_background pic) (region_width region end_x) row
else return ()
else return ()
return mrow_ops
type MRowOps s = STArray s Word SpanOps
ops_for_row :: MRowOps s -> Background -> DisplayRegion -> Image -> Word -> Word -> ST s ()
ops_for_row mrow_ops bg region image y remaining_columns
| remaining_columns == 0 = return ()
| y >= region_height region = return ()
| otherwise = case image of
EmptyImage -> return ()
HorizText a text_str ow cw -> do
snoc_text_span a text_str ow cw mrow_ops y remaining_columns
VertJoin t b _ _ -> do
ops_for_row mrow_ops bg region t y remaining_columns
ops_for_row mrow_ops bg region b (y + image_height t) remaining_columns
HorizJoin l r _ _ -> do
ops_for_row mrow_ops bg region l y remaining_columns
if image_width l < remaining_columns
then ops_for_row mrow_ops bg region r y (remaining_columns image_width l)
else return ()
BGFill width height -> do
let actual_height = if y + height > region_height region
then region_height region y
else height
actual_width = if width > remaining_columns
then remaining_columns
else width
forM_ [y .. y + actual_height 1] $ \y' -> snoc_bg_fill mrow_ops bg actual_width y'
Translation _offset i -> ops_for_row mrow_ops bg region i y remaining_columns
snoc_text_span :: (Foldable.Foldable t)
=> Attr
-> t Char
-> Word
-> Word
-> MRowOps s
-> Word
-> Word
-> ST s ()
snoc_text_span a text_str ow cw mrow_ops y remaining_columns = do
if ow > remaining_columns
then do
snoc_op mrow_ops y $ AttributeChange a
let (ow', cw', txt) = Foldable.foldl'
build_cropped_txt
( 0, 0, B.empty )
text_str
snoc_op mrow_ops y $ TextSpan ow' cw' (UTF8.fromRep txt)
else do
snoc_op mrow_ops y $ AttributeChange a
let utf8_bs = ( BSUTF8.fromString) $ Foldable.foldMap (\c -> [c]) text_str
snoc_op mrow_ops y $ TextSpan ow cw (UTF8.fromRep utf8_bs)
where
build_cropped_txt (ow', char_count', b0) c =
let w = wcwidth c
w' = toEnum $ if w < 0 then 1 else w
in if (w' + ow') > remaining_columns
then ( ow', char_count', b0 )
else ( ow' + w', char_count' + 1, B.append b0 $ B.pack $ encode [c] )
snoc_bg_fill :: MRowOps s -> Background -> Word -> Word -> ST s ()
snoc_bg_fill _row_ops _bg 0 _row
= return ()
snoc_bg_fill mrow_ops (Background c back_attr) fill_length row
= do
snoc_op mrow_ops row $ AttributeChange back_attr
utf8_bs <- if c <= (toEnum 255 :: Char)
then
let !(c_byte :: Word8) = BInt.c2w c
in unsafeIOToST $ do
BInt.create ( fromEnum fill_length )
$ \ptr -> mapM_ (\i -> pokeByteOff ptr i c_byte)
[0 .. fromEnum (fill_length 1)]
else
let !(c_bytes :: [Word8]) = encode [c]
in unsafeIOToST $ do
BInt.create (fromEnum fill_length * length c_bytes)
$ \ptr -> mapM_ (\(i,b) -> pokeByteOff ptr i b)
$ zip [0 .. fromEnum (fill_length 1)] (cycle c_bytes)
snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)
snoc_op :: MRowOps s -> Word -> SpanOp -> ST s ()
snoc_op !mrow_ops !row !op = do
ops <- readSTArray mrow_ops row
let ops' = ops ++ [op]
writeSTArray mrow_ops row ops'
return ()