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