1-- Copyright Corey O'Connor
2-- General philosophy is: MonadIO is for equations exposed to clients.
3{-# LANGUAGE BangPatterns #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE ExistentialQuantification #-}
7{-# LANGUAGE FlexibleContexts #-}
8module Graphics.Vty.Output.Interface ( module Graphics.Vty.Output.Interface
13import Graphics.Vty.Prelude
15import Data.Marshalling
17import Graphics.Vty.Picture
18import Graphics.Vty.PictureToSpans
19import Graphics.Vty.Span
21import Graphics.Vty.DisplayAttributes
23import Control.Monad.Trans
25import qualified Data.ByteString.Internal as BS
26import qualified Data.Text.Encoding as T
27import qualified Data.Text.Lazy as TL
29import qualified Data.Vector as Vector
32 { -- | Text identifier for the output device. Used for debugging.
34 , release_terminal :: MonadIO m => m ()
35 -- | Clear the display and initialize the terminal to some initial display state.
37 -- The expectation of a program is that the display starts in some initial state.
38 -- The initial state would consist of fixed values:
40 -- - cursor at top left
41 -- - UTF-8 character encoding
42 -- - drawing characteristics are the default
44 -- The abstract operation I think all these behaviors are instances of is reserving exclusive
45 -- access to a display such that:
47 -- - The previous state cannot be determined
48 -- - When exclusive access to a display is released the display returns to the previous state.
49 , reserve_display :: MonadIO m => m ()
50 -- | Return the display to the state before reserve_display
51 -- If no previous state then set the display state to the initial state.
52 , release_display :: MonadIO m => m ()
53 -- | Returns the current display bounds.
54 , display_bounds :: MonadIO m => m DisplayRegion
55 -- | Output the byte buffer of the specified size to the terminal device. The size is equal to
56 -- end_ptr - start_ptr
57 , output_byte_buffer :: OutputBuffer -> Int -> IO ()
58 -- | Maximum number of colors supported by the context.
59 , context_color_count :: Int
60 -- | if the cursor can be shown / hidden
61 , supports_cursor_visibility :: Bool
62 , assumed_state_ref :: IORef AssumedState
63 -- | Acquire display access to the given region of the display.
64 -- Currently all regions have the upper left corner of (0,0) and the lower right corner at
65 -- (max display_width provided_width, max display_height provided_height)
66 , mk_display_context :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
69display_context :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
70display_context t = liftIO . mk_display_context t t
72data AssumedState = AssumedState
73 { prev_fattr :: Maybe FixedAttr
74 , prev_output_ops :: Maybe DisplayOps
77initial_assumed_state :: AssumedState
78initial_assumed_state = AssumedState Nothing Nothing
80data DisplayContext = DisplayContext
81 { context_device :: Output
82 -- | Provide the bounds of the display context.
83 , context_region :: DisplayRegion
84 -- | sets the output position to the specified row and column. Where the number of bytes
85 -- required for the control codes can be specified seperate from the actual byte sequence.
86 , move_cursor_required_bytes :: Int -> Int -> Int
87 , serialize_move_cursor :: Int -> Int -> OutputBuffer -> IO OutputBuffer
88 , show_cursor_required_bytes :: Int
89 , serialize_show_cursor :: OutputBuffer -> IO OutputBuffer
90 , hide_cursor_required_bytes :: Int
91 , serialize_hide_cursor :: OutputBuffer -> IO OutputBuffer
92 -- | Assure the specified output attributes will be applied to all the following text until the
93 -- next output attribute change. Where the number of bytes required for the control codes can
94 -- be specified seperate from the actual byte sequence. The required number of bytes must be
95 -- at least the maximum number of bytes required by any attribute changes. The serialization
96 -- equations must provide the ptr to the next byte to be specified in the output buffer.
98 -- The currently applied display attributes are provided as well. The Attr data type can
99 -- specify the style or color should not be changed from the currently applied display
100 -- attributes. In order to support this the currently applied display attributes are required.
101 -- In addition it may be possible to optimize the state changes based off the currently applied
102 -- display attributes.
103 , attr_required_bytes :: FixedAttr -> Attr -> DisplayAttrDiff -> Int
104 , serialize_set_attr :: FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> IO OutputBuffer
105 -- | Reset the display attributes to the default display attributes
106 , default_attr_required_bytes :: Int
107 , serialize_default_attr :: OutputBuffer -> IO OutputBuffer
108 , row_end_required_bytes :: Int
109 , serialize_row_end :: OutputBuffer -> IO OutputBuffer
110 -- | See Graphics.Vty.Output.XTermColor.inline_hack
111 , inline_hack :: IO ()
114-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
115utf8_text_required_bytes :: BS.ByteString -> Int
116utf8_text_required_bytes str =
117 let (_, _, src_bytes_length) = BS.toForeignPtr str
120-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
121serialize_utf8_text :: BS.ByteString -> OutputBuffer -> IO OutputBuffer
122serialize_utf8_text str dest_ptr =
123 let (src_fptr, src_ptr_offset, src_bytes_length) = BS.toForeignPtr str
124 in withForeignPtr src_fptr $ \src_ptr -> do
125 let src_ptr' = src_ptr `plusPtr` src_ptr_offset
126 BS.memcpy dest_ptr src_ptr' (toEnum src_bytes_length)
127 return (dest_ptr `plusPtr` src_bytes_length)
129-- | Displays the given `Picture`.
131-- 0. The image is cropped to the display size.
133-- 1. Converted into a sequence of attribute changes and text spans.
135-- 2. The cursor is hidden.
137-- 3. Serialized to the display.
139-- 4. The cursor is then shown and positioned or kept hidden.
141-- todo: specify possible IO exceptions.
142-- abstract from IO monad to a MonadIO instance.
143output_picture :: MonadIO m => DisplayContext -> Picture -> m ()
144output_picture dc pic = liftIO $ do
145 as <- readIORef (assumed_state_ref $ context_device dc)
146 let manip_cursor = supports_cursor_visibility (context_device dc)
147 let !r = context_region dc
148 !ops = display_ops_for_pic pic r
149 !initial_attr = FixedAttr default_style_mask Nothing Nothing
150 -- Diff the previous output against the requested output. Differences are currently on a per-row
152 -- \todo handle resizes that crop the dominate directions better.
153 diffs :: [Bool] = case prev_output_ops as of
154 Nothing -> replicate (fromEnum $ region_height $ effected_region ops) True
155 Just previous_ops -> if effected_region previous_ops /= effected_region ops
156 then replicate (display_ops_rows ops) True
157 else zipWith (/=) (Vector.toList previous_ops)
159 -- determine the number of bytes required to completely serialize the output ops.
160 total = (if manip_cursor then hide_cursor_required_bytes dc else 0)
161 + default_attr_required_bytes dc
162 + required_bytes dc initial_attr diffs ops
163 + case pic_cursor pic of
164 _ | not manip_cursor -> 0
167 let { m = cursor_output_map ops $ pic_cursor pic; (ox, oy) = char_to_output_pos m ( x, y ) }
168 in show_cursor_required_bytes dc + move_cursor_required_bytes dc ox oy
169 -- ... then serialize
170 allocaBytes (fromEnum total) $ \start_ptr -> do
171 ptr <- case manip_cursor of
172 True -> serialize_hide_cursor dc start_ptr
173 False -> return start_ptr
174 ptr' <- serialize_default_attr dc ptr
175 ptr'' <- serialize_output_ops dc ptr' initial_attr diffs ops
176 end_ptr <- case pic_cursor pic of
177 _ | not manip_cursor -> return ptr''
178 NoCursor -> return ptr''
180 let m = cursor_output_map ops $ pic_cursor pic
181 (ox, oy) = char_to_output_pos m (x,y)
182 serialize_show_cursor dc ptr'' >>= serialize_move_cursor dc ox oy
183 -- todo: How to handle exceptions?
184 -- probably set the prev_output_ops to Nothing
185 case end_ptr `minusPtr` start_ptr of
186 count | count < 0 -> fail "End pointer before start of buffer."
187 | toEnum count > total -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - total)
188 | otherwise -> output_byte_buffer (context_device dc) start_ptr (toEnum count)
189 -- Cache the output spans.
190 let as' = as { prev_output_ops = Just ops }
191 writeIORef (assumed_state_ref $ context_device dc) as'
193required_bytes :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Int
194required_bytes dc in_fattr diffs ops =
195 let (_, n, _, _) = Vector.foldl' required_bytes' (0, 0, in_fattr, diffs) ops
198 required_bytes' (y, current_sum, fattr, True : diffs') span_ops
199 = let (s, fattr') = span_ops_required_bytes dc y fattr span_ops
200 in ( y + 1, s + current_sum, fattr', diffs' )
201 required_bytes' (y, current_sum, fattr, False : diffs') _span_ops
202 = ( y + 1, current_sum, fattr, diffs' )
203 required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops
204 = error "shouldn't be possible"
206span_ops_required_bytes :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Int, FixedAttr)
207span_ops_required_bytes dc y in_fattr span_ops =
208 -- The first operation is to set the cursor to the start of the row
209 let header_required_bytes = move_cursor_required_bytes dc 0 y
210 -- then the span ops are serialized in the order specified
211 in Vector.foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes dc fattr op
212 in (c + current_sum, fattr')
214 (header_required_bytes, in_fattr)
217span_op_required_bytes :: DisplayContext -> FixedAttr -> SpanOp -> (Int, FixedAttr)
218span_op_required_bytes dc fattr (TextSpan attr _ _ str) =
219 let attr' = limit_attr_for_display (context_device dc) attr
220 diffs = display_attr_diffs fattr fattr'
221 c = attr_required_bytes dc fattr attr' diffs
222 fattr' = fix_display_attr fattr attr'
223 in (c + utf8_text_required_bytes (T.encodeUtf8 $ TL.toStrict str), fattr')
224span_op_required_bytes _dc _fattr (Skip _) = error "span_op_required_bytes for Skip."
225span_op_required_bytes dc fattr (RowEnd _) = (row_end_required_bytes dc, fattr)
227serialize_output_ops :: DisplayContext
233serialize_output_ops dc start_ptr in_fattr diffs ops = do
234 (_, end_ptr, _, _) <- Vector.foldM' serialize_output_ops'
235 ( 0, start_ptr, in_fattr, diffs )
239 serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops
240 = serialize_span_ops dc y out_ptr fattr span_ops
241 >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) )
242 serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops
243 = return ( y + 1, out_ptr, fattr, diffs' )
244 serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops
245 = error "shouldn't be possible"
247serialize_span_ops :: DisplayContext
252 -> IO (OutputBuffer, FixedAttr)
253serialize_span_ops dc y out_ptr in_fattr span_ops = do
254 -- The first operation is to set the cursor to the start of the row
255 out_ptr' <- serialize_move_cursor dc 0 y out_ptr
256 -- then the span ops are serialized in the order specified
257 Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op dc op out_ptr'' fattr )
262-- TODO: move this into the terminal implementation?
263serialize_span_op :: DisplayContext
267 -> IO (OutputBuffer, FixedAttr)
268serialize_span_op dc (TextSpan attr _ _ str) out_ptr fattr = do
269 let attr' = limit_attr_for_display (context_device dc) attr
270 fattr' = fix_display_attr fattr attr'
271 diffs = display_attr_diffs fattr fattr'
272 out_ptr' <- serialize_set_attr dc fattr attr' diffs out_ptr
273 out_ptr'' <- serialize_utf8_text (T.encodeUtf8 $ TL.toStrict str) out_ptr'
274 return (out_ptr'', fattr')
275serialize_span_op _dc (Skip _) _out_ptr _fattr = error "serialize_span_op for Skip"
276serialize_span_op dc (RowEnd _) out_ptr fattr = do
277 out_ptr' <- serialize_row_end dc out_ptr
278 return (out_ptr', fattr)
280send_to_terminal :: Output -> Int -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()
281send_to_terminal t c f = allocaBytes (fromEnum c) $ \start_ptr -> do
282 end_ptr <- f start_ptr
283 case end_ptr `minusPtr` start_ptr of
284 count | count < 0 -> fail "End pointer before start pointer."
285 | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c)
286 | otherwise -> output_byte_buffer t start_ptr (toEnum count)
288-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this
289-- needs to be translated to column, row positions.
290data CursorOutputMap = CursorOutputMap
291 { char_to_output_pos :: (Int, Int) -> (Int, Int)
294cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap
295cursor_output_map span_ops _cursor = CursorOutputMap
296 { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)
299cursor_column_offset :: DisplayOps -> Int -> Int -> Int
300cursor_column_offset ops cx cy =
301 let cursor_row_ops = Vector.unsafeIndex ops (fromEnum cy)
303 = Vector.foldl' ( \(d, current_cx, done) op ->
304 if done then (d, current_cx, done) else case span_op_has_width op of
305 Nothing -> (d, current_cx, False)
306 Just (cw, ow) -> case compare cx (current_cx + cw) of
315 LT -> ( d + columns_to_char_offset (cx - current_cx) op
324-- | Not all terminals support all display attributes. This filters a display attribute to what the
325-- given terminal can display.
326limit_attr_for_display :: Output -> Attr -> Attr
327limit_attr_for_display t attr
328 = attr { attr_fore_color = clamp_color $ attr_fore_color attr
329 , attr_back_color = clamp_color $ attr_back_color attr
332 clamp_color Default = Default
333 clamp_color KeepCurrent = KeepCurrent
334 clamp_color (SetTo c) = clamp_color' c
335 clamp_color' (ISOColor v)
336 | context_color_count t < 8 = Default
337 | context_color_count t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
338 | otherwise = SetTo $ ISOColor v
339 clamp_color' (Color240 v)
340 -- TODO: Choose closes ISO color?
341 | context_color_count t < 8 = Default
342 | context_color_count t < 16 = Default
343 | context_color_count t == 240 = SetTo $ Color240 v
345 = let p :: Double = fromIntegral v / 240.0
346 v' = floor $ p * (fromIntegral $ context_color_count t)
347 in SetTo $ Color240 v'
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list