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