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