git.iko.soy/vty
on ebee723 help sign in
vty/src/Graphics/Vty/Output/Interface.hs
295 lines 13 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 #-}
9module Graphics.Vty.Output.Interface
10 ( Output(..)
11 , AssumedState(..)
12 , DisplayContext(..)
13 , Mode(..)
14 , displayContext
15 , outputPicture
16 , initialAssumedState
17 , limitAttrForDisplay
18 )
19where
21import Graphics.Vty.Attributes
22import Graphics.Vty.Image (DisplayRegion, regionHeight)
23import Graphics.Vty.Picture
24import Graphics.Vty.PictureToSpans
25import Graphics.Vty.Span
27import Graphics.Vty.DisplayAttributes
29import Blaze.ByteString.Builder (Write, writeToByteString)
30import Blaze.ByteString.Builder.ByteString (writeByteString)
32import Control.Monad.Trans
34import qualified Data.ByteString as BS
35import Data.IORef
36import qualified Data.Text.Encoding as T
37import qualified Data.Text.Lazy as TL
38import qualified Data.Vector as Vector
40-- | Modal terminal features that can be enabled and disabled.
41data Mode = Mouse
42 | BracketedPaste
43 deriving (Eq, Read, Show)
45data Output = Output
46 { -- | Text identifier for the output device. Used for debugging.
47 terminalID :: String
48 , releaseTerminal :: forall m. MonadIO m => m ()
49 -- | Clear the display and initialize the terminal to some initial
50 -- display state.
51 --
52 -- The expectation of a program is that the display starts in some
53 -- The initial state. initial state would consist of fixed values:
54 --
55 -- - cursor at top left
56 -- - UTF-8 character encoding
57 -- - drawing characteristics are the default
58 --
59 -- The abstract operation I think all these behaviors are instances
60 -- of is reserving exclusive access to a display such that:
61 --
62 -- - The previous state cannot be determined
63 -- - When exclusive access to a display is released the display
64 -- returns to the previous state.
65 , reserveDisplay :: forall m. MonadIO m => m ()
66 -- | Return the display to the state before `reserveDisplay`
67 -- If no previous state then set the display state to the initial
68 -- state.
69 , releaseDisplay :: forall m. MonadIO m => m ()
70 -- | Returns the current display bounds.
71 , displayBounds :: forall m. MonadIO m => m DisplayRegion
72 -- | Output the byte string to the terminal device.
73 , outputByteBuffer :: BS.ByteString -> IO ()
74 -- | Maximum number of colors supported by the context.
75 , contextColorCount :: Int
76 -- | if the cursor can be shown / hidden
77 , supportsCursorVisibility :: Bool
78 -- | Indicates support for terminal modes for this output device
79 , supportsMode :: Mode -> Bool
80 -- | Enables or disables a mode (does nothing if the mode is
81 -- unsupported)
82 , setMode :: forall m. MonadIO m => Mode -> Bool -> m ()
83 -- | Returns whether a mode is enabled
84 , getModeStatus :: forall m. MonadIO m => Mode -> m Bool
85 , assumedStateRef :: IORef AssumedState
86 -- | Acquire display access to the given region of the display.
87 -- Currently all regions have the upper left corner of (0,0) and
88 -- the lower right corner at (max displayWidth providedWidth, max
89 -- displayHeight providedHeight)
90 , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext
91 -- | Ring the terminal bell if supported.
92 , ringTerminalBell :: forall m. MonadIO m => m ()
93 -- | Returns whether the terminal has an audio bell feature.
94 , supportsBell :: forall m. MonadIO m => m Bool
95 }
97displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
98displayContext t = liftIO . mkDisplayContext t t
100data AssumedState = AssumedState
101 { prevFattr :: Maybe FixedAttr
102 , prevOutputOps :: Maybe DisplayOps
103 }
105initialAssumedState :: AssumedState
106initialAssumedState = AssumedState Nothing Nothing
108data DisplayContext = DisplayContext
109 { contextDevice :: Output
110 -- | Provide the bounds of the display context.
111 , contextRegion :: DisplayRegion
112 -- | sets the output position to the specified row and column.
113 -- Where the number of bytes required for the control codes can be
114 -- specified seperate from the actual byte sequence.
115 , writeMoveCursor :: Int -> Int -> Write
116 , writeShowCursor :: Write
117 , writeHideCursor :: Write
118 -- | Assure the specified output attributes will be applied to
119 -- all the following text until the next output attribute change.
120 -- Where the number of bytes required for the control codes can be
121 -- specified seperate from the actual byte sequence. The required
122 -- number of bytes must be at least the maximum number of bytes
123 -- required by any attribute changes. The serialization equations
124 -- must provide the ptr to the next byte to be specified in the
125 -- output buffer.
126 --
127 -- The currently applied display attributes are provided as well.
128 -- The Attr data type can specify the style or color should not be
129 -- changed from the currently applied display attributes. In order
130 -- to support this the currently applied display attributes are
131 -- required. In addition it may be possible to optimize the state
132 -- changes based off the currently applied display attributes.
133 , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
134 -- | Reset the display attributes to the default display attributes
135 , writeDefaultAttr :: Write
136 , writeRowEnd :: Write
137 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
138 , inlineHack :: IO ()
139 }
141-- | All terminals serialize UTF8 text to the terminal device exactly as
142-- serialized in memory.
143writeUtf8Text :: BS.ByteString -> Write
144writeUtf8Text = writeByteString
146-- | Displays the given `Picture`.
147--
148-- 0. The image is cropped to the display size.
149--
150-- 1. Converted into a sequence of attribute changes and text spans.
151--
152-- 2. The cursor is hidden.
153--
154-- 3. Serialized to the display.
155--
156-- 4. The cursor is then shown and positioned or kept hidden.
157outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
158outputPicture dc pic = liftIO $ do
159 as <- readIORef (assumedStateRef $ contextDevice dc)
160 let manipCursor = supportsCursorVisibility (contextDevice dc)
161 r = contextRegion dc
162 ops = displayOpsForPic pic r
163 initialAttr = FixedAttr defaultStyleMask Nothing Nothing
164 -- Diff the previous output against the requested output.
165 -- Differences are currently on a per-row basis.
166 diffs :: [Bool] = case prevOutputOps as of
167 Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True
168 Just previousOps -> if effectedRegion previousOps /= effectedRegion ops
169 then replicate (displayOpsRows ops) True
170 else zipWith (/=) (Vector.toList previousOps)
171 (Vector.toList ops)
172 -- build the Write corresponding to the output image
173 out = (if manipCursor then writeHideCursor dc else mempty)
174 `mappend` writeOutputOps dc initialAttr diffs ops
175 `mappend`
176 (let (w,h) = contextRegion dc
177 clampX = max 0 . min (w-1)
178 clampY = max 0 . min (h-1) in
179 case picCursor pic of
180 _ | not manipCursor -> mempty
181 NoCursor -> mempty
182 AbsoluteCursor x y ->
183 writeShowCursor dc `mappend`
184 writeMoveCursor dc (clampX x) (clampY y)
185 Cursor x y ->
186 let m = cursorOutputMap ops $ picCursor pic
187 (ox, oy) = charToOutputPos m (x,y)
188 in writeShowCursor dc `mappend`
189 writeMoveCursor dc (clampX ox) (clampY oy)
190 )
191 -- ... then serialize
192 outputByteBuffer (contextDevice dc) (writeToByteString out)
193 -- Cache the output spans.
194 let as' = as { prevOutputOps = Just ops }
195 writeIORef (assumedStateRef $ contextDevice dc) as'
197writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
198writeOutputOps dc initialAttr diffs ops =
199 let (_, out, _) = Vector.foldl' writeOutputOps'
200 (0, mempty, diffs)
201 ops
202 in out
203 where
204 writeOutputOps' (y, out, True : diffs') spanOps
205 = let spanOut = writeSpanOps dc y initialAttr spanOps
206 out' = out `mappend` spanOut
207 in (y+1, out', diffs')
208 writeOutputOps' (y, out, False : diffs') _spanOps
209 = (y + 1, out, diffs')
210 writeOutputOps' (_y, _out, []) _spanOps
211 = error "vty - output spans without a corresponding diff."
213writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
214writeSpanOps dc y initialAttr spanOps =
215 -- The first operation is to set the cursor to the start of the row
216 let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc
217 -- then the span ops are serialized in the order specified
218 in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of
219 (opOut, fattr') -> (out `mappend` opOut, fattr')
220 )
221 (start, initialAttr)
222 spanOps
224writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
225writeSpanOp dc (TextSpan attr _ _ str) fattr =
226 let attr' = limitAttrForDisplay (contextDevice dc) attr
227 fattr' = fixDisplayAttr fattr attr'
228 diffs = displayAttrDiffs fattr fattr'
229 out = writeSetAttr dc fattr attr' diffs
230 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
231 in (out, fattr')
232writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
233writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)
235-- | The cursor position is given in X,Y character offsets. Due to
236-- multi-column characters this needs to be translated to column, row
237-- positions.
238data CursorOutputMap = CursorOutputMap
239 { charToOutputPos :: (Int, Int) -> (Int, Int)
240 }
242cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
243cursorOutputMap spanOps _cursor = CursorOutputMap
244 { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)
245 }
247cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
248cursorColumnOffset ops cx cy =
249 let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)
250 (outOffset, _, _)
251 = Vector.foldl' ( \(d, currentCx, done) op ->
252 if done then (d, currentCx, done) else case spanOpHasWidth op of
253 Nothing -> (d, currentCx, False)
254 Just (cw, ow) -> case compare cx (currentCx + cw) of
255 GT -> ( d + ow
256 , currentCx + cw
257 , False
258 )
259 EQ -> ( d + ow
260 , currentCx + cw
261 , True
262 )
263 LT -> ( d + columnsToCharOffset (cx - currentCx) op
264 , currentCx + cw
265 , True
266 )
267 )
268 (0, 0, False)
269 cursorRowOps
270 in outOffset
272-- | Not all terminals support all display attributes. This filters a
273-- display attribute to what the given terminal can display.
274limitAttrForDisplay :: Output -> Attr -> Attr
275limitAttrForDisplay t attr
276 = attr { attrForeColor = clampColor $ attrForeColor attr
277 , attrBackColor = clampColor $ attrBackColor attr
278 }
279 where
280 clampColor Default = Default
281 clampColor KeepCurrent = KeepCurrent
282 clampColor (SetTo c) = clampColor' c
283 clampColor' (ISOColor v)
284 | contextColorCount t < 8 = Default
285 | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
286 | otherwise = SetTo $ ISOColor v
287 clampColor' (Color240 v)
288 -- Should we choose closest ISO color?
289 | contextColorCount t < 8 = Default
290 | contextColorCount t < 16 = Default
291 | contextColorCount t <= 256 = SetTo $ Color240 v
292 | otherwise
293 = let p :: Double = fromIntegral v / 240.0
294 v' = floor $ p * (fromIntegral $ contextColorCount t)
295 in SetTo $ Color240 v'