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