git.iko.soy/vty
on faa248d help sign in
vty/src/Graphics/Vty/Output/Interface.hs
256 lines 12 kB history raw
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 #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE FlexibleContexts #-}
8module Graphics.Vty.Output.Interface
9where
11import Graphics.Vty.Prelude
13import Graphics.Vty.Picture
14import Graphics.Vty.PictureToSpans
15import Graphics.Vty.Span
17import Graphics.Vty.DisplayAttributes
19import Blaze.ByteString.Builder (Write, writeToByteString)
20import Blaze.ByteString.Builder.ByteString (writeByteString)
22import Control.Monad.Trans
24import qualified Data.ByteString as BS
25import Data.IORef
26import Data.Monoid (mempty, mappend)
27import qualified Data.Text.Encoding as T
28import qualified Data.Text.Lazy as TL
29import qualified Data.Vector as Vector
31data Output = Output
32 { -- | Text identifier for the output device. Used for debugging.
33 terminal_ID :: String
34 , release_terminal :: MonadIO m => m ()
35 -- | Clear the display and initialize the terminal to some initial display state.
36 --
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 --
40 -- - cursor at top left
41 -- - UTF-8 character encoding
42 -- - drawing characteristics are the default
43 --
44 -- The abstract operation I think all these behaviors are instances of is reserving exclusive
45 -- access to a display such that:
46 --
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 string to the terminal device.
56 , output_byte_buffer :: BS.ByteString -> IO ()
57 -- | Maximum number of colors supported by the context.
58 , context_color_count :: Int
59 -- | if the cursor can be shown / hidden
60 , supports_cursor_visibility :: Bool
61 , assumed_state_ref :: IORef AssumedState
62 -- | Acquire display access to the given region of the display.
63 -- Currently all regions have the upper left corner of (0,0) and the lower right corner at
64 -- (max display_width provided_width, max display_height provided_height)
65 , mk_display_context :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
66 }
68display_context :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
69display_context t = liftIO . mk_display_context t t
71data AssumedState = AssumedState
72 { prev_fattr :: Maybe FixedAttr
73 , prev_output_ops :: Maybe DisplayOps
74 }
76initial_assumed_state :: AssumedState
77initial_assumed_state = AssumedState Nothing Nothing
79data DisplayContext = DisplayContext
80 { context_device :: Output
81 -- | Provide the bounds of the display context.
82 , context_region :: DisplayRegion
83 -- | sets the output position to the specified row and column. Where the number of bytes
84 -- required for the control codes can be specified seperate from the actual byte sequence.
85 , write_move_cursor :: Int -> Int -> Write
86 , write_show_cursor :: Write
87 , write_hide_cursor :: Write
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.
93 --
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 , write_set_attr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
100 -- | Reset the display attributes to the default display attributes
101 , write_default_attr :: Write
102 , write_row_end :: Write
103 -- | See Graphics.Vty.Output.XTermColor.inline_hack
104 , inline_hack :: IO ()
105 }
107-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
108write_utf8_text :: BS.ByteString -> Write
109write_utf8_text = writeByteString
111-- | Displays the given `Picture`.
112--
113-- 0. The image is cropped to the display size.
114--
115-- 1. Converted into a sequence of attribute changes and text spans.
116--
117-- 2. The cursor is hidden.
118--
119-- 3. Serialized to the display.
120--
121-- 4. The cursor is then shown and positioned or kept hidden.
122--
123-- todo: specify possible IO exceptions.
124-- abstract from IO monad to a MonadIO instance.
125output_picture :: MonadIO m => DisplayContext -> Picture -> m ()
126output_picture dc pic = liftIO $ do
127 as <- readIORef (assumed_state_ref $ context_device dc)
128 let manip_cursor = supports_cursor_visibility (context_device dc)
129 r = context_region dc
130 ops = display_ops_for_pic pic r
131 initial_attr = FixedAttr default_style_mask Nothing Nothing
132 -- Diff the previous output against the requested output. Differences are currently on a per-row
133 -- basis.
134 -- \todo handle resizes that crop the dominate directions better.
135 diffs :: [Bool] = case prev_output_ops as of
136 Nothing -> replicate (fromEnum $ region_height $ effected_region ops) True
137 Just previous_ops -> if effected_region previous_ops /= effected_region ops
138 then replicate (display_ops_rows ops) True
139 else zipWith (/=) (Vector.toList previous_ops)
140 (Vector.toList ops)
141 -- build the Write corresponding to the output image
142 out = (if manip_cursor then write_hide_cursor dc else mempty)
143 `mappend` write_default_attr dc
144 `mappend` write_output_ops dc initial_attr diffs ops
145 `mappend`
146 (case pic_cursor pic of
147 _ | not manip_cursor -> mempty
148 NoCursor -> mempty
149 Cursor x y ->
150 let m = cursor_output_map ops $ pic_cursor pic
151 (ox, oy) = char_to_output_pos m (x,y)
152 in write_show_cursor dc `mappend` write_move_cursor dc ox oy
153 )
154 -- ... then serialize
155 output_byte_buffer (context_device dc) (writeToByteString out)
156 -- Cache the output spans.
157 let as' = as { prev_output_ops = Just ops }
158 writeIORef (assumed_state_ref $ context_device dc) as'
160write_output_ops :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
161write_output_ops dc in_fattr diffs ops =
162 let (_, out, _, _) = Vector.foldl' write_output_ops'
163 (0, mempty, in_fattr, diffs)
164 ops
165 in out
166 where
167 write_output_ops' (y, out, fattr, True : diffs') span_ops
168 = let (span_out, fattr') = write_span_ops dc y fattr span_ops
169 in (y+1, out `mappend` span_out, fattr', diffs')
170 write_output_ops' (y, out, fattr, False : diffs') _span_ops
171 = (y + 1, out, fattr, diffs')
172 write_output_ops' (_y, _out, _fattr, []) _span_ops
173 = error "vty - output spans without a corresponding diff."
175write_span_ops :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Write, FixedAttr)
176write_span_ops dc y in_fattr span_ops =
177 -- The first operation is to set the cursor to the start of the row
178 let start = write_move_cursor dc 0 y
179 -- then the span ops are serialized in the order specified
180 in Vector.foldl' (\(out, fattr) op -> case write_span_op dc op fattr of
181 (op_out, fattr') -> (out `mappend` op_out, fattr')
182 )
183 (start, in_fattr)
184 span_ops
186write_span_op :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
187write_span_op dc (TextSpan attr _ _ str) fattr =
188 let attr' = limit_attr_for_display (context_device dc) attr
189 fattr' = fix_display_attr fattr attr'
190 diffs = display_attr_diffs fattr fattr'
191 out = write_set_attr dc fattr attr' diffs
192 `mappend` write_utf8_text (T.encodeUtf8 $ TL.toStrict str)
193 in (out, fattr')
194write_span_op _dc (Skip _) _fattr = error "serialize_span_op for Skip"
195write_span_op dc (RowEnd _) fattr = (write_row_end dc, fattr)
197-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this
198-- needs to be translated to column, row positions.
199data CursorOutputMap = CursorOutputMap
200 { char_to_output_pos :: (Int, Int) -> (Int, Int)
201 }
203cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap
204cursor_output_map span_ops _cursor = CursorOutputMap
205 { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)
206 }
208cursor_column_offset :: DisplayOps -> Int -> Int -> Int
209cursor_column_offset ops cx cy =
210 let cursor_row_ops = Vector.unsafeIndex ops (fromEnum cy)
211 (out_offset, _, _)
212 = Vector.foldl' ( \(d, current_cx, done) op ->
213 if done then (d, current_cx, done) else case span_op_has_width op of
214 Nothing -> (d, current_cx, False)
215 Just (cw, ow) -> case compare cx (current_cx + cw) of
216 GT -> ( d + ow
217 , current_cx + cw
218 , False
219 )
220 EQ -> ( d + ow
221 , current_cx + cw
222 , True
223 )
224 LT -> ( d + columns_to_char_offset (cx - current_cx) op
225 , current_cx + cw
226 , True
227 )
228 )
229 (0, 0, False)
230 cursor_row_ops
231 in out_offset
233-- | Not all terminals support all display attributes. This filters a display attribute to what the
234-- given terminal can display.
235limit_attr_for_display :: Output -> Attr -> Attr
236limit_attr_for_display t attr
237 = attr { attr_fore_color = clamp_color $ attr_fore_color attr
238 , attr_back_color = clamp_color $ attr_back_color attr
239 }
240 where
241 clamp_color Default = Default
242 clamp_color KeepCurrent = KeepCurrent
243 clamp_color (SetTo c) = clamp_color' c
244 clamp_color' (ISOColor v)
245 | context_color_count t < 8 = Default
246 | context_color_count t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
247 | otherwise = SetTo $ ISOColor v
248 clamp_color' (Color240 v)
249 -- TODO: Choose closes ISO color?
250 | context_color_count t < 8 = Default
251 | context_color_count t < 16 = Default
252 | context_color_count t == 240 = SetTo $ Color240 v
253 | otherwise
254 = let p :: Double = fromIntegral v / 240.0
255 v' = floor $ p * (fromIntegral $ context_color_count t)
256 in SetTo $ Color240 v'