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