1-- Copyright Corey O'Connor
2-- General philosophy is: MonadIO is for equations exposed to clients.
3{-# LANGUAGE BangPatterns #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ExistentialQuantification #-}
8{-# LANGUAGE FlexibleContexts #-}
9module Graphics.Vty.Terminal.Interface ( module Graphics.Vty.Terminal.Interface
14import Data.Marshalling
16import Graphics.Vty.Picture
17import Graphics.Vty.PictureToSpans
18import Graphics.Vty.Span
19import Graphics.Vty.DisplayRegion
21import Graphics.Vty.DisplayAttributes
23import Control.Monad.Trans
25import qualified Data.ByteString.Internal as BS
27import qualified Data.Vector as Vector
29data Terminal = Terminal
30 { -- | Text identifier for the terminal. Used for debugging.
32 , release_terminal :: MonadIO m => m ()
33 -- | Clear the display and initialize the terminal to some initial display state.
35 -- The expectation of a program is that the display starts in some initial state.
36 -- The initial state would consist of fixed values:
37 -- - cursor at top left
38 -- - UTF-8 character encoding
39 -- - drawing characteristics are the default
40 -- The abstract operation I think all these behaviors are instances of is reserving exclusive
41 -- access to a display such that:
42 -- - The previous state cannot be determined
43 -- - When exclusive access to a display is released the display returns to the previous state.
44 , reserve_display :: MonadIO m => m ()
45 -- | Return the display to the state before reserve_display
46 -- If no previous state then set the display state to the initial state.
47 , release_display :: MonadIO m => m ()
48 -- | Returns the current display bounds.
49 , display_bounds :: MonadIO m => m DisplayRegion
50 -- | Output the byte buffer of the specified size to the terminal device. The size is equal to
51 -- end_ptr - start_ptr
52 , output_byte_buffer :: OutputBuffer -> Int -> IO ()
53 -- | Maximum number of colors supported by the context.
54 , context_color_count :: Int
55 -- | if the cursor can be shown / hidden
56 , supports_cursor_visibility :: Bool
57 , assumed_state_ref :: IORef AssumedState
58 -- | Acquire display access to the given region of the display.
59 -- Currently all regions have the upper left corner of (0,0) and the lower right corner at
60 -- (max display_width provided_width, max display_height provided_height)
61 , mk_display_context :: MonadIO m => Terminal -> DisplayRegion -> m DisplayContext
64display_context :: MonadIO m => Terminal -> DisplayRegion -> m DisplayContext
65display_context t = liftIO . mk_display_context t t
67data AssumedState = AssumedState
68 { prev_fattr :: Maybe FixedAttr
69 , prev_output_ops :: Maybe DisplayOps
72initial_assumed_state :: AssumedState
73initial_assumed_state = AssumedState Nothing Nothing
75data DisplayContext = DisplayContext
76 { context_device :: Terminal
77 -- | Provide the bounds of the display context.
78 , context_region :: DisplayRegion
79 -- | sets the output position to the specified row and column. Where the number of bytes
80 -- required for the control codes can be specified seperate from the actual byte sequence.
81 , move_cursor_required_bytes :: Int -> Int -> Int
82 , serialize_move_cursor :: Int -> Int -> OutputBuffer -> IO OutputBuffer
83 , show_cursor_required_bytes :: Int
84 , serialize_show_cursor :: OutputBuffer -> IO OutputBuffer
85 , hide_cursor_required_bytes :: Int
86 , serialize_hide_cursor :: OutputBuffer -> IO OutputBuffer
87 -- | Assure the specified output attributes will be applied to all the following text until the
88 -- next output attribute change. Where the number of bytes required for the control codes can
89 -- be specified seperate from the actual byte sequence. The required number of bytes must be
90 -- at least the maximum number of bytes required by any attribute changes. The serialization
91 -- equations must provide the ptr to the next byte to be specified in the output buffer.
93 -- The currently applied display attributes are provided as well. The Attr data type can
94 -- specify the style or color should not be changed from the currently applied display
95 -- attributes. In order to support this the currently applied display attributes are required.
96 -- In addition it may be possible to optimize the state changes based off the currently applied
97 -- display attributes.
98 , attr_required_bytes :: FixedAttr -> Attr -> DisplayAttrDiff -> Int
99 , serialize_set_attr :: FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> IO OutputBuffer
100 -- | Reset the display attributes to the default display attributes
101 , default_attr_required_bytes :: Int
102 , serialize_default_attr :: OutputBuffer -> IO OutputBuffer
103 , row_end_required_bytes :: Int
104 , serialize_row_end :: OutputBuffer -> IO OutputBuffer
105 -- | See Graphics.Vty.Terminal.XTermColor.inline_hack
106 , inline_hack :: IO ()
109-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
110utf8_text_required_bytes :: BS.ByteString -> Int
111utf8_text_required_bytes str =
112 let (_, _, src_bytes_length) = BS.toForeignPtr str
115-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
116serialize_utf8_text :: BS.ByteString -> OutputBuffer -> IO OutputBuffer
117serialize_utf8_text str dest_ptr =
118 let (src_fptr, src_ptr_offset, src_bytes_length) = BS.toForeignPtr str
119 in withForeignPtr src_fptr $ \src_ptr -> do
120 let src_ptr' = src_ptr `plusPtr` src_ptr_offset
121 BS.memcpy dest_ptr src_ptr' (toEnum src_bytes_length)
122 return (dest_ptr `plusPtr` src_bytes_length)
124-- | Displays the given `Picture`.
126-- 0. The image is cropped to the display size.
128-- 1. Converted into a sequence of attribute changes and text spans.
130-- 2. The cursor is hidden.
132-- 3. Serialized to the display.
134-- 4. The cursor is then shown and positioned or kept hidden.
136-- todo: specify possible IO exceptions.
137-- abstract from IO monad to a MonadIO instance.
138output_picture :: MonadIO m => DisplayContext -> Picture -> m ()
139output_picture dc pic = liftIO $ do
140 as <- readIORef (assumed_state_ref $ context_device dc)
141 let manip_cursor = supports_cursor_visibility (context_device dc)
142 let !r = context_region dc
143 !ops = display_ops_for_pic pic r
144 !initial_attr = FixedAttr default_style_mask Nothing Nothing
145 -- Diff the previous output against the requested output. Differences are currently on a per-row
147 -- \todo handle resizes that crop the dominate directions better.
148 diffs :: [Bool] = case prev_output_ops as of
149 Nothing -> replicate (fromEnum $ region_height $ effected_region ops) True
150 Just previous_ops -> if effected_region previous_ops /= effected_region ops
151 then replicate (display_ops_rows ops) True
152 else zipWith (/=) (Vector.toList previous_ops)
154 -- determine the number of bytes required to completely serialize the output ops.
155 total = (if manip_cursor then hide_cursor_required_bytes dc else 0)
156 + default_attr_required_bytes dc
157 + required_bytes dc initial_attr diffs ops
158 + case pic_cursor pic of
159 _ | not manip_cursor -> 0
162 let { m = cursor_output_map ops $ pic_cursor pic; (ox, oy) = char_to_output_pos m ( x, y ) }
163 in show_cursor_required_bytes dc + move_cursor_required_bytes dc ox oy
164 -- ... then serialize
165 allocaBytes (fromEnum total) $ \start_ptr -> do
166 ptr <- case manip_cursor of
167 True -> serialize_hide_cursor dc start_ptr
168 False -> return start_ptr
169 ptr' <- serialize_default_attr dc ptr
170 ptr'' <- serialize_output_ops dc ptr' initial_attr diffs ops
171 end_ptr <- case pic_cursor pic of
172 _ | not manip_cursor -> return ptr''
173 NoCursor -> return ptr''
175 let m = cursor_output_map ops $ pic_cursor pic
176 (ox, oy) = char_to_output_pos m (x,y)
177 serialize_show_cursor dc ptr'' >>= serialize_move_cursor dc ox oy
178 -- todo: How to handle exceptions?
179 -- probably set the prev_output_ops to Nothing
180 case end_ptr `minusPtr` start_ptr of
181 count | count < 0 -> fail "End pointer before start of buffer."
182 | toEnum count > total -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - total)
183 | otherwise -> output_byte_buffer (context_device dc) start_ptr (toEnum count)
184 -- Cache the output spans.
185 let as' = as { prev_output_ops = Just ops }
186 writeIORef (assumed_state_ref $ context_device dc) as'
188required_bytes :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Int
189required_bytes dc in_fattr diffs ops =
190 let (_, n, _, _) = Vector.foldl' required_bytes' (0, 0, in_fattr, diffs) ops
193 required_bytes' (y, current_sum, fattr, True : diffs') span_ops
194 = let (s, fattr') = span_ops_required_bytes dc y fattr span_ops
195 in ( y + 1, s + current_sum, fattr', diffs' )
196 required_bytes' (y, current_sum, fattr, False : diffs') _span_ops
197 = ( y + 1, current_sum, fattr, diffs' )
198 required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops
199 = error "shouldn't be possible"
201span_ops_required_bytes :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Int, FixedAttr)
202span_ops_required_bytes dc y in_fattr span_ops =
203 -- The first operation is to set the cursor to the start of the row
204 let header_required_bytes = move_cursor_required_bytes dc 0 y
205 -- then the span ops are serialized in the order specified
206 in Vector.foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes dc fattr op
207 in (c + current_sum, fattr')
209 (header_required_bytes, in_fattr)
212span_op_required_bytes :: DisplayContext -> FixedAttr -> SpanOp -> (Int, FixedAttr)
213span_op_required_bytes dc fattr (AttributeChange attr) =
214 let attr' = limit_attr_for_display (context_device dc) attr
215 diffs = display_attr_diffs fattr fattr'
216 c = attr_required_bytes dc fattr attr' diffs
217 fattr' = fix_display_attr fattr attr'
219span_op_required_bytes _dc fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)
220span_op_required_bytes _dc _fattr (Skip _) = error "span_op_required_bytes for Skip."
221span_op_required_bytes dc fattr (RowEnd _) = (row_end_required_bytes dc, fattr)
223serialize_output_ops :: DisplayContext
229serialize_output_ops dc start_ptr in_fattr diffs ops = do
230 (_, end_ptr, _, _) <- Vector.foldM' serialize_output_ops'
231 ( 0, start_ptr, in_fattr, diffs )
235 serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops
236 = serialize_span_ops dc y out_ptr fattr span_ops
237 >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) )
238 serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops
239 = return ( y + 1, out_ptr, fattr, diffs' )
240 serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops
241 = error "shouldn't be possible"
243serialize_span_ops :: DisplayContext
248 -> IO (OutputBuffer, FixedAttr)
249serialize_span_ops dc y out_ptr in_fattr span_ops = do
250 -- The first operation is to set the cursor to the start of the row
251 out_ptr' <- serialize_move_cursor dc 0 y out_ptr
252 -- then the span ops are serialized in the order specified
253 Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op dc op out_ptr'' fattr )
258-- TODO: move this into the terminal implementation?
259serialize_span_op :: DisplayContext
263 -> IO (OutputBuffer, FixedAttr)
264serialize_span_op dc (AttributeChange attr) out_ptr fattr = do
265 let attr' = limit_attr_for_display (context_device dc) attr
266 fattr' = fix_display_attr fattr attr'
267 diffs = display_attr_diffs fattr fattr'
268 out_ptr' <- serialize_set_attr dc fattr attr' diffs out_ptr
269 return (out_ptr', fattr')
270serialize_span_op _dc (TextSpan _ _ str) out_ptr fattr = do
271 out_ptr' <- serialize_utf8_text str out_ptr
272 return (out_ptr', fattr)
273serialize_span_op _dc (Skip _) _out_ptr _fattr = error "serialize_span_op for Skip"
274serialize_span_op dc (RowEnd _) out_ptr fattr = do
275 out_ptr' <- serialize_row_end dc out_ptr
276 return (out_ptr', fattr)
278send_to_terminal :: Terminal -> Int -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()
279send_to_terminal t c f = allocaBytes (fromEnum c) $ \start_ptr -> do
280 end_ptr <- f start_ptr
281 case end_ptr `minusPtr` start_ptr of
282 count | count < 0 -> fail "End pointer before start pointer."
283 | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c)
284 | otherwise -> output_byte_buffer t start_ptr (toEnum count)
286-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this
287-- needs to be translated to column, row positions.
288data CursorOutputMap = CursorOutputMap
289 { char_to_output_pos :: (Int, Int) -> (Int, Int)
292cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap
293cursor_output_map span_ops _cursor = CursorOutputMap
294 { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)
297cursor_column_offset :: DisplayOps -> Int -> Int -> Int
298cursor_column_offset ops cx cy =
299 let cursor_row_ops = Vector.unsafeIndex ops (fromEnum cy)
301 = Vector.foldl' ( \(d, current_cx, done) op ->
302 if done then (d, current_cx, done) else case span_op_has_width op of
303 Nothing -> (d, current_cx, False)
304 Just (cw, ow) -> case compare cx (current_cx + cw) of
313 LT -> ( d + columns_to_char_offset (cx - current_cx) op
322-- | Not all terminals support all display attributes. This filters a display attribute to what the
323-- given terminal can display.
324limit_attr_for_display :: Terminal -> Attr -> Attr
325limit_attr_for_display t attr
326 = attr { attr_fore_color = clamp_color $ attr_fore_color attr
327 , attr_back_color = clamp_color $ attr_back_color attr
330 clamp_color Default = Default
331 clamp_color KeepCurrent = KeepCurrent
332 clamp_color (SetTo c) = clamp_color' c
333 clamp_color' (ISOColor v)
334 | context_color_count t < 8 = Default
335 | context_color_count t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
336 | otherwise = SetTo $ ISOColor v
337 clamp_color' (Color240 v)
338 -- TODO: Choose closes ISO color?
339 | context_color_count t < 8 = Default
340 | context_color_count t < 16 = Default
341 | context_color_count t == 240 = SetTo $ Color240 v
343 = let p :: Double = fromIntegral v / 240.0
344 v' = floor $ p * (fromIntegral $ context_color_count t)
345 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