git.iko.soy/vty
on ae06339 help sign in
vty/src/Graphics/Vty/Terminal/Generic.hs
411 lines 19 kB history raw
1-- Copyright 2009-2010 Corey O'Connor
2{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE FlexibleContexts #-}
7module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic
8 , OutputBuffer
9 )
10 where
12import Data.Marshalling
14import Graphics.Vty.Picture
15import Graphics.Vty.Span
16import Graphics.Vty.DisplayRegion
18import Graphics.Vty.DisplayAttributes
20import Control.Monad ( liftM )
21import Control.Monad.Trans
23import Data.Array
24import qualified Data.ByteString.Internal as BSCore
25import Data.Foldable
26import Data.IORef
27import Data.String.UTF8 hiding ( foldl )
29import System.IO
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
42data TerminalState = TerminalState
43 { -- | The current terminal display attributes or Nothing if they are not known.
44 known_fattr :: Maybe FixedAttr
45 }
47initial_terminal_state :: TerminalState
48initial_terminal_state = TerminalState Nothing
50class Terminal t where
51 -- | Text identifier for the terminal. Used for debugging.
52 terminal_ID :: t -> String
53 -- |
54 release_terminal :: MonadIO m => t -> m ()
55 -- | Clear the display and initialize the terminal to some initial display state.
56 --
57 -- The expectation of a program is that the display starts in some initial state.
58 -- The initial state would consist of fixed values:
59 -- - cursor at top left
60 -- - UTF-8 character encoding
61 -- - drawing characteristics are the default
62 -- The abstract operation I think all these behaviors are instances of is reserving exclusive
63 -- access to a display such that:
64 -- - The previous state cannot be determined
65 -- - When exclusive access to a display is release the display returns to the previous state.
66 reserve_display :: MonadIO m => t -> m ()
68 -- | Return the display to the state before reserve_display
69 -- If no previous state then set the display state to the initial state.
70 release_display :: MonadIO m => t -> m ()
72 -- | Returns the current display bounds.
73 display_bounds :: MonadIO m => t -> m DisplayRegion
75 -- Internal method used to provide the DisplayTerminal instance to the DisplayHandle
76 -- constructor.
77 display_terminal_instance :: MonadIO m
78 => t
79 -> DisplayRegion
80 -> (forall d. DisplayTerminal d => d -> DisplayHandle)
81 -> m DisplayHandle
83 -- | Output the byte buffer of the specified size to the terminal device. The size is equal to
84 -- end_ptr - start_ptr
85 output_byte_buffer :: t -> OutputBuffer -> Word -> IO ()
87 -- | Handle of output device
88 output_handle :: t -> IO Handle
90instance Terminal TerminalHandle where
91 terminal_ID (TerminalHandle t _) = terminal_ID t
92 release_terminal (TerminalHandle t _) = release_terminal t
93 reserve_display (TerminalHandle t _) = reserve_display t
94 release_display (TerminalHandle t _) = release_display t
95 display_bounds (TerminalHandle t _) = display_bounds t
96 display_terminal_instance (TerminalHandle t _) = display_terminal_instance t
97 output_byte_buffer (TerminalHandle t _) = output_byte_buffer t
98 output_handle (TerminalHandle t _) = output_handle t
100data DisplayHandle where
101 DisplayHandle :: forall d . DisplayTerminal d => d -> TerminalHandle -> DisplayState -> DisplayHandle
103-- | Acquire display access to the given region of the display.
104-- Currently all regions have the upper left corner of (0,0) and the lower right corner at
105-- (max display_width provided_width, max display_height provided_height)
106display_context :: MonadIO m => TerminalHandle -> DisplayRegion -> m DisplayHandle
107display_context t b = do
108 s <- initial_display_state
109 display_terminal_instance t b (\ d -> DisplayHandle d t s)
111data DisplayState = DisplayState
112 { previous_output_ref :: IORef (Maybe SpanOpSequence)
113 }
115initial_display_state :: MonadIO m => m DisplayState
116initial_display_state = liftM DisplayState $ liftIO $ newIORef Nothing
118class DisplayTerminal d where
119 -- | Provide the bounds of the display context.
120 context_region :: d -> DisplayRegion
122 -- | Maximum number of colors supported by the context.
123 context_color_count :: d -> Word
125 -- | sets the output position to the specified row and column. Where the number of bytes
126 -- required for the control codes can be specified seperate from the actual byte sequence.
127 move_cursor_required_bytes :: d -> Word -> Word -> Word
128 serialize_move_cursor :: MonadIO m => d -> Word -> Word -> OutputBuffer -> m OutputBuffer
130 show_cursor_required_bytes :: d -> Word
131 serialize_show_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
133 hide_cursor_required_bytes :: d -> Word
134 serialize_hide_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
136 -- | Assure the specified output attributes will be applied to all the following text until the
137 -- next output attribute change. Where the number of bytes required for the control codes can
138 -- be specified seperate from the actual byte sequence. The required number of bytes must be
139 -- at least the maximum number of bytes required by any attribute changes. The serialization
140 -- equations must provide the ptr to the next byte to be specified in the output buffer.
141 --
142 -- The currently applied display attributes are provided as well. The Attr data type can
143 -- specify the style or color should not be changed from the currently applied display
144 -- attributes. In order to support this the currently applied display attributes are required.
145 -- In addition it may be possible to optimize the state changes based off the currently applied
146 -- display attributes.
147 attr_required_bytes :: d -> FixedAttr -> Attr -> DisplayAttrDiff -> Word
148 serialize_set_attr :: MonadIO m => d -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> m OutputBuffer
150 -- | Reset the display attributes to the default display attributes
151 default_attr_required_bytes :: d -> Word
152 serialize_default_attr :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
154 -- | See Graphics.Vty.Terminal.XTermColor.inline_hack
155 inline_hack :: MonadIO m => d -> m ()
156 inline_hack _d = return ()
159instance DisplayTerminal DisplayHandle where
160 context_region (DisplayHandle d _ _) = context_region d
161 context_color_count (DisplayHandle d _ _) = context_color_count d
162 move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d
163 serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d
164 show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d
165 serialize_show_cursor (DisplayHandle d _ _) = serialize_show_cursor d
166 hide_cursor_required_bytes (DisplayHandle d _ _) = hide_cursor_required_bytes d
167 serialize_hide_cursor (DisplayHandle d _ _) = serialize_hide_cursor d
168 attr_required_bytes (DisplayHandle d _ _) = attr_required_bytes d
169 serialize_set_attr (DisplayHandle d _ _) = serialize_set_attr d
170 default_attr_required_bytes (DisplayHandle d _ _) = default_attr_required_bytes d
171 serialize_default_attr (DisplayHandle d _ _) = serialize_default_attr d
172 inline_hack (DisplayHandle d _ _) = inline_hack d
174-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
175utf8_text_required_bytes :: UTF8 BSCore.ByteString -> Word
176utf8_text_required_bytes str =
177 let (_, _, src_bytes_length) = BSCore.toForeignPtr (toRep str)
178 in toEnum src_bytes_length
180-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
181serialize_utf8_text :: MonadIO m => UTF8 BSCore.ByteString -> OutputBuffer -> m OutputBuffer
182serialize_utf8_text str dest_ptr =
183 let (src_fptr, src_ptr_offset, src_bytes_length) = BSCore.toForeignPtr (toRep str)
184 in liftIO $ withForeignPtr src_fptr $ \src_ptr -> do
185 let src_ptr' = src_ptr `plusPtr` src_ptr_offset
186 BSCore.memcpy dest_ptr src_ptr' (toEnum src_bytes_length)
187 return (dest_ptr `plusPtr` src_bytes_length)
190-- | Displays the given `Picture`.
191--
192-- 0. The image is cropped to the display size.
193--
194-- 1. Converted into a sequence of attribute changes and text spans.
195--
196-- 2. The cursor is hidden.
197--
198-- 3. Serialized to the display.
199--
200-- 4. The cursor is then shown and positioned or kept hidden.
201--
202--
203-- todo: specify possible IO exceptions.
204-- abstract from IO monad to a MonadIO instance.
205output_picture :: MonadIO m => DisplayHandle -> Picture -> m ()
206output_picture (DisplayHandle d t s) pic = do
207 let !r = context_region d
208 let !ops = spans_for_pic pic r
209 let !initial_attr = FixedAttr default_style_mask Nothing Nothing
210 -- Diff the previous output against the requested output. Differences are currently on a per-row
211 -- basis.
212 diffs :: [Bool]
213 <- liftIO ( readIORef (previous_output_ref s) )
214 >>= \mprevious_ops -> case mprevious_ops of
215 Nothing
216 -> return $ replicate ( fromEnum $ region_height $ effected_region ops )
217 True
218 Just previous_ops
219 -> if effected_region previous_ops /= effected_region ops
220 then return $ replicate ( fromEnum $ region_height $ effected_region ops )
221 True
222 else return $ zipWith (/=) ( elems $ row_ops previous_ops )
223 ( elems $ row_ops ops )
225 -- determine the number of bytes required to completely serialize the output ops.
226 let total = hide_cursor_required_bytes d
227 + default_attr_required_bytes d
228 + required_bytes d initial_attr diffs ops
229 + case pic_cursor pic of
230 NoCursor -> 0
231 Cursor x y -> let m = cursor_output_map ops $ pic_cursor pic
232 ( ox, oy ) = char_to_output_pos m ( x, y )
233 in show_cursor_required_bytes d
234 + move_cursor_required_bytes d ox oy
236 -- ... then serialize
237 liftIO $ allocaBytes (fromEnum total) $ \start_ptr -> do
238 ptr <- serialize_hide_cursor d start_ptr
239 ptr' <- serialize_default_attr d ptr
240 ptr'' <- serialize_output_ops d ptr' initial_attr diffs ops
241 end_ptr <- case pic_cursor pic of
242 NoCursor -> return ptr''
243 Cursor x y -> do
244 let m = cursor_output_map ops $ pic_cursor pic
245 (ox, oy) = char_to_output_pos m (x,y)
246 serialize_show_cursor d ptr'' >>= serialize_move_cursor d ox oy
247 -- todo: How to handle exceptions?
248 case end_ptr `minusPtr` start_ptr of
249 count | count < 0 -> fail "End pointer before start of buffer."
250 | toEnum count > total -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - total)
251 | otherwise -> output_byte_buffer t start_ptr (toEnum count)
252 -- Cache the output spans.
253 liftIO $ writeIORef (previous_output_ref s) (Just ops)
254 return ()
256required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> SpanOpSequence -> Word
257required_bytes d in_fattr diffs ops =
258 let (_, n, _, _) = foldl' required_bytes' (0, 0, in_fattr, diffs) ( row_ops ops )
259 in n
260 where
261 required_bytes' (y, current_sum, fattr, True : diffs') span_ops
262 = let (s, fattr') = span_ops_required_bytes d y fattr span_ops
263 in ( y + 1, s + current_sum, fattr', diffs' )
264 required_bytes' (y, current_sum, fattr, False : diffs') _span_ops
265 = ( y + 1, current_sum, fattr, diffs' )
266 required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops
267 = error "shouldn't be possible"
269span_ops_required_bytes :: DisplayTerminal d => d -> Word -> FixedAttr -> SpanOps -> (Word, FixedAttr)
270span_ops_required_bytes d y in_fattr span_ops =
271 -- The first operation is to set the cursor to the start of the row
272 let header_required_bytes = move_cursor_required_bytes d 0 y
273 -- then the span ops are serialized in the order specified
274 in foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op
275 in (c + current_sum, fattr')
276 )
277 (header_required_bytes, in_fattr)
278 span_ops
280span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr)
281span_op_required_bytes d fattr (AttributeChange attr) =
282 let attr' = limit_attr_for_display d attr
283 diffs = display_attr_diffs fattr fattr'
284 c = attr_required_bytes d fattr attr' diffs
285 fattr' = fix_display_attr fattr attr'
286 in (c, fattr')
287span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)
289serialize_output_ops :: ( MonadIO m, DisplayTerminal d )
290 => d
291 -> OutputBuffer
292 -> FixedAttr
293 -> [Bool]
294 -> SpanOpSequence
295 -> m OutputBuffer
296serialize_output_ops d start_ptr in_fattr diffs ops = do
297 (_, end_ptr, _, _) <- foldlM serialize_output_ops'
298 ( 0, start_ptr, in_fattr, diffs )
299 ( row_ops ops )
300 return end_ptr
301 where
302 serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops
303 = serialize_span_ops d y out_ptr fattr span_ops
304 >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) )
305 serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops
306 = return ( y + 1, out_ptr, fattr, diffs' )
307 serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops
308 = error "shouldn't be possible"
310serialize_span_ops :: ( MonadIO m, DisplayTerminal d )
311 => d
312 -> Word
313 -> OutputBuffer
314 -> FixedAttr
315 -> SpanOps
316 -> m (OutputBuffer, FixedAttr)
317serialize_span_ops d y out_ptr in_fattr span_ops = do
318 -- The first operation is to set the cursor to the start of the row
319 out_ptr' <- serialize_move_cursor d 0 y out_ptr
320 -- then the span ops are serialized in the order specified
321 foldlM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr )
322 (out_ptr', in_fattr)
323 span_ops
325serialize_span_op :: ( MonadIO m, DisplayTerminal d )
326 => d
327 -> SpanOp
328 -> OutputBuffer
329 -> FixedAttr
330 -> m (OutputBuffer, FixedAttr)
331serialize_span_op d (AttributeChange attr) out_ptr fattr = do
332 let attr' = limit_attr_for_display d attr
333 fattr' = fix_display_attr fattr attr'
334 diffs = display_attr_diffs fattr fattr'
335 out_ptr' <- serialize_set_attr d fattr attr' diffs out_ptr
336 return (out_ptr', fattr')
337serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do
338 out_ptr' <- serialize_utf8_text str out_ptr
339 return (out_ptr', fattr)
341marshall_to_terminal :: ( Terminal t )
342 => t -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()
343marshall_to_terminal t c f = do
344 start_ptr <- mallocBytes (fromEnum c)
345 --
346 -- todo: capture exceptions?
347 end_ptr <- f start_ptr
348 case end_ptr `minusPtr` start_ptr of
349 count | count < 0 -> fail "End pointer before start pointer."
350 | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c)
351 | otherwise -> output_byte_buffer t start_ptr (toEnum count)
352 free start_ptr
353 return ()
355data CursorOutputMap = CursorOutputMap
356 { char_to_output_pos :: (Word, Word) -> (Word, Word)
357 }
359cursor_output_map :: SpanOpSequence -> Cursor -> CursorOutputMap
360cursor_output_map span_ops _cursor = CursorOutputMap
361 { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)
362 }
364cursor_column_offset :: SpanOpSequence -> Word -> Word -> Word
365cursor_column_offset span_ops cx cy =
366 let cursor_row_ops = row_ops span_ops ! cy
367 (out_offset, _, _)
368 = foldl' ( \(d, current_cx, done) op ->
369 if done then (d, current_cx, done) else case span_op_has_width op of
370 Nothing -> (d, current_cx, False)
371 Just (cw, ow) -> case compare cx (current_cx + cw) of
372 GT -> ( d + ow
373 , current_cx + cw
374 , False
375 )
376 EQ -> ( d + ow
377 , current_cx + cw
378 , True
379 )
380 LT -> ( d + columns_to_char_offset (cx - current_cx) op
381 , current_cx + cw
382 , True
383 )
384 )
385 (0, 0, False)
386 cursor_row_ops
387 in out_offset
389limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr
390limit_attr_for_display d attr
391 = attr { attr_fore_color = clamp_color $ attr_fore_color attr
392 , attr_back_color = clamp_color $ attr_back_color attr
393 }
394 where
395 clamp_color Default = Default
396 clamp_color KeepCurrent = KeepCurrent
397 clamp_color (SetTo c) = clamp_color' c
398 clamp_color' (ISOColor v)
399 | context_color_count d < 8 = Default
400 | context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
401 | otherwise = SetTo $ ISOColor v
402 clamp_color' (Color240 v)
403 -- TODO: Choose closes ISO color?
404 | context_color_count d < 8 = Default
405 | context_color_count d < 16 = Default
406 | context_color_count d == 240 = SetTo $ Color240 v
407 | otherwise
408 = let p :: Double = fromIntegral v / 240.0
409 v' = floor $ p * (fromIntegral $ context_color_count d)
410 in SetTo $ Color240 v'