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