git.iko.soy/vty
on 30fd552 help sign in
vty/src/Graphics/Vty/Terminal/Generic.hs
412 lines 19 kB history raw
1-- Copyright 2009-2011 Corey O'Connor
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE FlexibleContexts #-}
8module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic
9 , OutputBuffer
10 )
11 where
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 Data.Array
25import qualified Data.ByteString.Internal as BSCore
26import Data.Foldable
27import Data.IORef
28import Data.String.UTF8 hiding ( foldl )
30import System.IO
32data TerminalHandle where
33 TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle
35state_ref :: TerminalHandle -> IORef TerminalState
36state_ref (TerminalHandle _ s_ref) = s_ref
38new_terminal_handle :: forall m t. ( MonadIO m, Terminal t ) => t -> m TerminalHandle
39new_terminal_handle t = do
40 s_ref <- liftIO $ newIORef initial_terminal_state
41 return $ TerminalHandle t s_ref
43data TerminalState = TerminalState
44 { -- | The current terminal display attributes or Nothing if they are not known.
45 known_fattr :: Maybe FixedAttr
46 }
48initial_terminal_state :: TerminalState
49initial_terminal_state = TerminalState Nothing
51class Terminal t where
52 -- | Text identifier for the terminal. Used for debugging.
53 terminal_ID :: t -> String
54 -- |
55 release_terminal :: MonadIO m => t -> m ()
56 -- | Clear the display and initialize the terminal to some initial display state.
57 --
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
77 -- constructor.
78 display_terminal_instance :: MonadIO m
79 => t
80 -> DisplayRegion
81 -> (forall d. DisplayTerminal d => d -> DisplayHandle)
82 -> m 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 -> Word -> 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 SpanOpSequence)
114 }
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 -> Word
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 -> Word -> Word -> Word
129 serialize_move_cursor :: MonadIO m => d -> Word -> Word -> OutputBuffer -> m OutputBuffer
131 show_cursor_required_bytes :: d -> Word
132 serialize_show_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer
134 hide_cursor_required_bytes :: d -> Word
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.
142 --
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 -> Word
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 -> Word
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 :: UTF8 BSCore.ByteString -> Word
177utf8_text_required_bytes str =
178 let (_, _, src_bytes_length) = BSCore.toForeignPtr (toRep str)
179 in toEnum src_bytes_length
181-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
182serialize_utf8_text :: MonadIO m => UTF8 BSCore.ByteString -> OutputBuffer -> m OutputBuffer
183serialize_utf8_text str dest_ptr =
184 let (src_fptr, src_ptr_offset, src_bytes_length) = BSCore.toForeignPtr (toRep str)
185 in liftIO $ withForeignPtr src_fptr $ \src_ptr -> do
186 let src_ptr' = src_ptr `plusPtr` src_ptr_offset
187 BSCore.memcpy dest_ptr src_ptr' (toEnum src_bytes_length)
188 return (dest_ptr `plusPtr` src_bytes_length)
191-- | Displays the given `Picture`.
192--
193-- 0. The image is cropped to the display size.
194--
195-- 1. Converted into a sequence of attribute changes and text spans.
196--
197-- 2. The cursor is hidden.
198--
199-- 3. Serialized to the display.
200--
201-- 4. The cursor is then shown and positioned or kept hidden.
202--
203--
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
212 -- basis.
213 diffs :: [Bool]
214 <- liftIO ( readIORef (previous_output_ref s) )
215 >>= \mprevious_ops -> case mprevious_ops of
216 Nothing
217 -> return $ replicate ( fromEnum $ region_height $ effected_region ops )
218 True
219 Just previous_ops
220 -> if effected_region previous_ops /= effected_region ops
221 then return $ replicate ( fromEnum $ region_height $ effected_region ops )
222 True
223 else return $ zipWith (/=) ( elems $ row_ops previous_ops )
224 ( elems $ row_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
231 NoCursor -> 0
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''
244 Cursor x y -> do
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)
255 return ()
257required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> SpanOpSequence -> Word
258required_bytes d in_fattr diffs ops =
259 let (_, n, _, _) = foldl' required_bytes' (0, 0, in_fattr, diffs) ( row_ops ops )
260 in n
261 where
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 -> Word -> FixedAttr -> SpanOps -> (Word, 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 foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op
276 in (c + current_sum, fattr')
277 )
278 (header_required_bytes, in_fattr)
279 span_ops
281span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, 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'
287 in (c, fattr')
288span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)
290serialize_output_ops :: ( MonadIO m, DisplayTerminal d )
291 => d
292 -> OutputBuffer
293 -> FixedAttr
294 -> [Bool]
295 -> SpanOpSequence
296 -> m OutputBuffer
297serialize_output_ops d start_ptr in_fattr diffs ops = do
298 (_, end_ptr, _, _) <- foldlM serialize_output_ops'
299 ( 0, start_ptr, in_fattr, diffs )
300 ( row_ops ops )
301 return end_ptr
302 where
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 )
312 => d
313 -> Word
314 -> OutputBuffer
315 -> FixedAttr
316 -> SpanOps
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 foldlM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr )
323 (out_ptr', in_fattr)
324 span_ops
326serialize_span_op :: ( MonadIO m, DisplayTerminal d )
327 => d
328 -> SpanOp
329 -> OutputBuffer
330 -> FixedAttr
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 -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()
344marshall_to_terminal t c f = do
345 start_ptr <- mallocBytes (fromEnum c)
346 --
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)
353 free start_ptr
354 return ()
356data CursorOutputMap = CursorOutputMap
357 { char_to_output_pos :: (Word, Word) -> (Word, Word)
358 }
360cursor_output_map :: SpanOpSequence -> Cursor -> CursorOutputMap
361cursor_output_map span_ops _cursor = CursorOutputMap
362 { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)
363 }
365cursor_column_offset :: SpanOpSequence -> Word -> Word -> Word
366cursor_column_offset span_ops cx cy =
367 let cursor_row_ops = row_ops span_ops ! cy
368 (out_offset, _, _)
369 = foldl' ( \(d, current_cx, done) op ->
370 if done then (d, current_cx, done) else case span_op_has_width op of
371 Nothing -> (d, current_cx, False)
372 Just (cw, ow) -> case compare cx (current_cx + cw) of
373 GT -> ( d + ow
374 , current_cx + cw
375 , False
376 )
377 EQ -> ( d + ow
378 , current_cx + cw
379 , True
380 )
381 LT -> ( d + columns_to_char_offset (cx - current_cx) op
382 , current_cx + cw
383 , True
384 )
385 )
386 (0, 0, False)
387 cursor_row_ops
388 in out_offset
390limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr
391limit_attr_for_display d attr
392 = attr { attr_fore_color = clamp_color $ attr_fore_color attr
393 , attr_back_color = clamp_color $ attr_back_color attr
394 }
395 where
396 clamp_color Default = Default
397 clamp_color KeepCurrent = KeepCurrent
398 clamp_color (SetTo c) = clamp_color' c
399 clamp_color' (ISOColor v)
400 | context_color_count d < 8 = Default
401 | context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
402 | otherwise = SetTo $ ISOColor v
403 clamp_color' (Color240 v)
404 -- TODO: Choose closes ISO color?
405 | context_color_count d < 8 = Default
406 | context_color_count d < 16 = Default
407 | context_color_count d == 240 = SetTo $ Color240 v
408 | otherwise
409 = let p :: Double = fromIntegral v / 240.0
410 v' = floor $ p * (fromIntegral $ context_color_count d)
411 in SetTo $ Color240 v'