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/IO/Terminal')

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