git.iko.soy/vty
on master help sign in
Resolve #76. Terminfo "clear to end of line" does not mean what I thought it means.
cceeeeeCorey O'Connor
src/Graphics/Vty/Output/Interface.hs+19−19
compare with master
unifiedsplit
@@ -149,7 +149,6 @@ outputPicture dc pic = liftIO $ do
149 (Vector.toList ops)
149 (Vector.toList ops)
150 -- build the Write corresponding to the output image
150 -- build the Write corresponding to the output image
151 out = (if manipCursor then writeHideCursor dc else mempty)
151 out = (if manipCursor then writeHideCursor dc else mempty)
152− `mappend` writeDefaultAttr dc
153 `mappend` writeOutputOps dc initialAttr diffs ops
152 `mappend` writeOutputOps dc initialAttr diffs ops
154 `mappend`
153 `mappend`
155 (case picCursor pic of
154 (case picCursor pic of
@@ -167,30 +166,31 @@ outputPicture dc pic = liftIO $ do
167 writeIORef (assumedStateRef $ contextDevice dc) as'
166 writeIORef (assumedStateRef $ contextDevice dc) as'
168
167
169writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
168writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
170−writeOutputOps dc inFattr diffs ops =
169+writeOutputOps dc initialAttr diffs ops =
171− let (_, out, _, _) = Vector.foldl' writeOutputOps'
170+ let (_, out, _) = Vector.foldl' writeOutputOps'
172− (0, mempty, inFattr, diffs)
171+ (0, mempty, diffs)
173 ops
172 ops
174 in out
173 in out
175 where
174 where
176− writeOutputOps' (y, out, fattr, True : diffs') spanOps
175+ writeOutputOps' (y, out, True : diffs') spanOps
177− = let (spanOut, fattr') = writeSpanOps dc y fattr spanOps
176+ = let spanOut = writeSpanOps dc y initialAttr spanOps
177+ out' = out `mappend` spanOut
178− in (y+1, out `mappend` spanOut, fattr', diffs')
178+ in (y+1, out', diffs')
179− writeOutputOps' (y, out, fattr, False : diffs') _spanOps
179+ writeOutputOps' (y, out, False : diffs') _spanOps
180− = (y + 1, out, fattr, diffs')
180+ = (y + 1, out, diffs')
181− writeOutputOps' (_y, _out, _fattr, []) _spanOps
181+ writeOutputOps' (_y, _out, []) _spanOps
182 = error "vty - output spans without a corresponding diff."
182 = error "vty - output spans without a corresponding diff."
183
183
184−writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Write, FixedAttr)
184+writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
185−writeSpanOps dc y inFattr spanOps =
185+writeSpanOps dc y initialAttr spanOps =
186 -- The first operation is to set the cursor to the start of the row
186 -- The first operation is to set the cursor to the start of the row
187− let start = writeMoveCursor dc 0 y
187+ let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc
188 -- then the span ops are serialized in the order specified
188 -- then the span ops are serialized in the order specified
189− in Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of
189+ in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of
190− (opOut, fattr') -> (out `mappend` opOut, fattr')
190+ (opOut, fattr') -> (out `mappend` opOut, fattr')
191− )
191+ )
192− (start, inFattr)
192+ (start, initialAttr)
193− spanOps
193+ spanOps
194
194
195writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
195writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
196writeSpanOp dc (TextSpan attr _ _ str) fattr =
196writeSpanOp dc (TextSpan attr _ _ str) fattr =
@@ -201,7 +201,7 @@ writeSpanOp dc (TextSpan attr _ _ str) fattr =
201 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
201 `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
202 in (out, fattr')
202 in (out, fattr')
203writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
203writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip"
204−writeSpanOp dc (RowEnd _) fattr = (writeRowEnd dc, fattr)
204+writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr)
205
205
206-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this
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.
207-- needs to be translated to column, row positions.
src/Graphics/Vty/PictureToSpans.hs+1−2
@@ -221,8 +221,7 @@ buildSpans image outRegion = do
221 return ()
221 return ()
222 return outOps
222 return outOps
223
223
224−-- | Add the operations required to build a given image to the current set of row operations
224+-- | Add the operations required to build a given image to the current set of row operations.
225−-- returns the number of columns and rows contributed to the output.
226startImageBuild :: Image -> BlitM s ()
225startImageBuild :: Image -> BlitM s ()
227startImageBuild image = do
226startImageBuild image = do
228 outOfBounds <- isOutOfBounds image <$> get
227 outOfBounds <- isOutOfBounds image <$> get
test/interactive_terminal_test.hs+9−1
@@ -1150,13 +1150,21 @@ cheesyAnim0 i background = do
1150 reserveDisplay t
1150 reserveDisplay t
1151 bounds <- displayBounds t
1151 bounds <- displayBounds t
1152 d <- displayContext t bounds
1152 d <- displayContext t bounds
1153− forM_ [0..100] $ \t -> do
1153+ forM_ [0..2] $ \t -> do
1154+ forM_ [0..100] $ \t -> do
1154 let i_offset = translate (t `mod` fst bounds)
1155 let i_offset = translate (t `mod` fst bounds)
1155 (t `div` 2 `mod` snd bounds)
1156 (t `div` 2 `mod` snd bounds)
1156 i
1157 i
1157 let pic = picForLayers $ i_offset : background
1158 let pic = picForLayers $ i_offset : background
1158 outputPicture d pic
1159 outputPicture d pic
1159 threadDelay 50000
1160 threadDelay 50000
1161+ forM_ [0..100] $ \t -> do
1162+ let i_offset = translate (t * (-1) `mod` fst bounds)
1163+ (t * (-1) `div` 2 `mod` snd bounds)
1164+ i
1165+ let pic = picForLayers $ i_offset : background
1166+ outputPicture d pic
1167+ threadDelay 50000
1160 releaseDisplay t
1168 releaseDisplay t
1161 releaseTerminal t
1169 releaseTerminal t
1162 return ()
1170 return ()