From 8418014253e3f5507dccfd4b7ef61c4402d6e0a6 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 9 Jul 2023 11:48:18 +0200
Subject: Add putcWith
---
src/System/IO/Terminal/Render.hs | 26 +++++++++++++++++++-------
1 file changed, 19 insertions(+), 7 deletions(-)
(limited to 'src/System')
diff --git a/src/System/IO/Terminal/Render.hs b/src/System/IO/Terminal/Render.hs
index 86b5cb3..f3f0b59 100644
--- a/src/System/IO/Terminal/Render.hs
+++ b/src/System/IO/Terminal/Render.hs
@@ -40,7 +40,7 @@ module System.IO.Terminal.Render
,RenderT, Render, withRender, liftIO
,getTermSize
,redraw, redrawFull
- ,write, putc
+ ,write, putc, putcWith
,readPixel
,setStyle, setFg, setBg, setBold, setUnderline
,savingStyle
@@ -196,21 +196,33 @@ getTermSize = do
write :: MonadIO m => (Int, Int) -> String -> RenderT m ()
write (x, y1) str = do
(wid, hei) <- getTermSize
- let writeLine y line = sequence_ [putc' (x', y) c | (x', c) <- zip [x..] line]
+ let writeLine y line = sequence_ [unsafePutc (x', y) c | (x', c) <- zip [x..] line]
sequence_ [writeLine y (take (wid - x) line)
| (y, line) <- take (hei - y1) $ zip [y1..] (lines str)]
-- | Write one character to the draw buffer at the given position.
putc :: MonadIO m => (Int, Int) -> Char -> RenderT m ()
-putc (x, y) c = whenM (inBounds (x, y)) $ putc' (x, y) c
+putc (x, y) c = whenM (inBounds (x, y)) $ unsafePutc (x, y) c
-putc' :: MonadIO m => (Int, Int) -> Char -> RenderT m ()
-putc' (x, y) c = do
- drawBuffer <- gets rDrawBuffer
+-- | Write one character to the draw buffer at the given position with the given
+-- style (instead of the stateful style).
+putcWith :: MonadIO m => Style -> (Int, Int) -> Char -> RenderT m ()
+putcWith sty (x, y) c = whenM (inBounds (x, y)) $ unsafePutcWith sty (x, y) c
+
+-- | 'putc', but don't check bounds
+unsafePutc :: MonadIO m => (Int, Int) -> Char -> RenderT m ()
+unsafePutc (x, y) c = do
style <- gets rCurrentStyle
+ unsafePutcWith style (x, y) c
+
+-- | 'putcWith', but don't check bounds
+unsafePutcWith :: MonadIO m => Style -> (Int, Int) -> Char -> RenderT m ()
+unsafePutcWith style (x, y) c = do
+ drawBuffer <- gets rDrawBuffer
let cell = Cell { cChar = c, cStyle = style }
liftIO $ writeArray drawBuffer (y, x) cell
+
-- | Obtain the current character and style in the draw buffer at the given
-- position.
readPixel :: MonadIO m => (Int, Int) -> RenderT m (Style, Char)
@@ -255,7 +267,7 @@ setUnderline ul = modifyCurrentStyle (\s -> s { sUnderline = ul })
fillRect :: MonadIO m => (Int, Int) -> (Int, Int) -> Char -> RenderT m ()
fillRect (fromx, fromy) (tox, toy) ch =
forM_ [(x, y) | y <- [fromy..toy], x <- [fromx..tox]] $ \(x, y) -> do
- putc' (x, y) ch
+ unsafePutc (x, y) ch
-- | Clear the whole screen. This may also be accomplished using 'fillRect'
-- with appropriate bounds.
--
cgit v1.2.3-70-g09d2