git.iko.soy/vty
on 021a059 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 terminalID :: String
34 , releaseTerminal :: 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 , reserveDisplay :: MonadIO m => m ()
50 -- | Return the display to the state before `reserveDisplay`
51 -- If no previous state then set the display state to the initial state.
52 , releaseDisplay :: MonadIO m => m ()
53 -- | Returns the current display bounds.
54 , displayBounds :: MonadIO m => m DisplayRegion
55 -- | Output the byte string to the terminal device.
56 , outputByteBuffer :: BS.ByteString -> IO ()
57 -- | Maximum number of colors supported by the context.
58 , contextColorCount :: Int
59 -- | if the cursor can be shown / hidden
60 , supportsCursorVisibility :: Bool
61 , assumedStateRef :: 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 displayWidth providedWidth, max displayHeight providedHeight)
65 , mkDisplayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
66 }
68displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext
69displayContext t = liftIO . mkDisplayContext t t
71data AssumedState = AssumedState
72 { prevFattr :: Maybe FixedAttr
73 , prevOutputOps :: Maybe DisplayOps
74 }
76initialAssumedState :: AssumedState
77initialAssumedState = AssumedState Nothing Nothing
79data DisplayContext = DisplayContext
80 { contextDevice :: Output
81 -- | Provide the bounds of the display context.
82 , contextRegion :: 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 , writeMoveCursor :: Int -> Int -> Write
86 , writeShowCursor :: Write
87 , writeHideCursor :: 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 , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write
100 -- | Reset the display attributes to the default display attributes
101 , writeDefaultAttr :: Write
102 , writeRowEnd :: Write
103 -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
104 , inlineHack :: IO ()
105 }
107-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.
108writeUtf8Text :: BS.ByteString -> Write
109writeUtf8Text = 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.
125outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
126outputPicture dc pic = liftIO $ do
127 as <- readIORef (assumedStateRef $ contextDevice dc)
128 let manipCursor = supportsCursorVisibility (contextDevice dc)
129 r = contextRegion dc
130 ops = displayOpsForPic pic r
131 initialAttr = FixedAttr defaultStyleMask 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 prevOutputOps as of
136 Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True
137 Just previousOps -> if effectedRegion previousOps /= effectedRegion ops
138 then replicate (displayOpsRows ops) True
139 else zipWith (/=) (Vector.toList previousOps)
140 (Vector.toList ops)
141 -- build the Write corresponding to the output image
142 out = (if manipCursor then writeHideCursor dc else mempty)
143 `mappend` writeDefaultAttr dc
144 `mappend` writeOutputOps dc initialAttr diffs ops
145 `mappend`
146 (case picCursor pic of
147 _ | not manipCursor -> mempty
148 NoCursor -> mempty
149 Cursor x y ->
150 let m = cursorOutputMap ops $ picCursor pic
151 (ox, oy) = charToOutputPos m (x,y)
152 in writeShowCursor dc `mappend` writeMoveCursor dc ox oy
153 )
154 -- ... then serialize
155 outputByteBuffer (contextDevice dc) (writeToByteString out)
156 -- Cache the output spans.
157 let as' = as { prevOutputOps = Just ops }
158 writeIORef (assumedStateRef $ contextDevice dc) as'
160writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
161writeOutputOps dc inFattr diffs ops =
162 let (_, out, _, _) = Vector.foldl' writeOutputOps'
163 (0, mempty, inFattr, diffs)
164 ops
165 in out
166 where
167 writeOutputOps' (y, out, fattr, True : diffs') spanOps
168 = let (spanOut, fattr') = writeSpanOps dc y fattr spanOps
169 in (y+1, out `mappend` spanOut, fattr', diffs')
170 writeOutputOps' (y, out, fattr, False : diffs') _spanOps
171 = (y + 1, out, fattr, diffs')
172 writeOutputOps' (_y, _out, _fattr, []) _spanOps
173 = error "vty - output spans without a corresponding diff."
175writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Write, FixedAttr)
176writeSpanOps dc y inFattr spanOps =
177 -- The first operation is to set the cursor to the start of the row
178 let start = writeMoveCursor dc 0 y
179 -- then the span ops are serialized in the order specified
180 in Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of
181 (opOut, fattr') -> (out `mappend` opOut, fattr')
182 )
183 (start, inFattr)
184 spanOps
186writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
187writeSpanOp dc (TextSpan attr _ _ str) fattr =
188 let attr' = limitAttrForDisplay (contextDevice dc) attr
189 fattr' = fixDisplayAttr fattr attr'
190 diffs = displayAttrDiffs fattr fattr'
191 out = writeSetAttr dc fattr attr' diffs
192 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
193 in (out, fattr')
194writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
195writeSpanOp dc (RowEnd _) fattr = (writeRowEnd 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 { charToOutputPos :: (Int, Int) -> (Int, Int)
201 }
203cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
204cursorOutputMap spanOps _cursor = CursorOutputMap
205 { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)
206 }
208cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
209cursorColumnOffset ops cx cy =
210 let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)
211 (outOffset, _, _)
212 = Vector.foldl' ( \(d, currentCx, done) op ->
213 if done then (d, currentCx, done) else case spanOpHasWidth op of
214 Nothing -> (d, currentCx, False)
215 Just (cw, ow) -> case compare cx (currentCx + cw) of
216 GT -> ( d + ow
217 , currentCx + cw
218 , False
219 )
220 EQ -> ( d + ow
221 , currentCx + cw
222 , True
223 )
224 LT -> ( d + columnsToCharOffset (cx - currentCx) op
225 , currentCx + cw
226 , True
227 )
228 )
229 (0, 0, False)
230 cursorRowOps
231 in outOffset
233-- | Not all terminals support all display attributes. This filters a display attribute to what the
234-- given terminal can display.
235limitAttrForDisplay :: Output -> Attr -> Attr
236limitAttrForDisplay t attr
237 = attr { attrForeColor = clampColor $ attrForeColor attr
238 , attrBackColor = clampColor $ attrBackColor attr
239 }
240 where
241 clampColor Default = Default
242 clampColor KeepCurrent = KeepCurrent
243 clampColor (SetTo c) = clampColor' c
244 clampColor' (ISOColor v)
245 | contextColorCount t < 8 = Default
246 | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
247 | otherwise = SetTo $ ISOColor v
248 clampColor' (Color240 v)
249 -- TODO: Choose closes ISO color?
250 | contextColorCount t < 8 = Default
251 | contextColorCount t < 16 = Default
252 | contextColorCount t == 240 = SetTo $ Color240 v
253 | otherwise
254 = let p :: Double = fromIntegral v / 240.0
255 v' = floor $ p * (fromIntegral $ contextColorCount t)
256 in SetTo $ Color240 v'