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