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