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