module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic
, OutputBuffer
)
where
import Data.Marshalling
import Graphics.Vty.Picture
import Graphics.Vty.Span
import Graphics.Vty.DisplayRegion
import Graphics.Vty.DisplayAttributes
import Control.Monad ( liftM )
import Control.Monad.Trans
import Data.Array
import qualified Data.ByteString.Internal as BSCore
import Data.Foldable
import Data.IORef
import Data.String.UTF8 hiding ( foldl )
import System.IO
data TerminalHandle where
TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle
state_ref :: TerminalHandle -> IORef TerminalState
state_ref (TerminalHandle _ s_ref) = s_ref
new_terminal_handle :: forall m t. ( MonadIO m, Terminal t ) => t -> m TerminalHandle
new_terminal_handle t = do
s_ref <- liftIO $ newIORef initial_terminal_state
return $ TerminalHandle t s_ref
data TerminalState = TerminalState
{
known_fattr :: Maybe FixedAttr
}
initial_terminal_state :: TerminalState
initial_terminal_state = TerminalState Nothing
class Terminal t where
terminal_ID :: t -> String
release_terminal :: MonadIO m => t -> m ()
reserve_display :: MonadIO m => t -> m ()
release_display :: MonadIO m => t -> m ()
display_bounds :: MonadIO m => t -> m DisplayRegion
display_terminal_instance :: MonadIO m
=> t
-> DisplayRegion
-> (forall d. DisplayTerminal d => d -> DisplayHandle)
-> m DisplayHandle
output_byte_buffer :: t -> OutputBuffer -> Word -> IO ()
output_handle :: t -> IO Handle
instance Terminal TerminalHandle where
terminal_ID (TerminalHandle t _) = terminal_ID t
release_terminal (TerminalHandle t _) = release_terminal t
reserve_display (TerminalHandle t _) = reserve_display t
release_display (TerminalHandle t _) = release_display t
display_bounds (TerminalHandle t _) = display_bounds t
display_terminal_instance (TerminalHandle t _) = display_terminal_instance t
output_byte_buffer (TerminalHandle t _) = output_byte_buffer t
output_handle (TerminalHandle t _) = output_handle t
data DisplayHandle where
DisplayHandle :: DisplayTerminal d => d -> TerminalHandle -> DisplayState -> DisplayHandle
display_context :: MonadIO m => TerminalHandle -> DisplayRegion -> m DisplayHandle
display_context t b = do
s <- initial_display_state
let c d = DisplayHandle d t s
display_terminal_instance t b c
data DisplayState = DisplayState
{ previous_output_ref :: IORef (Maybe SpanOpSequence)
}
initial_display_state :: MonadIO m => m DisplayState
initial_display_state = liftM DisplayState $ liftIO $ newIORef Nothing
class DisplayTerminal d where
context_region :: d -> DisplayRegion
context_color_count :: d -> Word
move_cursor_required_bytes :: d -> Word -> Word -> Word
serialize_move_cursor :: MonadIO m => d -> Word -> Word -> OutputBuffer -> m OutputBuffer
show_cursor_required_bytes :: d -> Word
serialize_show_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
hide_cursor_required_bytes :: d -> Word
serialize_hide_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
attr_required_bytes :: d -> FixedAttr -> Attr -> DisplayAttrDiff -> Word
serialize_set_attr :: MonadIO m => d -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> m OutputBuffer
default_attr_required_bytes :: d -> Word
serialize_default_attr :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
inline_hack :: MonadIO m => d -> m ()
inline_hack _d = return ()
instance DisplayTerminal DisplayHandle where
context_region (DisplayHandle d _ _) = context_region d
context_color_count (DisplayHandle d _ _) = context_color_count d
move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d
serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d
show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d
serialize_show_cursor (DisplayHandle d _ _) = serialize_show_cursor d
hide_cursor_required_bytes (DisplayHandle d _ _) = hide_cursor_required_bytes d
serialize_hide_cursor (DisplayHandle d _ _) = serialize_hide_cursor d
attr_required_bytes (DisplayHandle d _ _) = attr_required_bytes d
serialize_set_attr (DisplayHandle d _ _) = serialize_set_attr d
default_attr_required_bytes (DisplayHandle d _ _) = default_attr_required_bytes d
serialize_default_attr (DisplayHandle d _ _) = serialize_default_attr d
inline_hack (DisplayHandle d _ _) = inline_hack d
utf8_text_required_bytes :: UTF8 BSCore.ByteString -> Word
utf8_text_required_bytes str =
let (_, _, src_bytes_length) = BSCore.toForeignPtr (toRep str)
in toEnum src_bytes_length
serialize_utf8_text :: MonadIO m => UTF8 BSCore.ByteString -> OutputBuffer -> m OutputBuffer
serialize_utf8_text str dest_ptr =
let (src_fptr, src_ptr_offset, src_bytes_length) = BSCore.toForeignPtr (toRep str)
in liftIO $ withForeignPtr src_fptr $ \src_ptr -> do
let src_ptr' = src_ptr `plusPtr` src_ptr_offset
BSCore.memcpy dest_ptr src_ptr' (toEnum src_bytes_length)
return (dest_ptr `plusPtr` src_bytes_length)
output_picture :: MonadIO m => DisplayHandle -> Picture -> m ()
output_picture (DisplayHandle d t s) pic = do
let !r = context_region d
let !ops = spans_for_pic pic r
let !initial_attr = FixedAttr default_style_mask Nothing Nothing
diffs :: [Bool]
<- liftIO ( readIORef (previous_output_ref s) )
>>= \mprevious_ops -> case mprevious_ops of
Nothing
-> return $ replicate ( fromEnum $ region_height $ effected_region ops )
True
Just previous_ops
-> if effected_region previous_ops /= effected_region ops
then return $ replicate ( fromEnum $ region_height $ effected_region ops )
True
else return $ zipWith (/=) ( elems $ row_ops previous_ops )
( elems $ row_ops ops )
let total = hide_cursor_required_bytes d
+ default_attr_required_bytes d
+ required_bytes d initial_attr diffs ops
+ case pic_cursor pic of
NoCursor -> 0
Cursor x y -> let m = cursor_output_map ops $ pic_cursor pic
( ox, oy ) = char_to_output_pos m ( x, y )
in show_cursor_required_bytes d
+ move_cursor_required_bytes d ox oy
liftIO $ allocaBytes (fromEnum total) $ \start_ptr -> do
ptr <- serialize_hide_cursor d start_ptr
ptr' <- serialize_default_attr d ptr
ptr'' <- serialize_output_ops d ptr' initial_attr diffs ops
end_ptr <- case pic_cursor pic of
NoCursor -> return ptr''
Cursor x y -> do
let m = cursor_output_map ops $ pic_cursor pic
(ox, oy) = char_to_output_pos m (x,y)
serialize_show_cursor d ptr'' >>= serialize_move_cursor d ox oy
case end_ptr `minusPtr` start_ptr of
count | count < 0 -> fail "End pointer before start of buffer."
| toEnum count > total -> fail $ "End pointer past end of buffer by " ++ show (toEnum count total)
| otherwise -> output_byte_buffer t start_ptr (toEnum count)
liftIO $ writeIORef (previous_output_ref s) (Just ops)
return ()
required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> SpanOpSequence -> Word
required_bytes d in_fattr diffs ops =
let (_, n, _, _) = foldl' required_bytes' (0, 0, in_fattr, diffs) ( row_ops ops )
in n
where
required_bytes' (y, current_sum, fattr, True : diffs') span_ops
= let (s, fattr') = span_ops_required_bytes d y fattr span_ops
in ( y + 1, s + current_sum, fattr', diffs' )
required_bytes' (y, current_sum, fattr, False : diffs') _span_ops
= ( y + 1, current_sum, fattr, diffs' )
required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops
= error "shouldn't be possible"
span_ops_required_bytes :: DisplayTerminal d => d -> Word -> FixedAttr -> SpanOps -> (Word, FixedAttr)
span_ops_required_bytes d y in_fattr span_ops =
let header_required_bytes = move_cursor_required_bytes d 0 y
in foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op
in (c + current_sum, fattr')
)
(header_required_bytes, in_fattr)
span_ops
span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr)
span_op_required_bytes d fattr (AttributeChange attr) =
let attr' = limit_attr_for_display d attr
diffs = display_attr_diffs fattr fattr'
c = attr_required_bytes d fattr attr' diffs
fattr' = fix_display_attr fattr attr'
in (c, fattr')
span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)
serialize_output_ops :: ( MonadIO m, DisplayTerminal d )
=> d
-> OutputBuffer
-> FixedAttr
-> [Bool]
-> SpanOpSequence
-> m OutputBuffer
serialize_output_ops d start_ptr in_fattr diffs ops = do
(_, end_ptr, _, _) <- foldlM serialize_output_ops'
( 0, start_ptr, in_fattr, diffs )
( row_ops ops )
return end_ptr
where
serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops
= serialize_span_ops d y out_ptr fattr span_ops
>>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) )
serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops
= return ( y + 1, out_ptr, fattr, diffs' )
serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops
= error "shouldn't be possible"
serialize_span_ops :: ( MonadIO m, DisplayTerminal d )
=> d
-> Word
-> OutputBuffer
-> FixedAttr
-> SpanOps
-> m (OutputBuffer, FixedAttr)
serialize_span_ops d y out_ptr in_fattr span_ops = do
out_ptr' <- serialize_move_cursor d 0 y out_ptr
foldlM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr )
(out_ptr', in_fattr)
span_ops
serialize_span_op :: ( MonadIO m, DisplayTerminal d )
=> d
-> SpanOp
-> OutputBuffer
-> FixedAttr
-> m (OutputBuffer, FixedAttr)
serialize_span_op d (AttributeChange attr) out_ptr fattr = do
let attr' = limit_attr_for_display d attr
fattr' = fix_display_attr fattr attr'
diffs = display_attr_diffs fattr fattr'
out_ptr' <- serialize_set_attr d fattr attr' diffs out_ptr
return (out_ptr', fattr')
serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do
out_ptr' <- serialize_utf8_text str out_ptr
return (out_ptr', fattr)
marshall_to_terminal :: ( Terminal t )
=> t -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()
marshall_to_terminal t c f = do
start_ptr <- mallocBytes (fromEnum c)
end_ptr <- f start_ptr
case end_ptr `minusPtr` start_ptr of
count | count < 0 -> fail "End pointer before start pointer."
| toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count c)
| otherwise -> output_byte_buffer t start_ptr (toEnum count)
free start_ptr
return ()
data CursorOutputMap = CursorOutputMap
{ char_to_output_pos :: (Word, Word) -> (Word, Word)
}
cursor_output_map :: SpanOpSequence -> Cursor -> CursorOutputMap
cursor_output_map span_ops _cursor = CursorOutputMap
{ char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)
}
cursor_column_offset :: SpanOpSequence -> Word -> Word -> Word
cursor_column_offset span_ops cx cy =
let cursor_row_ops = row_ops span_ops ! cy
(out_offset, _, _)
= foldl' ( \(d, current_cx, done) op ->
if done then (d, current_cx, done) else case span_op_has_width op of
Nothing -> (d, current_cx, False)
Just (cw, ow) -> case compare cx (current_cx + cw) of
GT -> ( d + ow
, current_cx + cw
, False
)
EQ -> ( d + ow
, current_cx + cw
, True
)
LT -> ( d + columns_to_char_offset (cx current_cx) op
, current_cx + cw
, True
)
)
(0, 0, False)
cursor_row_ops
in out_offset
limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr
limit_attr_for_display d attr
= attr { attr_fore_color = clamp_color $ attr_fore_color attr
, attr_back_color = clamp_color $ attr_back_color attr
}
where
clamp_color Default = Default
clamp_color KeepCurrent = KeepCurrent
clamp_color (SetTo c) = clamp_color' c
clamp_color' (ISOColor v)
| context_color_count d < 8 = Default
| context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v 8)
| otherwise = SetTo $ ISOColor v
clamp_color' (Color240 v)
| context_color_count d < 8 = Default
| context_color_count d < 16 = Default
| context_color_count d == 240 = SetTo $ Color240 v
| otherwise
= let p :: Double = fromIntegral v / 240.0
v' = floor $ p * (fromIntegral $ context_color_count d)
in SetTo $ Color240 v'