1-- Copyright 2009-2011 Corey O'Connor
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ExistentialQuantification #-}
7{-# LANGUAGE FlexibleContexts #-}
8module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic
13import Data.Marshalling
15import Graphics.Vty.Picture
16import Graphics.Vty.Span
17import Graphics.Vty.DisplayRegion
19import Graphics.Vty.DisplayAttributes
21import Control.Monad ( liftM )
22import Control.Monad.Trans
24import qualified Data.ByteString.Internal as BS
26import qualified Data.Vector as Vector
30-- | An handle to a terminal that hides the implementation.
31data TerminalHandle where
32 TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle
34state_ref :: TerminalHandle -> IORef TerminalState
35state_ref (TerminalHandle _ s_ref) = s_ref
37new_terminal_handle :: forall m t. ( MonadIO m, Terminal t ) => t -> m TerminalHandle
38new_terminal_handle t = do
39 s_ref <- liftIO $ newIORef initial_terminal_state
40 return $ TerminalHandle t s_ref
42-- | The current terminal state. This may not exactly be known.
43data TerminalState = TerminalState
44 { known_fattr :: Maybe FixedAttr
47-- | Initially we know nothing about a terminal's state.
48initial_terminal_state :: TerminalState
49initial_terminal_state = TerminalState Nothing
52 -- | Text identifier for the terminal. Used for debugging.
53 terminal_ID :: t -> String
55 release_terminal :: MonadIO m => t -> m ()
56 -- | Clear the display and initialize the terminal to some initial display state.
58 -- The expectation of a program is that the display starts in some initial state.
59 -- The initial state would consist of fixed values:
60 -- - cursor at top left
61 -- - UTF-8 character encoding
62 -- - drawing characteristics are the default
63 -- The abstract operation I think all these behaviors are instances of is reserving exclusive
64 -- access to a display such that:
65 -- - The previous state cannot be determined
66 -- - When exclusive access to a display is release the display returns to the previous state.
67 reserve_display :: MonadIO m => t -> m ()
69 -- | Return the display to the state before reserve_display
70 -- If no previous state then set the display state to the initial state.
71 release_display :: MonadIO m => t -> m ()
73 -- | Returns the current display bounds.
74 display_bounds :: MonadIO m => t -> m DisplayRegion
76 -- Internal method used to provide the DisplayTerminal instance to the DisplayHandle
78 display_terminal_instance :: MonadIO m
81 -> (forall d. DisplayTerminal d => d -> DisplayHandle)
84 -- | Output the byte buffer of the specified size to the terminal device. The size is equal to
85 -- end_ptr - start_ptr
86 output_byte_buffer :: t -> OutputBuffer -> Int -> IO ()
88 -- | Handle of output device
89 output_handle :: t -> IO Handle
91instance Terminal TerminalHandle where
92 terminal_ID (TerminalHandle t _) = terminal_ID t
93 release_terminal (TerminalHandle t _) = release_terminal t
94 reserve_display (TerminalHandle t _) = reserve_display t
95 release_display (TerminalHandle t _) = release_display t
96 display_bounds (TerminalHandle t _) = display_bounds t
97 display_terminal_instance (TerminalHandle t _) = display_terminal_instance t
98 output_byte_buffer (TerminalHandle t _) = output_byte_buffer t
99 output_handle (TerminalHandle t _) = output_handle t
101data DisplayHandle where
102 DisplayHandle :: forall d . DisplayTerminal d => d -> TerminalHandle -> DisplayState -> DisplayHandle
104-- | Acquire display access to the given region of the display.
105-- Currently all regions have the upper left corner of (0,0) and the lower right corner at
106-- (max display_width provided_width, max display_height provided_height)
107display_context :: MonadIO m => TerminalHandle -> DisplayRegion -> m DisplayHandle
108display_context t b = do
109 s <- initial_display_state
110 display_terminal_instance t b (\ d -> DisplayHandle d t s)
112data DisplayState = DisplayState
113 { previous_output_ref :: IORef (Maybe DisplayOps)
116initial_display_state :: MonadIO m => m DisplayState
117initial_display_state = liftM DisplayState $ liftIO $ newIORef Nothing
119class DisplayTerminal d where
120 -- | Provide the bounds of the display context.
121 context_region :: d -> DisplayRegion
123 -- | Maximum number of colors supported by the context.
124 context_color_count :: d -> Int
126 -- | sets the output position to the specified row and column. Where the number of bytes
127 -- required for the control codes can be specified seperate from the actual byte sequence.
128 move_cursor_required_bytes :: d -> Int -> Int -> Int
129 serialize_move_cursor :: MonadIO m => d -> Int -> Int -> OutputBuffer -> m OutputBuffer
131 show_cursor_required_bytes :: d -> Int
132 serialize_show_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
134 hide_cursor_required_bytes :: d -> Int
135 serialize_hide_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
137 -- | Assure the specified output attributes will be applied to all the following text until the
138 -- next output attribute change. Where the number of bytes required for the control codes can
139 -- be specified seperate from the actual byte sequence. The required number of bytes must be
140 -- at least the maximum number of bytes required by any attribute changes. The serialization
141 -- equations must provide the ptr to the next byte to be specified in the output buffer.
143 -- The currently applied display attributes are provided as well. The Attr data type can
144 -- specify the style or color should not be changed from the currently applied display
145 -- attributes. In order to support this the currently applied display attributes are required.
146 -- In addition it may be possible to optimize the state changes based off the currently applied
147 -- display attributes.
148 attr_required_bytes :: d -> FixedAttr -> Attr -> DisplayAttrDiff -> Int
149 serialize_set_attr :: MonadIO m => d -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> m OutputBuffer
151 -- | Reset the display attributes to the default display attributes
152 default_attr_required_bytes :: d -> Int
153 serialize_default_attr :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
155 -- | See Graphics.Vty.Terminal.XTermColor.inline_hack
156 inline_hack :: MonadIO m => d -> m ()
157 inline_hack _d = return ()
160instance DisplayTerminal DisplayHandle where
161 context_region (DisplayHandle d _ _) = context_region d
162 context_color_count (DisplayHandle d _ _) = context_color_count d
163 move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d
164 serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d
165 show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d
166 serialize_show_cursor (DisplayHandle d _ _) = serialize_show_cursor d
167 hide_cursor_required_bytes (DisplayHandle d _ _) = hide_cursor_required_bytes d
168 serialize_hide_cursor (DisplayHandle d _ _) = serialize_hide_cursor d
169 attr_required_bytes (DisplayHandle d _ _) = attr_required_bytes d
170 serialize_set_attr (DisplayHandle d _ _) = serialize_set_attr d
171 default_attr_required_bytes (DisplayHandle d _ _) = default_attr_required_bytes d
172 serialize_default_attr (DisplayHandle d _ _) = serialize_default_attr d
173 inline_hack (DisplayHandle d _ _) = inline_hack d
175-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
176utf8_text_required_bytes :: BS.ByteString -> Int
177utf8_text_required_bytes str =
178 let (_, _, src_bytes_length) = BS.toForeignPtr str
181-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
182serialize_utf8_text :: MonadIO m => BS.ByteString -> OutputBuffer -> m OutputBuffer
183serialize_utf8_text str dest_ptr =
184 let (src_fptr, src_ptr_offset, src_bytes_length) = BS.toForeignPtr str
185 in liftIO $ withForeignPtr src_fptr $ \src_ptr -> do
186 let src_ptr' = src_ptr `plusPtr` src_ptr_offset
187 BS.memcpy dest_ptr src_ptr' (toEnum src_bytes_length)
188 return (dest_ptr `plusPtr` src_bytes_length)
191-- | Displays the given `Picture`.
193-- 0. The image is cropped to the display size.
195-- 1. Converted into a sequence of attribute changes and text spans.
197-- 2. The cursor is hidden.
199-- 3. Serialized to the display.
201-- 4. The cursor is then shown and positioned or kept hidden.
204-- todo: specify possible IO exceptions.
205-- abstract from IO monad to a MonadIO instance.
206output_picture :: MonadIO m => DisplayHandle -> Picture -> m ()
207output_picture (DisplayHandle d t s) pic = do
208 let !r = context_region d
209 let !ops = spans_for_pic pic r
210 let !initial_attr = FixedAttr default_style_mask Nothing Nothing
211 -- Diff the previous output against the requested output. Differences are currently on a per-row
214 <- liftIO ( readIORef (previous_output_ref s) )
215 >>= \mprevious_ops -> case mprevious_ops of
217 -> return $ replicate ( fromEnum $ region_height $ effected_region ops )
220 -> if effected_region previous_ops /= effected_region ops
221 then return $ replicate ( fromEnum $ region_height $ effected_region ops )
223 else return $ zipWith (/=) ( Vector.toList $ display_ops previous_ops )
224 ( Vector.toList $ display_ops ops )
226 -- determine the number of bytes required to completely serialize the output ops.
227 let total = hide_cursor_required_bytes d
228 + default_attr_required_bytes d
229 + required_bytes d initial_attr diffs ops
230 + case pic_cursor pic of
232 Cursor x y -> let m = cursor_output_map ops $ pic_cursor pic
233 ( ox, oy ) = char_to_output_pos m ( x, y )
234 in show_cursor_required_bytes d
235 + move_cursor_required_bytes d ox oy
237 -- ... then serialize
238 liftIO $ allocaBytes (fromEnum total) $ \start_ptr -> do
239 ptr <- serialize_hide_cursor d start_ptr
240 ptr' <- serialize_default_attr d ptr
241 ptr'' <- serialize_output_ops d ptr' initial_attr diffs ops
242 end_ptr <- case pic_cursor pic of
243 NoCursor -> return ptr''
245 let m = cursor_output_map ops $ pic_cursor pic
246 (ox, oy) = char_to_output_pos m (x,y)
247 serialize_show_cursor d ptr'' >>= serialize_move_cursor d ox oy
248 -- todo: How to handle exceptions?
249 case end_ptr `minusPtr` start_ptr of
250 count | count < 0 -> fail "End pointer before start of buffer."
251 | toEnum count > total -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - total)
252 | otherwise -> output_byte_buffer t start_ptr (toEnum count)
253 -- Cache the output spans.
254 liftIO $ writeIORef (previous_output_ref s) (Just ops)
257required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> DisplayOps -> Int
258required_bytes d in_fattr diffs ops =
259 let (_, n, _, _) = Vector.foldl' required_bytes' (0, 0, in_fattr, diffs) ( display_ops ops )
262 required_bytes' (y, current_sum, fattr, True : diffs') span_ops
263 = let (s, fattr') = span_ops_required_bytes d y fattr span_ops
264 in ( y + 1, s + current_sum, fattr', diffs' )
265 required_bytes' (y, current_sum, fattr, False : diffs') _span_ops
266 = ( y + 1, current_sum, fattr, diffs' )
267 required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops
268 = error "shouldn't be possible"
270span_ops_required_bytes :: DisplayTerminal d => d -> Int -> FixedAttr -> SpanOps -> (Int, FixedAttr)
271span_ops_required_bytes d y in_fattr span_ops =
272 -- The first operation is to set the cursor to the start of the row
273 let header_required_bytes = move_cursor_required_bytes d 0 y
274 -- then the span ops are serialized in the order specified
275 in Vector.foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op
276 in (c + current_sum, fattr')
278 (header_required_bytes, in_fattr)
281span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Int, FixedAttr)
282span_op_required_bytes d fattr (AttributeChange attr) =
283 let attr' = limit_attr_for_display d attr
284 diffs = display_attr_diffs fattr fattr'
285 c = attr_required_bytes d fattr attr' diffs
286 fattr' = fix_display_attr fattr attr'
288span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)
290serialize_output_ops :: ( MonadIO m, DisplayTerminal d )
297serialize_output_ops d start_ptr in_fattr diffs ops = do
298 (_, end_ptr, _, _) <- Vector.foldM' serialize_output_ops'
299 ( 0, start_ptr, in_fattr, diffs )
303 serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops
304 = serialize_span_ops d y out_ptr fattr span_ops
305 >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) )
306 serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops
307 = return ( y + 1, out_ptr, fattr, diffs' )
308 serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops
309 = error "shouldn't be possible"
311serialize_span_ops :: ( MonadIO m, DisplayTerminal d )
317 -> m (OutputBuffer, FixedAttr)
318serialize_span_ops d y out_ptr in_fattr span_ops = do
319 -- The first operation is to set the cursor to the start of the row
320 out_ptr' <- serialize_move_cursor d 0 y out_ptr
321 -- then the span ops are serialized in the order specified
322 Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr )
326serialize_span_op :: ( MonadIO m, DisplayTerminal d )
331 -> m (OutputBuffer, FixedAttr)
332serialize_span_op d (AttributeChange attr) out_ptr fattr = do
333 let attr' = limit_attr_for_display d attr
334 fattr' = fix_display_attr fattr attr'
335 diffs = display_attr_diffs fattr fattr'
336 out_ptr' <- serialize_set_attr d fattr attr' diffs out_ptr
337 return (out_ptr', fattr')
338serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do
339 out_ptr' <- serialize_utf8_text str out_ptr
340 return (out_ptr', fattr)
342marshall_to_terminal :: ( Terminal t )
343 => t -> Int -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()
344marshall_to_terminal t c f = do
345 start_ptr <- mallocBytes (fromEnum c)
347 -- todo: capture exceptions?
348 end_ptr <- f start_ptr
349 case end_ptr `minusPtr` start_ptr of
350 count | count < 0 -> fail "End pointer before start pointer."
351 | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c)
352 | otherwise -> output_byte_buffer t start_ptr (toEnum count)
356-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this
357-- needs to be translated to column, row positions.
358data CursorOutputMap = CursorOutputMap
359 { char_to_output_pos :: (Int, Int) -> (Int, Int)
362cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap
363cursor_output_map span_ops _cursor = CursorOutputMap
364 { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)
367cursor_column_offset :: DisplayOps -> Int -> Int -> Int
368cursor_column_offset span_ops cx cy =
369 let cursor_row_ops = Vector.unsafeIndex (display_ops span_ops) (fromEnum cy)
371 = Vector.foldl' ( \(d, current_cx, done) op ->
372 if done then (d, current_cx, done) else case span_op_has_width op of
373 Nothing -> (d, current_cx, False)
374 Just (cw, ow) -> case compare cx (current_cx + cw) of
383 LT -> ( d + columns_to_char_offset (cx - current_cx) op
392-- | Not all terminals support all display attributes. This filters a display attribute to what the
393-- given terminal can display.
394limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr
395limit_attr_for_display d attr
396 = attr { attr_fore_color = clamp_color $ attr_fore_color attr
397 , attr_back_color = clamp_color $ attr_back_color attr
400 clamp_color Default = Default
401 clamp_color KeepCurrent = KeepCurrent
402 clamp_color (SetTo c) = clamp_color' c
403 clamp_color' (ISOColor v)
404 | context_color_count d < 8 = Default
405 | context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
406 | otherwise = SetTo $ ISOColor v
407 clamp_color' (Color240 v)
408 -- TODO: Choose closes ISO color?
409 | context_color_count d < 8 = Default
410 | context_color_count d < 16 = Default
411 | context_color_count d == 240 = SetTo $ Color240 v
413 = let p :: Double = fromIntegral v / 240.0
414 v' = floor $ p * (fromIntegral $ context_color_count d)
415 in SetTo $ Color240 v'
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list