{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -O2 #-}
{- This module does a lot of calculation that can be expensive, so optimise
 - it well -}

-- | 
-- Copyright: 2015 Joey Hess <id@joeyh.name>
-- License: BSD-2-clause
-- 
-- Console regions are displayed near the bottom of the console, and can be
-- updated concurrently by threads. 
--
-- Any other output lines displayed using
-- `outputConcurrent` and `createProcessConcurrent`
-- will scroll up above the open console regions.
--
-- For example, this program:
--
-- > import Control.Concurrent.Async
-- > import Control.Concurrent
-- > import System.Console.Concurrent
-- > import System.Console.Regions
-- > import System.Process
-- > 
-- > main = displayConsoleRegions $ do
-- > 	mapConcurrently download [1..5]
-- >		`concurrently` mapM_ message [1..10]
-- >		`concurrently` createProcessConcurrent (proc "echo" ["hello world"])
-- > 
-- > message :: Int -> IO ()
-- > message n = do
-- > 	threadDelay 500000
-- > 	outputConcurrent ("Message " ++ show n ++ "\n")
-- > 
-- > download :: Int -> IO ()
-- > download n = withConsoleRegion Linear $ \r -> do
-- > 	setConsoleRegion r basemsg
-- > 	go n r
-- >   where
-- > 	basemsg = "Download " ++ show n
-- >	go c r
-- >		| c < 1 = finishConsoleRegion r (basemsg ++ " done!")
-- > 		| otherwise = do
-- > 			threadDelay 1000000
-- > 			appendConsoleRegion r " ... "
-- > 			go (c-1) r
--
-- Will display like this:
--
-- > Message 1
-- > hello world
-- > Message 2
-- > Download 1 ...
-- > Download 2 ...
-- > Download 3 ...
--
-- Once the 1st download has finished, and another message has displayed,
-- the console will update like this:
--
-- > Message 1
-- > hello world
-- > Message 2
-- > Download 1 done!
-- > Message 3
-- > Download 2 ... ...
-- > Download 3 ... ...

module System.Console.Regions (
	-- * Types
	ConsoleRegion,
	RegionLayout(..),
	ToRegionContent(..),
	RegionContent(..),
	LiftRegion(..),
	-- * Initialization
	displayConsoleRegions,
	withConsoleRegion,
	openConsoleRegion,
	newConsoleRegion,
	closeConsoleRegion,
	-- * Region content and display
	setConsoleRegion,
	appendConsoleRegion,
	finishConsoleRegion,
	getConsoleRegion,
	tuneDisplay,
	-- * STM region contents
	--
	-- | The `ToRegionContent` instance for `STM` `Text` can be used to
	-- make regions that automatically update whenever there's
	-- a change to any of the STM values that they use.
	--
	-- For example, a region that displays the screen size,
	-- and automatically refreshes it:
	--
	-- > import qualified Data.Text as T
	--
	-- > r <- openConsoleRegion Linear s
	-- > setConsoleRegion r $ do
	-- > 	w <- readTVar consoleWidth
	-- > 	h <- readTVar consoleHeight
	-- > 	return $ T.pack $ unwords
	-- > 		[ "size:"
	-- >		, show w
	-- > 		, "x"
	-- >		, show h
	-- > 		]
	-- >
	consoleWidth,
	consoleHeight,
	regionList,
	waitDisplayChange,
) where

import Data.Monoid
import Data.String
import Data.Char
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.IO as T
import Data.Text (Text)
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Concurrent.Async
import System.Console.ANSI
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Text.Read
import Data.List (intercalate, nubBy)
import Control.Applicative
import Prelude
#ifdef VERSION_terminal_size
import qualified System.Console.Terminal.Size as Console
#ifndef mingw32_HOST_OS
import System.Posix.Signals
import System.Posix.Signals.Exts
#endif
#endif

import System.Console.Concurrent
import Utility.Monad
import Utility.Exception

-- | Controls how a region is laid out in the console.
--
-- Here's an annotated example of how the console layout works.
-- Each sequence of the same letter represents a distinct region.
--
-- > scrolling......
-- > scrolling......
-- > scrolling......
-- > aaaaaa......... -- Linear
-- > bbbbbbbbbbbbbbb -- Linear
-- > bbb............       (expanded to multiple lines)
-- > ccccccccc...... -- Linear
-- > ddddeeeefffffff -- [InLine]
-- > fffffggggg.....       (expanded to multiple lines)
-- > 
data RegionLayout = Linear | InLine ConsoleRegion
	deriving (RegionLayout -> RegionLayout -> Bool
(RegionLayout -> RegionLayout -> Bool)
-> (RegionLayout -> RegionLayout -> Bool) -> Eq RegionLayout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RegionLayout -> RegionLayout -> Bool
== :: RegionLayout -> RegionLayout -> Bool
$c/= :: RegionLayout -> RegionLayout -> Bool
/= :: RegionLayout -> RegionLayout -> Bool
Eq)

-- | A handle allowing access to a region of the console.
newtype ConsoleRegion = ConsoleRegion (TVar R)
	deriving (ConsoleRegion -> ConsoleRegion -> Bool
(ConsoleRegion -> ConsoleRegion -> Bool)
-> (ConsoleRegion -> ConsoleRegion -> Bool) -> Eq ConsoleRegion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConsoleRegion -> ConsoleRegion -> Bool
== :: ConsoleRegion -> ConsoleRegion -> Bool
$c/= :: ConsoleRegion -> ConsoleRegion -> Bool
/= :: ConsoleRegion -> ConsoleRegion -> Bool
Eq)

data R = R
	{ R -> RegionContent
regionContent :: RegionContent
	, R -> Text -> STM Text
regionRender :: (Text -> STM Text)
	, R -> RegionLayout
regionLayout :: RegionLayout
	, R -> TVar [ConsoleRegion]
regionChildren :: TVar [ConsoleRegion]
	}

newtype RegionContent = RegionContent (STM Text)

-- | All the regions that are currently displayed on the screen.
--
-- The list is ordered from the bottom of the screen up. Reordering
-- it will change the order in which regions are displayed.
-- It's also fine to remove, duplicate, or add new regions to the list.
{-# NOINLINE regionList #-}
regionList :: TMVar [ConsoleRegion]
regionList :: TMVar [ConsoleRegion]
regionList = IO (TMVar [ConsoleRegion]) -> TMVar [ConsoleRegion]
forall a. IO a -> a
unsafePerformIO IO (TMVar [ConsoleRegion])
forall a. IO (TMVar a)
newEmptyTMVarIO

data ConsoleSize = ConsoleSize
	{ ConsoleSize -> Int
_consoleHeight :: Int
	, ConsoleSize -> Int
_consoleWidth :: Int
	}

{-# NOINLINE consoleSize #-}
consoleSize :: TVar ConsoleSize
consoleSize :: TVar ConsoleSize
consoleSize = IO (TVar ConsoleSize) -> TVar ConsoleSize
forall a. IO a -> a
unsafePerformIO (IO (TVar ConsoleSize) -> TVar ConsoleSize)
-> IO (TVar ConsoleSize) -> TVar ConsoleSize
forall a b. (a -> b) -> a -> b
$ ConsoleSize -> IO (TVar ConsoleSize)
forall a. a -> IO (TVar a)
newTVarIO (ConsoleSize -> IO (TVar ConsoleSize))
-> ConsoleSize -> IO (TVar ConsoleSize)
forall a b. (a -> b) -> a -> b
$
	ConsoleSize { _consoleWidth :: Int
_consoleWidth = Int
80, _consoleHeight :: Int
_consoleHeight = Int
25}

type Width = Int

-- | Gets the width of the console.
--
-- On Unix, this is automatically updated when the terminal is resized.
-- On Windows, it is determined at start. On WASM,
-- the console width is hard coded to 80 since WASI does not provide a way
-- to determine it.
consoleWidth :: STM Int
consoleWidth :: STM Int
consoleWidth = Int -> Int
forall {a}. a -> a
munge (Int -> Int) -> (ConsoleSize -> Int) -> ConsoleSize -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsoleSize -> Int
_consoleWidth (ConsoleSize -> Int) -> STM ConsoleSize -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ConsoleSize -> STM ConsoleSize
forall a. TVar a -> STM a
readTVar TVar ConsoleSize
consoleSize
  where
#ifndef mingw32_HOST_OS
	munge :: a -> a
munge = a -> a
forall {a}. a -> a
id
#else
	-- On Windows, writing to the right-most column caused some
	-- problimatic wrap, so avoid it.
	munge = pred
#endif

-- | Get the height of the console.
--
-- On Unix, this is automatically updated when the terminal is resized.
-- On Windows, it is determined at start. On WASM,
-- the console heigth is hard coded to 25 since WASI does not provide a way
-- to determine it.
consoleHeight :: STM Int
consoleHeight :: STM Int
consoleHeight = ConsoleSize -> Int
_consoleHeight (ConsoleSize -> Int) -> STM ConsoleSize -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ConsoleSize -> STM ConsoleSize
forall a. TVar a -> STM a
readTVar TVar ConsoleSize
consoleSize

-- | Check if `displayConsoleRegions` is running.
regionDisplayEnabled :: IO Bool
regionDisplayEnabled :: IO Bool
regionDisplayEnabled = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar [ConsoleRegion] -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar [ConsoleRegion]
regionList

-- | Many actions in this module can be run in either the IO monad
-- or the STM monad. Using STM allows making several changes to the
-- displayed regions atomically, with the display updated a single time.
class LiftRegion m where
	liftRegion :: STM a -> m a

instance LiftRegion STM where
	liftRegion :: forall a. STM a -> STM a
liftRegion = STM a -> STM a
forall {a}. a -> a
id

instance LiftRegion IO where
	liftRegion :: forall a. STM a -> IO a
liftRegion = STM a -> IO a
forall a. STM a -> IO a
atomically

-- | Values that can be displayed in a region.
class ToRegionContent v where
	toRegionContent :: v -> RegionContent

instance ToRegionContent String where
	toRegionContent :: String -> RegionContent
toRegionContent = String -> RegionContent
forall v. Outputable v => v -> RegionContent
fromOutput

instance ToRegionContent Text where
	toRegionContent :: Text -> RegionContent
toRegionContent = Text -> RegionContent
forall v. Outputable v => v -> RegionContent
fromOutput

-- | Note that using a lazy Text in a region will buffer it all in memory.
instance ToRegionContent L.Text where
	toRegionContent :: Text -> RegionContent
toRegionContent = Text -> RegionContent
forall v. Outputable v => v -> RegionContent
fromOutput

fromOutput :: Outputable v => v -> RegionContent
fromOutput :: forall v. Outputable v => v -> RegionContent
fromOutput = STM Text -> RegionContent
RegionContent (STM Text -> RegionContent)
-> (v -> STM Text) -> v -> RegionContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> STM Text
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> STM Text) -> (v -> Text) -> v -> STM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Text
forall v. Outputable v => v -> Text
toOutput

-- | Makes a STM action be run to get the content of a region.
--
-- Any change to the values that action reads will result in an immediate
-- refresh of the display.
instance ToRegionContent (STM Text) where
	toRegionContent :: STM Text -> RegionContent
toRegionContent = STM Text -> RegionContent
RegionContent

-- | Sets the value of a console region. This will cause the
-- console to be updated to display the new value.
--
-- It's fine for the value to be longer than the terminal is wide,
-- or to include newlines ('\n'). Regions expand to multiple lines as
-- necessary.
--
-- The value can include ANSI SGR escape sequences for changing
-- the colors of all or part of a region. For this to display properly,
-- a reset escape sequence must be included to get the color back
-- to default. System.Console.ANSI makes it easy to construct such
-- values. For example:
--
-- > import System.Console.ANSI
-- > 
-- > setConsoleRegion region 
-- > 	( "hello "
-- > 	<> setSGRCode [SetColor Foreground Vivid Red] 
-- >	<> "Mars" 
-- >	<> setSGRCode [Reset]
-- > 	<> "!"
-- >	)
-- 
-- Other ANSI escape sequences, especially those doing cursor
-- movement, will mess up the layouts of regions. Caveat emptor.
--
-- ANSI SGR escape sequences that span multiple lines do not currently
-- display as you might hope. (Patches would be accepted.)
setConsoleRegion :: (ToRegionContent v, LiftRegion m) => ConsoleRegion -> v -> m ()
setConsoleRegion :: forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
setConsoleRegion ConsoleRegion
r v
v = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
	ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion ConsoleRegion
r ((RegionContent -> STM RegionContent) -> STM ())
-> (RegionContent -> STM RegionContent) -> STM ()
forall a b. (a -> b) -> a -> b
$ STM RegionContent -> RegionContent -> STM RegionContent
forall a b. a -> b -> a
const (STM RegionContent -> RegionContent -> STM RegionContent)
-> STM RegionContent -> RegionContent -> STM RegionContent
forall a b. (a -> b) -> a -> b
$ RegionContent -> STM RegionContent
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RegionContent -> STM RegionContent)
-> RegionContent -> STM RegionContent
forall a b. (a -> b) -> a -> b
$ v -> RegionContent
forall v. ToRegionContent v => v -> RegionContent
toRegionContent v
v

-- | Appends a value to the current value of a console region.
--
-- > appendConsoleRegion progress "." -- add another dot to progress display
appendConsoleRegion :: (Outputable v, LiftRegion m) => ConsoleRegion -> v -> m ()
appendConsoleRegion :: forall v (m :: * -> *).
(Outputable v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
appendConsoleRegion ConsoleRegion
r v
v = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
	ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion ConsoleRegion
r ((RegionContent -> STM RegionContent) -> STM ())
-> (RegionContent -> STM RegionContent) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(RegionContent STM Text
a) ->
		RegionContent -> STM RegionContent
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RegionContent -> STM RegionContent)
-> RegionContent -> STM RegionContent
forall a b. (a -> b) -> a -> b
$ STM Text -> RegionContent
RegionContent (STM Text -> RegionContent) -> STM Text -> RegionContent
forall a b. (a -> b) -> a -> b
$ do
			Text
t <- STM Text
a
			Text -> STM Text
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> v -> Text
forall v. Outputable v => v -> Text
toOutput v
v)

modifyRegion :: ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion :: ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion (ConsoleRegion TVar R
tv) RegionContent -> STM RegionContent
f = do
	R
r <- TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
	RegionContent
rc <- RegionContent -> STM RegionContent
f (R -> RegionContent
regionContent R
r)
	let r' :: R
r' = R
r { regionContent = rc }
	TVar R -> R -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar R
tv R
r'

readRegionContent :: RegionContent -> STM Text
readRegionContent :: RegionContent -> STM Text
readRegionContent (RegionContent STM Text
a) = STM Text
a

resizeRegion :: Width -> ConsoleRegion -> STM [Text]
resizeRegion :: Int -> ConsoleRegion -> STM [Text]
resizeRegion Int
width (ConsoleRegion TVar R
tv) = do
	R
r <- TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
	[Text]
ls <- R -> Int -> STM [Text]
calcRegionLines R
r Int
width
	[Text] -> STM [Text]
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
ls

-- | Runs the action with a new console region, closing the region when
-- the action finishes or on exception.
withConsoleRegion :: (MonadIO m, MonadMask m) => RegionLayout -> (ConsoleRegion -> m a) -> m a
withConsoleRegion :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RegionLayout -> (ConsoleRegion -> m a) -> m a
withConsoleRegion RegionLayout
ly = IO ConsoleRegion
-> (ConsoleRegion -> IO ()) -> (ConsoleRegion -> m a) -> m a
forall (m :: * -> *) v b a.
(MonadMask m, MonadIO m) =>
IO v -> (v -> IO b) -> (v -> m a) -> m a
bracketIO
	(RegionLayout -> IO ConsoleRegion
forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
openConsoleRegion RegionLayout
ly)
	(IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
uninterruptibleMask_ (IO () -> IO ())
-> (ConsoleRegion -> IO ()) -> ConsoleRegion -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsoleRegion -> IO ()
forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m ()
closeConsoleRegion)

-- | Opens a new console region.
openConsoleRegion :: LiftRegion m => RegionLayout -> m ConsoleRegion
openConsoleRegion :: forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
openConsoleRegion RegionLayout
ly = STM ConsoleRegion -> m ConsoleRegion
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM ConsoleRegion -> m ConsoleRegion)
-> STM ConsoleRegion -> m ConsoleRegion
forall a b. (a -> b) -> a -> b
$ do
	ConsoleRegion
h <- RegionLayout -> Text -> STM ConsoleRegion
forall (m :: * -> *) v.
(LiftRegion m, ToRegionContent v) =>
RegionLayout -> v -> m ConsoleRegion
newConsoleRegion RegionLayout
ly Text
T.empty
	case RegionLayout
ly of
		RegionLayout
Linear -> do
			Maybe [ConsoleRegion]
ml <- TMVar [ConsoleRegion] -> STM (Maybe [ConsoleRegion])
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar [ConsoleRegion]
regionList
			case Maybe [ConsoleRegion]
ml of
				Just [ConsoleRegion]
l -> TMVar [ConsoleRegion] -> [ConsoleRegion] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [ConsoleRegion]
regionList (ConsoleRegion
hConsoleRegion -> [ConsoleRegion] -> [ConsoleRegion]
forall a. a -> [a] -> [a]
:[ConsoleRegion]
l)
				-- displayConsoleRegions is not active, so
				-- it's not put on any list, and won't display
				Maybe [ConsoleRegion]
Nothing -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
		InLine ConsoleRegion
parent -> ConsoleRegion -> ConsoleRegion -> STM ()
addChild ConsoleRegion
h ConsoleRegion
parent
	ConsoleRegion -> STM ConsoleRegion
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ConsoleRegion
h

-- | Makes a new region, but does not add it to the display.
newConsoleRegion :: (LiftRegion m) => ToRegionContent v => RegionLayout -> v -> m ConsoleRegion
newConsoleRegion :: forall (m :: * -> *) v.
(LiftRegion m, ToRegionContent v) =>
RegionLayout -> v -> m ConsoleRegion
newConsoleRegion RegionLayout
ly v
v = STM ConsoleRegion -> m ConsoleRegion
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM ConsoleRegion -> m ConsoleRegion)
-> STM ConsoleRegion -> m ConsoleRegion
forall a b. (a -> b) -> a -> b
$ do
	TVar [ConsoleRegion]
cs <- [ConsoleRegion] -> STM (TVar [ConsoleRegion])
forall a. a -> STM (TVar a)
newTVar [ConsoleRegion]
forall a. Monoid a => a
mempty
	let r :: R
r = R
		{ regionContent :: RegionContent
regionContent = STM Text -> RegionContent
RegionContent (STM Text -> RegionContent) -> STM Text -> RegionContent
forall a b. (a -> b) -> a -> b
$ Text -> STM Text
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
forall a. Monoid a => a
mempty
		, regionRender :: Text -> STM Text
regionRender = Text -> STM Text
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
		, regionLayout :: RegionLayout
regionLayout = RegionLayout
ly
		, regionChildren :: TVar [ConsoleRegion]
regionChildren = TVar [ConsoleRegion]
cs
		}
	ConsoleRegion
h <- TVar R -> ConsoleRegion
ConsoleRegion (TVar R -> ConsoleRegion) -> STM (TVar R) -> STM ConsoleRegion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R -> STM (TVar R)
forall a. a -> STM (TVar a)
newTVar R
r
	ConsoleRegion -> STM ()
displayChildren ConsoleRegion
h
	ConsoleRegion -> v -> STM ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
setConsoleRegion ConsoleRegion
h v
v
	ConsoleRegion -> STM ConsoleRegion
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ConsoleRegion
h

displayChildren :: ConsoleRegion -> STM ()
displayChildren :: ConsoleRegion -> STM ()
displayChildren p :: ConsoleRegion
p@(ConsoleRegion TVar R
tv) = ConsoleRegion -> (Text -> STM Text) -> STM ()
forall (m :: * -> *).
LiftRegion m =>
ConsoleRegion -> (Text -> STM Text) -> m ()
tuneDisplay ConsoleRegion
p ((Text -> STM Text) -> STM ()) -> (Text -> STM Text) -> STM ()
forall a b. (a -> b) -> a -> b
$ \Text
t -> do
	[ConsoleRegion]
children <- TVar [ConsoleRegion] -> STM [ConsoleRegion]
forall a. TVar a -> STM a
readTVar (TVar [ConsoleRegion] -> STM [ConsoleRegion])
-> (R -> TVar [ConsoleRegion]) -> R -> STM [ConsoleRegion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R -> TVar [ConsoleRegion]
regionChildren (R -> STM [ConsoleRegion]) -> STM R -> STM [ConsoleRegion]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
	Text
ct <- [Text] -> Text
T.concat ([Text] -> Text) -> STM [Text] -> STM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConsoleRegion -> STM Text) -> [ConsoleRegion] -> STM [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ConsoleRegion -> STM Text
getc [ConsoleRegion]
children
	Text -> STM Text
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> STM Text) -> Text -> STM Text
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ct
  where
	getc :: ConsoleRegion -> STM Text
getc (ConsoleRegion TVar R
cv) = do
		R
c <- TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
cv
		R -> Text -> STM Text
regionRender R
c (Text -> STM Text) -> STM Text -> STM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RegionContent -> STM Text
readRegionContent (R -> RegionContent
regionContent R
c)

-- | Closes a console region. Once closed, the region is removed from the
-- display.
closeConsoleRegion :: LiftRegion m => ConsoleRegion -> m ()
closeConsoleRegion :: forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m ()
closeConsoleRegion h :: ConsoleRegion
h@(ConsoleRegion TVar R
tv) = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	Maybe [ConsoleRegion]
v <- TMVar [ConsoleRegion] -> STM (Maybe [ConsoleRegion])
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar [ConsoleRegion]
regionList
	case Maybe [ConsoleRegion]
v of
		Just [ConsoleRegion]
l ->
			let !l' :: [ConsoleRegion]
l' = (ConsoleRegion -> Bool) -> [ConsoleRegion] -> [ConsoleRegion]
forall a. (a -> Bool) -> [a] -> [a]
filter (ConsoleRegion -> ConsoleRegion -> Bool
forall a. Eq a => a -> a -> Bool
/= ConsoleRegion
h) [ConsoleRegion]
l
			in TMVar [ConsoleRegion] -> [ConsoleRegion] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [ConsoleRegion]
regionList [ConsoleRegion]
l'
		Maybe [ConsoleRegion]
_ -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
	RegionLayout
ly <- R -> RegionLayout
regionLayout (R -> RegionLayout) -> STM R -> STM RegionLayout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
	case RegionLayout
ly of
		RegionLayout
Linear -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
		InLine ConsoleRegion
parent -> ConsoleRegion -> ConsoleRegion -> STM ()
removeChild ConsoleRegion
h ConsoleRegion
parent

-- | Closes the console region, and displays the passed value in the
-- scrolling area above the active console regions. When Nothing is passed,
-- displays the current value of the console region.
finishConsoleRegion :: (Outputable v, LiftRegion m) => ConsoleRegion -> v -> m ()
finishConsoleRegion :: forall v (m :: * -> *).
(Outputable v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
finishConsoleRegion ConsoleRegion
h v
v = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	ConsoleRegion -> STM ()
forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m ()
closeConsoleRegion ConsoleRegion
h
	StdHandle -> Text -> STM ()
forall v. Outputable v => StdHandle -> v -> STM ()
bufferOutputSTM StdHandle
StdOut (v -> Text
forall v. Outputable v => v -> Text
toOutput v
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString String
"\n")

-- | Gets the current content of a console region.
getConsoleRegion :: LiftRegion m => ConsoleRegion -> m Text
getConsoleRegion :: forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m Text
getConsoleRegion (ConsoleRegion TVar R
tv) = STM Text -> m Text
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM Text -> m Text) -> STM Text -> m Text
forall a b. (a -> b) -> a -> b
$
	RegionContent -> STM Text
readRegionContent (RegionContent -> STM Text)
-> (R -> RegionContent) -> R -> STM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R -> RegionContent
regionContent (R -> STM Text) -> STM R -> STM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv

-- | Changes how a console region displays.
--
-- Each time the region's value changes, the STM action is provided
-- with the current value of the region, and returns the value to display.
--
-- For example, this will prevent a region from ever displaying more
-- than 10 characters wide, and will make it display text reversed:
-- 
-- > tuneDisplay myregion $ pure . T.take 10
-- > tuneDisplay myregion $ pure . T.reverse
--
-- Note that repeated calls to tuneDisplay are cumulative.
--
-- Normally, the STM action should avoid retrying, as that would
-- block all display updates.
tuneDisplay :: LiftRegion m => ConsoleRegion -> (Text -> STM Text) -> m ()
tuneDisplay :: forall (m :: * -> *).
LiftRegion m =>
ConsoleRegion -> (Text -> STM Text) -> m ()
tuneDisplay (ConsoleRegion TVar R
tv) Text -> STM Text
renderer = STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	R
r <- TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
	let rr :: Text -> STM Text
rr = \Text
t -> Text -> STM Text
renderer (Text -> STM Text) -> STM Text -> STM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< R -> Text -> STM Text
regionRender R
r Text
t
	let r' :: R
r' = R
r { regionRender = rr }
	TVar R -> R -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar R
tv R
r'

addChild :: ConsoleRegion -> ConsoleRegion -> STM ()
addChild :: ConsoleRegion -> ConsoleRegion -> STM ()
addChild ConsoleRegion
child _parent :: ConsoleRegion
_parent@(ConsoleRegion TVar R
pv) = do
	TVar [ConsoleRegion]
cv <- R -> TVar [ConsoleRegion]
regionChildren (R -> TVar [ConsoleRegion]) -> STM R -> STM (TVar [ConsoleRegion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
pv
	[ConsoleRegion]
children <- TVar [ConsoleRegion] -> STM [ConsoleRegion]
forall a. TVar a -> STM a
readTVar TVar [ConsoleRegion]
cv
	let !children' :: [ConsoleRegion]
children' = (ConsoleRegion -> Bool) -> [ConsoleRegion] -> [ConsoleRegion]
forall a. (a -> Bool) -> [a] -> [a]
filter (ConsoleRegion -> ConsoleRegion -> Bool
forall a. Eq a => a -> a -> Bool
/= ConsoleRegion
child) [ConsoleRegion]
children [ConsoleRegion] -> [ConsoleRegion] -> [ConsoleRegion]
forall a. [a] -> [a] -> [a]
++ [ConsoleRegion
child]
	TVar [ConsoleRegion] -> [ConsoleRegion] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [ConsoleRegion]
cv [ConsoleRegion]
children'

removeChild :: ConsoleRegion -> ConsoleRegion -> STM ()
removeChild :: ConsoleRegion -> ConsoleRegion -> STM ()
removeChild ConsoleRegion
child _parent :: ConsoleRegion
_parent@(ConsoleRegion TVar R
pv) = do
	TVar [ConsoleRegion]
cv <- R -> TVar [ConsoleRegion]
regionChildren (R -> TVar [ConsoleRegion]) -> STM R -> STM (TVar [ConsoleRegion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
pv
	TVar [ConsoleRegion]
-> ([ConsoleRegion] -> [ConsoleRegion]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [ConsoleRegion]
cv ((ConsoleRegion -> Bool) -> [ConsoleRegion] -> [ConsoleRegion]
forall a. (a -> Bool) -> [a] -> [a]
filter (ConsoleRegion -> ConsoleRegion -> Bool
forall a. Eq a => a -> a -> Bool
/= ConsoleRegion
child))

-- | Handles all display for the other functions in this module.
--
-- Note that this uses `lockOutput`, so it takes over all output to the
-- console while the passed IO action is running. As well as displaying
-- the console regions, this handles display of anything buffered by
-- `outputConcurrent` and `createProcessConcurrent`. So,
-- `withConcurrentOutput` and `flushConcurrentOutput` should not be run
-- while this is in use, and will block.
--
-- When standard output is not an ANSI capable terminal,
-- console regions are not displayed.
displayConsoleRegions :: (MonadIO m, MonadMask m) => m a -> m a
displayConsoleRegions :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
displayConsoleRegions m a
a = m Bool -> (m a, m a) -> m a
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
regionDisplayEnabled)
	( m a
a -- displayConsoleRegions is already running
	, m a -> m a
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
lockOutput (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m (Bool, Async (), TSem)
-> ((Bool, Async (), TSem) -> m ())
-> ((Bool, Async (), TSem) -> m a)
-> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m (Bool, Async (), TSem)
setup (Bool, Async (), TSem) -> m ()
forall {m :: * -> *} {a}.
MonadIO m =>
(Bool, Async a, TSem) -> m ()
cleanup (m a -> (Bool, Async (), TSem) -> m a
forall a b. a -> b -> a
const m a
a)
	)
  where
	setup :: m (Bool, Async (), TSem)
setup = IO (Bool, Async (), TSem) -> m (Bool, Async (), TSem)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, Async (), TSem) -> m (Bool, Async (), TSem))
-> IO (Bool, Async (), TSem) -> m (Bool, Async (), TSem)
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO (Bool, Async (), TSem))
-> IO (Bool, Async (), TSem)
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask (((forall a. IO a -> IO a) -> IO (Bool, Async (), TSem))
 -> IO (Bool, Async (), TSem))
-> ((forall a. IO a -> IO a) -> IO (Bool, Async (), TSem))
-> IO (Bool, Async (), TSem)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
		STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar [ConsoleRegion] -> [ConsoleRegion] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [ConsoleRegion]
regionList []
		TSem
endsignal <- STM TSem -> IO TSem
forall a. STM a -> IO a
atomically (STM TSem -> IO TSem) -> STM TSem -> IO TSem
forall a b. (a -> b) -> a -> b
$ do
			TSem
s <- Barrier -> STM TSem
newTSem Barrier
1
			TSem -> STM ()
waitTSem TSem
s
			TSem -> STM TSem
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return TSem
s
		Bool
isterm <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hSupportsANSI Handle
stdout
		Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()
forall a. IO a -> IO a
unmask IO ()
trackConsoleWidth)
		Async ()
da <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
unmask (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> TSem -> IO ()
displayThread Bool
isterm TSem
endsignal
		(Bool, Async (), TSem) -> IO (Bool, Async (), TSem)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isterm, Async ()
da, TSem
endsignal)
	cleanup :: (Bool, Async a, TSem) -> m ()
cleanup (Bool
isterm, Async a
da, TSem
endsignal) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TSem -> STM ()
signalTSem TSem
endsignal
		IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ Async a -> IO a
forall a. Async a -> IO a
wait Async a
da
		IO [ConsoleRegion] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [ConsoleRegion] -> IO ()) -> IO [ConsoleRegion] -> IO ()
forall a b. (a -> b) -> a -> b
$ STM [ConsoleRegion] -> IO [ConsoleRegion]
forall a. STM a -> IO a
atomically (STM [ConsoleRegion] -> IO [ConsoleRegion])
-> STM [ConsoleRegion] -> IO [ConsoleRegion]
forall a b. (a -> b) -> a -> b
$ TMVar [ConsoleRegion] -> STM [ConsoleRegion]
forall a. TMVar a -> STM a
takeTMVar TMVar [ConsoleRegion]
regionList
		Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
			Maybe (IO ()) -> IO ()
installResizeHandler Maybe (IO ())
forall a. Maybe a
Nothing

trackConsoleWidth :: IO ()
#ifdef VERSION_terminal_size
trackConsoleWidth :: IO ()
trackConsoleWidth = do
	let getsz :: IO ()
getsz = IO () -> (Window Int -> IO ()) -> Maybe (Window Int) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
forall (m :: * -> *). Monad m => m ()
noop (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Window Int -> STM ()) -> Window Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ConsoleSize -> ConsoleSize -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ConsoleSize
consoleSize (ConsoleSize -> STM ())
-> (Window Int -> ConsoleSize) -> Window Int -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window Int -> ConsoleSize
conv)
		(Maybe (Window Int) -> IO ()) -> IO (Maybe (Window Int)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
Console.size
	IO ()
getsz
	Maybe (IO ()) -> IO ()
installResizeHandler (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just IO ()
getsz)
  where
	conv :: Window Int -> ConsoleSize
conv Window Int
wsz = ConsoleSize
		{ _consoleWidth :: Int
_consoleWidth = Window Int -> Int
forall a. Window a -> a
Console.width Window Int
wsz
		, _consoleHeight :: Int
_consoleHeight = Window Int -> Int
forall a. Window a -> a
Console.height Window Int
wsz
		}
#else
trackConsoleWidth = return ()
#endif

data DisplayChange
	= BufferChange BufferSnapshot 
	| RegionChange RegionSnapshot
	| RegionListChange RegionSnapshot
	| TerminalResize Width
	| Shutdown
	| DisplayChangeBarrier Barrier

type BufferSnapshot = (StdHandle, OutputBuffer)
type RegionSnapshot = ([ConsoleRegion], [R], [[Text]])
type Barrier = Integer

-- | This is a broadcast TChan, which gets a DisplayChange written to it
-- after the display has been updated. It can be used to wait for something
-- to be displayed.
{-# NOINLINE displayUpdateNotifier #-}
displayUpdateNotifier :: TChan DisplayChange
displayUpdateNotifier :: TChan DisplayChange
displayUpdateNotifier = IO (TChan DisplayChange) -> TChan DisplayChange
forall a. IO a -> a
unsafePerformIO (IO (TChan DisplayChange) -> TChan DisplayChange)
-> IO (TChan DisplayChange) -> TChan DisplayChange
forall a b. (a -> b) -> a -> b
$ IO (TChan DisplayChange)
forall a. IO (TChan a)
newBroadcastTChanIO

{-# NOINLINE displayChangeBarrier #-}
displayChangeBarrier :: TVar Barrier
displayChangeBarrier :: TVar Barrier
displayChangeBarrier = IO (TVar Barrier) -> TVar Barrier
forall a. IO a -> a
unsafePerformIO (IO (TVar Barrier) -> TVar Barrier)
-> IO (TVar Barrier) -> TVar Barrier
forall a b. (a -> b) -> a -> b
$ Barrier -> IO (TVar Barrier)
forall a. a -> IO (TVar a)
newTVarIO Barrier
0

-- | Runs a STM action, and waits for the display to be fully updated
-- with any changes that action makes to the displayed regions.
waitDisplayChange :: STM a -> IO a
waitDisplayChange :: forall a. STM a -> IO a
waitDisplayChange STM a
a = do
	TChan DisplayChange
c <- STM (TChan DisplayChange) -> IO (TChan DisplayChange)
forall a. STM a -> IO a
atomically (STM (TChan DisplayChange) -> IO (TChan DisplayChange))
-> STM (TChan DisplayChange) -> IO (TChan DisplayChange)
forall a b. (a -> b) -> a -> b
$ TChan DisplayChange -> STM (TChan DisplayChange)
forall a. TChan a -> STM (TChan a)
dupTChan TChan DisplayChange
displayUpdateNotifier
	TMVar (Barrier, a)
bv <- IO (TMVar (Barrier, a))
forall a. IO (TMVar a)
newEmptyTMVarIO
	((), ())
_ <- TMVar (Barrier, a) -> IO ()
setbarrier TMVar (Barrier, a)
bv IO () -> IO () -> IO ((), ())
forall a b. IO a -> IO b -> IO (a, b)
`concurrently` TChan DisplayChange -> TMVar (Barrier, a) -> IO ()
forall {b}. TChan DisplayChange -> TMVar (Barrier, b) -> IO ()
waitchange TChan DisplayChange
c TMVar (Barrier, a)
bv
	(Barrier, a) -> a
forall a b. (a, b) -> b
snd ((Barrier, a) -> a) -> IO (Barrier, a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Barrier, a) -> IO (Barrier, a)
forall a. STM a -> IO a
atomically (TMVar (Barrier, a) -> STM (Barrier, a)
forall a. TMVar a -> STM a
readTMVar TMVar (Barrier, a)
bv)
  where
	setbarrier :: TMVar (Barrier, a) -> IO ()
setbarrier TMVar (Barrier, a)
bv = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		!Barrier
b <- Barrier -> Barrier
forall a. Enum a => a -> a
succ (Barrier -> Barrier) -> STM Barrier -> STM Barrier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Barrier -> STM Barrier
forall a. TVar a -> STM a
readTVar TVar Barrier
displayChangeBarrier
		a
r <- STM a
a
		TVar Barrier -> Barrier -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Barrier
displayChangeBarrier Barrier
b
		TMVar (Barrier, a) -> (Barrier, a) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Barrier, a)
bv (Barrier
b, a
r)
	waitchange :: TChan DisplayChange -> TMVar (Barrier, b) -> IO ()
waitchange TChan DisplayChange
c TMVar (Barrier, b)
bv = do
		DisplayChange
change <- STM DisplayChange -> IO DisplayChange
forall a. STM a -> IO a
atomically (STM DisplayChange -> IO DisplayChange)
-> STM DisplayChange -> IO DisplayChange
forall a b. (a -> b) -> a -> b
$ TChan DisplayChange -> STM DisplayChange
forall a. TChan a -> STM a
readTChan TChan DisplayChange
c
		-- this blocks until the STM action has run, and the
		-- barrier is set.
		Barrier
b <- (Barrier, b) -> Barrier
forall a b. (a, b) -> a
fst ((Barrier, b) -> Barrier) -> IO (Barrier, b) -> IO Barrier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Barrier, b) -> IO (Barrier, b)
forall a. STM a -> IO a
atomically (TMVar (Barrier, b) -> STM (Barrier, b)
forall a. TMVar a -> STM a
readTMVar TMVar (Barrier, b)
bv)
		case DisplayChange
change of
			DisplayChangeBarrier Barrier
b' | Barrier
b' Barrier -> Barrier -> Bool
forall a. Ord a => a -> a -> Bool
>= Barrier
b -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
			DisplayChange
_ -> TChan DisplayChange -> TMVar (Barrier, b) -> IO ()
waitchange TChan DisplayChange
c TMVar (Barrier, b)
bv

displayThread :: Bool -> TSem -> IO ()
displayThread :: Bool -> TSem -> IO ()
displayThread Bool
isterm TSem
endsignal = do
	Int
origwidth <- STM Int -> IO Int
forall a. STM a -> IO a
atomically STM Int
consoleWidth
	Barrier
origbarrier <- STM Barrier -> IO Barrier
forall a. STM a -> IO a
atomically (TVar Barrier -> STM Barrier
forall a. TVar a -> STM a
readTVar TVar Barrier
displayChangeBarrier)
	([ConsoleRegion], [R], [[Text]]) -> Int -> Barrier -> IO ()
go ([], [], []) Int
origwidth Barrier
origbarrier
  where
	go :: ([ConsoleRegion], [R], [[Text]]) -> Int -> Barrier -> IO ()
go origsnapshot :: ([ConsoleRegion], [R], [[Text]])
origsnapshot@([ConsoleRegion]
orighandles, [R]
origregions, [[Text]]
origlines) Int
origwidth Barrier
origbarrier = do
		let waitwidthchange :: STM Int
waitwidthchange = do
			Int
w <- STM Int
consoleWidth
			if Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
origwidth then STM Int
forall a. STM a
retry else Int -> STM Int
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
w
		let waitbarrierchange :: STM Barrier
waitbarrierchange = do
			Barrier
b <- TVar Barrier -> STM Barrier
forall a. TVar a -> STM a
readTVar TVar Barrier
displayChangeBarrier
			if Barrier
b Barrier -> Barrier -> Bool
forall a. Eq a => a -> a -> Bool
/= Barrier
origbarrier
				then Barrier -> STM Barrier
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Barrier
b
				else STM Barrier
forall a. STM a
retry
		let waitanychange :: STM DisplayChange
waitanychange =
			(([ConsoleRegion], [R], [[Text]]) -> DisplayChange
RegionChange (([ConsoleRegion], [R], [[Text]]) -> DisplayChange)
-> STM ([ConsoleRegion], [R], [[Text]]) -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ConsoleRegion], [R], [[Text]])
-> Int -> STM ([ConsoleRegion], [R], [[Text]])
regionWaiter ([ConsoleRegion], [R], [[Text]])
origsnapshot Int
origwidth)
				STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
			(([ConsoleRegion], [R], [[Text]]) -> DisplayChange
RegionListChange (([ConsoleRegion], [R], [[Text]]) -> DisplayChange)
-> STM ([ConsoleRegion], [R], [[Text]]) -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ConsoleRegion], [R], [[Text]])
-> STM ([ConsoleRegion], [R], [[Text]])
regionListWaiter ([ConsoleRegion], [R], [[Text]])
origsnapshot)
				STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
			(BufferSnapshot -> DisplayChange
BufferChange (BufferSnapshot -> DisplayChange)
-> STM BufferSnapshot -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OutputBuffer -> (OutputBuffer, OutputBuffer))
-> STM BufferSnapshot
outputBufferWaiterSTM OutputBuffer -> (OutputBuffer, OutputBuffer)
waitCompleteLines)
				STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
			(Int -> DisplayChange
TerminalResize (Int -> DisplayChange) -> STM Int -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Int
waitwidthchange)
				STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
			(TSem -> STM ()
waitTSem TSem
endsignal STM () -> STM DisplayChange -> STM DisplayChange
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DisplayChange -> STM DisplayChange
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DisplayChange
Shutdown)
				STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
			-- Must come last, so the changes above are
			-- processed before barriers.
			(Barrier -> DisplayChange
DisplayChangeBarrier (Barrier -> DisplayChange) -> STM Barrier -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Barrier
waitbarrierchange)
		(DisplayChange
change, Int
height) <- STM (DisplayChange, Int) -> IO (DisplayChange, Int)
forall a. STM a -> IO a
atomically (STM (DisplayChange, Int) -> IO (DisplayChange, Int))
-> STM (DisplayChange, Int) -> IO (DisplayChange, Int)
forall a b. (a -> b) -> a -> b
$ (,)
			(DisplayChange -> Int -> (DisplayChange, Int))
-> STM DisplayChange -> STM (Int -> (DisplayChange, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM DisplayChange
waitanychange
			STM (Int -> (DisplayChange, Int))
-> STM Int -> STM (DisplayChange, Int)
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM Int
consoleHeight
		let onscreen :: [[a]] -> [a]
onscreen = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([a] -> [a]) -> ([[a]] -> [a]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
		let update :: ([ConsoleRegion], [R], [[Text]]) -> IO (IO ())
update snapshot :: ([ConsoleRegion], [R], [[Text]])
snapshot@([ConsoleRegion]
_, [R]
_, [[Text]]
newlines) = do
			Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
				[Text] -> [Text] -> IO ()
changedLines ([[Text]] -> [Text]
forall {a}. [[a]] -> [a]
onscreen [[Text]]
origlines) ([[Text]] -> [Text]
forall {a}. [[a]] -> [a]
onscreen [[Text]]
newlines)
			IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ([ConsoleRegion], [R], [[Text]]) -> Int -> Barrier -> IO ()
go ([ConsoleRegion], [R], [[Text]])
snapshot Int
origwidth Barrier
origbarrier
		IO ()
next <- case DisplayChange
change of
			RegionChange ([ConsoleRegion], [R], [[Text]])
snapshot -> ([ConsoleRegion], [R], [[Text]]) -> IO (IO ())
update ([ConsoleRegion], [R], [[Text]])
snapshot
			RegionListChange ([ConsoleRegion], [R], [[Text]])
snapshot -> ([ConsoleRegion], [R], [[Text]]) -> IO (IO ())
update ([ConsoleRegion], [R], [[Text]])
snapshot
			BufferChange (StdHandle
h, OutputBuffer
buf) -> do
				-- Note that even when every available line
				-- is dedicated to visible regions, the
				-- buffer is still displayed. It would be
				-- more efficient to not display it, but
				-- this makes it available in scroll back.
				let origlines' :: [Text]
origlines' = [[Text]] -> [Text]
forall {a}. [[a]] -> [a]
onscreen [[Text]]
origlines
				Bool -> Int -> [Text] -> IO () -> IO ()
inAreaAbove Bool
isterm ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
origlines') [Text]
origlines' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
					StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer StdHandle
h OutputBuffer
buf
				IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ([ConsoleRegion], [R], [[Text]]) -> Int -> Barrier -> IO ()
go ([ConsoleRegion], [R], [[Text]])
origsnapshot Int
origwidth Barrier
origbarrier
			TerminalResize Int
newwidth -> do
				[[Text]]
newlines <- STM [[Text]] -> IO [[Text]]
forall a. STM a -> IO a
atomically ((ConsoleRegion -> STM [Text]) -> [ConsoleRegion] -> STM [[Text]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int -> ConsoleRegion -> STM [Text]
resizeRegion Int
newwidth) [ConsoleRegion]
orighandles)
				Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
					[Text] -> IO ()
resizeRecovery ([[Text]] -> [Text]
forall {a}. [[a]] -> [a]
onscreen [[Text]]
newlines)
				IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ([ConsoleRegion], [R], [[Text]]) -> Int -> Barrier -> IO ()
go ([ConsoleRegion]
orighandles, [R]
origregions, [[Text]]
newlines) Int
newwidth Barrier
origbarrier
			DisplayChange
Shutdown ->
				IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
			DisplayChangeBarrier Barrier
b ->
				IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ([ConsoleRegion], [R], [[Text]]) -> Int -> Barrier -> IO ()
go ([ConsoleRegion], [R], [[Text]])
origsnapshot Int
origwidth Barrier
b
		Handle -> IO ()
hFlush Handle
stdout
		STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan DisplayChange -> DisplayChange -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan DisplayChange
displayUpdateNotifier DisplayChange
change
		IO ()
next

readRegions :: [ConsoleRegion] -> STM [R]
readRegions :: [ConsoleRegion] -> STM [R]
readRegions = (ConsoleRegion -> STM R) -> [ConsoleRegion] -> STM [R]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(ConsoleRegion TVar R
h) -> TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
h)

-- | Wait for any changes to the region list, eg adding or removing a region.
regionListWaiter :: RegionSnapshot -> STM RegionSnapshot
regionListWaiter :: ([ConsoleRegion], [R], [[Text]])
-> STM ([ConsoleRegion], [R], [[Text]])
regionListWaiter ([ConsoleRegion]
orighandles, [R]
_origregions, [[Text]]
origlines) = do
	[ConsoleRegion]
handles <- TMVar [ConsoleRegion] -> STM [ConsoleRegion]
forall a. TMVar a -> STM a
readTMVar TMVar [ConsoleRegion]
regionList
	if [ConsoleRegion]
handles [ConsoleRegion] -> [ConsoleRegion] -> Bool
forall a. Eq a => a -> a -> Bool
== [ConsoleRegion]
orighandles
		then STM ([ConsoleRegion], [R], [[Text]])
forall a. STM a
retry
		else do
			[R]
rs <- [ConsoleRegion] -> STM [R]
readRegions [ConsoleRegion]
handles
			([ConsoleRegion], [R], [[Text]])
-> STM ([ConsoleRegion], [R], [[Text]])
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ConsoleRegion]
handles, [R]
rs, [[Text]]
origlines)

-- Wait for any changes to any of the contents of regions currently in the
-- region list.
regionWaiter :: RegionSnapshot -> Width -> STM RegionSnapshot
regionWaiter :: ([ConsoleRegion], [R], [[Text]])
-> Int -> STM ([ConsoleRegion], [R], [[Text]])
regionWaiter ([ConsoleRegion]
orighandles, [R]
_origregions, [[Text]]
origlines) Int
width = do
	[R]
rs <- [ConsoleRegion] -> STM [R]
readRegions [ConsoleRegion]
orighandles
	[[Text]]
newlines <- (R -> STM [Text]) -> [R] -> STM [[Text]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM R -> STM [Text]
getr [R]
rs
	Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Text]]
newlines [[Text]] -> [[Text]] -> Bool
forall a. Eq a => a -> a -> Bool
/= [[Text]]
origlines)
		STM ()
forall a. STM a
retry
	([ConsoleRegion], [R], [[Text]])
-> STM ([ConsoleRegion], [R], [[Text]])
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ConsoleRegion]
orighandles, [R]
rs, [[Text]]
newlines)
  where
	getr :: R -> STM [Text]
getr R
r = R -> Int -> STM [Text]
calcRegionLines R
r Int
width

-- This is not an optimal screen update like curses can do, but it's
-- pretty efficient, most of the time!
changedLines :: [Text] -> [Text] -> IO ()
changedLines :: [Text] -> [Text] -> IO ()
changedLines [Text]
origlines [Text]
newlines
	| Int
delta Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = do
		-- The total number of lines is unchanged, so update
		-- whichever ones have changed, and leave the rest as-is.
		[Text] -> [Text] -> IO ()
diffUpdate [Text]
origlines [Text]
newlines
	| Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = do
		-- Added more lines, so output each, with a
		-- newline, thus scrolling the old lines up
		-- the screen. (We can do this, because the cursor
		-- is left below the first line.)
		let addedlines :: [Text]
addedlines = [Text] -> [Text]
forall a. [a] -> [a]
reverse (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
delta [Text]
newlines)
		[Text] -> IO ()
displayLines [Text]
addedlines
		-- Some existing lines may have also changed..
		let scrolledlines :: [Text]
scrolledlines = [Text]
addedlines [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
origlines
		[Text] -> [Text] -> IO ()
diffUpdate [Text]
scrolledlines [Text]
newlines
	| Bool
otherwise = do
		-- Some lines were removed. Move up that many lines,
		-- clearing each line, and update any changed lines.
		Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (Int -> Int
forall a. Num a => a -> a
abs Int
delta) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
			Int -> IO ()
setCursorColumn Int
0
			Int -> IO ()
cursorUp Int
1
			IO ()
clearLine
		[Text] -> [Text] -> IO ()
diffUpdate (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop (Int -> Int
forall a. Num a => a -> a
abs Int
delta) [Text]
origlines) [Text]
newlines
  where
	delta :: Int
delta = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
newlines Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
origlines

diffUpdate :: [Text] -> [Text] -> IO ()
diffUpdate :: [Text] -> [Text] -> IO ()
diffUpdate [Text]
old [Text]
new = [((Text, Bool), Text)] -> IO ()
updateLines ([(Text, Bool)] -> [Text] -> [((Text, Bool), Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Text] -> [Bool] -> [(Text, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
new [Bool]
changed) [Text]
old)
  where
	changed :: [Bool]
changed = ((Text, Text) -> Bool) -> [(Text, Text)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text -> Bool) -> (Text, Text) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(/=)) ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
new [Text]
old) [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True

changeOffsets :: [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets :: forall r.
[((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [] Int
_ [((r, Int), r)]
c = [((r, Int), r)] -> [((r, Int), r)]
forall a. [a] -> [a]
reverse [((r, Int), r)]
c
changeOffsets (((r
new, Bool
changed), r
old):[((r, Bool), r)]
rs) Int
n [((r, Int), r)]
c
	| Bool
changed = [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
forall r.
[((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [((r, Bool), r)]
rs Int
1 (((r
new, Int
n), r
old)((r, Int), r) -> [((r, Int), r)] -> [((r, Int), r)]
forall a. a -> [a] -> [a]
:[((r, Int), r)]
c)
	| Bool
otherwise = [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
forall r.
[((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [((r, Bool), r)]
rs (Int -> Int
forall a. Enum a => a -> a
succ Int
n) [((r, Int), r)]
c

-- Displays lines that are paired with True, and skips over the rest.
-- Cursor is assumed to be just below the first line at the
-- beginning, and is put back there at the end.
updateLines :: [((Text, Bool), Text)] -> IO ()
updateLines :: [((Text, Bool), Text)] -> IO ()
updateLines [((Text, Bool), Text)]
l
	| [((Text, Int), Text)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((Text, Int), Text)]
l' = IO ()
forall (m :: * -> *). Monad m => m ()
noop
	| Bool
otherwise = do
		[((Text, Int), Text)] -> (((Text, Int), Text) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((Text, Int), Text)]
l' ((((Text, Int), Text) -> IO ()) -> IO ())
-> (((Text, Int), Text) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \((Text
newt, Int
offset), Text
oldt) -> do
			Int -> IO ()
setCursorColumn Int
0
			Int -> IO ()
cursorUp Int
offset
#ifndef mingw32_HOST_OS
			Handle -> Text -> IO ()
T.hPutStr Handle
stdout (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
				[LineUpdate] -> Text
genLineUpdate ([LineUpdate] -> Text) -> [LineUpdate] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [LineUpdate]
calcLineUpdate Text
oldt Text
newt
#else
			-- Windows does not support ansi characters
			-- emitted in a string, so do a full line
			-- redraw.
			T.hPutStr stdout newt
			clearFromCursorToLineEnd
#endif
		Int -> IO ()
cursorDown ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((((Text, Int), Text) -> Int) -> [((Text, Int), Text)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, Int) -> Int
forall a b. (a, b) -> b
snd ((Text, Int) -> Int)
-> (((Text, Int), Text) -> (Text, Int))
-> ((Text, Int), Text)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Int), Text) -> (Text, Int)
forall a b. (a, b) -> a
fst) [((Text, Int), Text)]
l'))
		Int -> IO ()
setCursorColumn Int
0
  where
	l' :: [((Text, Int), Text)]
l' = [((Text, Bool), Text)]
-> Int -> [((Text, Int), Text)] -> [((Text, Int), Text)]
forall r.
[((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [((Text, Bool), Text)]
l Int
1 []

-- Recover from a resize by redrawing all region lines.
--
-- The resize can change the position of the cursor, which would garble
-- the display going forward. To fix, the cursor is moved to the top of
-- the screen, which is cleared, and all regions are redrawn from there.
resizeRecovery :: [Text] -> IO ()
resizeRecovery :: [Text] -> IO ()
resizeRecovery [Text]
newlines = do
	Int -> Int -> IO ()
setCursorPosition Int
0 Int
0
	Bool -> Int -> [Text] -> IO () -> IO ()
inAreaAbove Bool
True Int
0 [Text]
newlines (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Move cursor up before the lines, performs some output there,
-- which will scroll down and overwrite the lines, so 
-- redraws all the lines below.
inAreaAbove :: Bool -> Int -> [Text] -> IO () -> IO ()
inAreaAbove :: Bool -> Int -> [Text] -> IO () -> IO ()
inAreaAbove Bool
isterm Int
numlines [Text]
ls IO ()
outputter = do
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
numlines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
			Int -> IO ()
setCursorColumn Int
0
			Int -> IO ()
cursorUp (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
numlines
		IO ()
clearFromCursorToScreenEnd
	-- Flush stdout now, because the outputter may write to stderr, so
	-- the cursor needs to be moved first.
	Handle -> IO ()
hFlush Handle
stdout
	IO ()
outputter
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		Int -> IO ()
setCursorColumn Int
0 -- just in case the output lacked a newline
		[Text] -> IO ()
displayLines ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
ls)

displayLines :: [Text] -> IO ()
displayLines :: [Text] -> IO ()
displayLines = (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Text -> IO ()) -> [Text] -> IO ())
-> (Text -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
l -> do
	Handle -> Text -> IO ()
T.hPutStr Handle
stdout Text
l
	Char -> IO ()
putChar Char
'\n'

installResizeHandler :: Maybe (IO ()) -> IO ()
#ifndef mingw32_HOST_OS
#ifdef VERSION_terminal_size
installResizeHandler :: Maybe (IO ()) -> IO ()
installResizeHandler Maybe (IO ())
h = IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$
	Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
windowChange (Handler -> (IO () -> Handler) -> Maybe (IO ()) -> Handler
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Handler
Default IO () -> Handler
Catch Maybe (IO ())
h) Maybe SignalSet
forall a. Maybe a
Nothing
#else
installResizeHandler _ = return ()
#endif
#else
installResizeHandler _ = return ()
#endif

calcRegionLines :: R -> Width -> STM [Text]
calcRegionLines :: R -> Int -> STM [Text]
calcRegionLines R
r Int
width = do
	Text
t <- R -> Text -> STM Text
regionRender R
r (Text -> STM Text) -> STM Text -> STM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RegionContent -> STM Text
readRegionContent (R -> RegionContent
regionContent R
r)
	[Text] -> STM [Text]
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> STM [Text]) -> [Text] -> STM [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Int -> [Text]
calcLines Text
t Int
width

-- | Splits a Text into the lines it would display using when output onto
-- a console with a given width, starting from the first column.
--
-- ANSI SGR sequences are handled specially, so that color, etc settings
-- work despite the lines being split up, and the lines can be output
-- indepedently. For example, "foooREDbar bazRESET" when split into lines
-- becomes ["fooREDbarRESET", "RED bazRESET"]
calcLines :: Text -> Width -> [Text]
calcLines :: Text -> Int -> [Text]
calcLines Text
t Int
width
	| Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
t = [Text
t] -- even an empty text is 1 line high
	| Bool
otherwise = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [] [] Int
0 Int
1 (Text -> Int
T.length Text
t) Text
t

calcLines' :: Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' :: Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [Text]
collectedlines [Text]
collectedSGR Int
i Int
displaysize Int
len Text
t
	| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
		then [Text] -> [Text]
forall a. [a] -> [a]
reverse (Text -> [Text]
finishline Text
t)
		else [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
collectedlines
	| Char
t1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width (Text -> [Text]
finishline (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
T.init Text
currline)
		[] Int
0 Int
1 (Text -> Int
T.length Text
rest) (Text -> Text
contSGR Text
rest)
	-- ANSI escape sequences do not take up space on screen.
	| Char
t1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\ESC' Bool -> Bool -> Bool
&& Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len = case HasCallStack => Text -> Int -> Char
Text -> Int -> Char
T.index Text
t (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) of
		Char
'[' -> (Char -> Bool) -> Bool -> [Text]
skipansi Char -> Bool
endCSI Bool
True
		Char
']' -> (Char -> Bool) -> Bool -> [Text]
skipansi Char -> Bool
endOSC Bool
False
		Char
_ -> Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [Text]
collectedlines [Text]
collectedSGR (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
displaysize Int
len Text
t
	-- Control characters do not take up space on screen.
	| Char -> Bool
isControl Char
t1 = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [Text]
collectedlines [Text]
collectedSGR (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
displaysize Int
len Text
t
	| Int
displaysize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
width = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width (Text -> [Text]
finishline Text
currline)
		[] Int
0 Int
1 (Text -> Int
T.length Text
rest) (Text -> Text
contSGR Text
rest)
	| Bool
otherwise = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [Text]
collectedlines [Text]
collectedSGR (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
displaysizeInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
len Text
t
  where
	t1 :: Char
t1 = HasCallStack => Text -> Int -> Char
Text -> Int -> Char
T.index Text
t Int
i
	(Text
currline, Text
rest) = Int -> Text -> (Text, Text)
T.splitAt (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Text
t

	skipansi :: (Char -> Bool) -> Bool -> [Text]
skipansi Char -> Bool
toend Bool
isCSI = case (Char -> Bool) -> Text -> Maybe Int
T.findIndex Char -> Bool
toend (Int -> Text -> Text
T.drop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Text
t) of
		Just Int
csiend -> Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [Text]
collectedlines 
			(Int -> [Text]
addSGR (Int
csiendInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
csiend) (Int
displaysizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
len Text
t
		Maybe Int
Nothing -> [Text] -> [Text]
forall a. [a] -> [a]
reverse (Text -> [Text]
finishline Text
t)
	  where
		addSGR :: Int -> [Text]
addSGR Int
csiend
			| Bool -> Bool
not Bool
isCSI = [Text]
collectedSGR
			| Text
ansicode Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
resetSGR = []
			| Bool -> Bool
not (Text -> Bool
T.null Text
ansicode) Bool -> Bool -> Bool
&& HasCallStack => Text -> Char
Text -> Char
T.last Text
ansicode Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
endSGR =
				Text
ansicode Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
collectedSGR
			| Bool
otherwise = [Text]
collectedSGR
		  where
			ansicode :: Text
ansicode = Int -> Text -> Text
T.take (Int
csiend Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Text -> Text
T.drop Int
i Text
t)
	finishline :: Text -> [Text]
finishline Text
l = Text -> Text
closeSGR Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
collectedlines
	-- Close any open SGR codes at end of line
	closeSGR :: Text -> Text
closeSGR Text
l
		| [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
collectedSGR = Text
l
		| Bool
otherwise = Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resetSGR
	-- Continue any open SGR codes from previous line
	contSGR :: Text -> Text
contSGR Text
l = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
collectedSGR) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l

resetSGR :: Text
resetSGR :: Text
resetSGR = String -> Text
T.pack ([SGR] -> String
setSGRCode [SGR
Reset])

endCSI :: Char -> Bool
endCSI :: Char -> Bool
endCSI Char
c = let o :: Int
o = Char -> Int
ord Char
c in Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
64 Bool -> Bool -> Bool
&& Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
127

endOSC :: Char -> Bool
endOSC :: Char -> Bool
endOSC Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\BEL'

endSGR :: Char
endSGR :: Char
endSGR = Char
'm'

#ifndef mingw32_HOST_OS

-- | Finds the least expensive output to make a console that was displaying
-- the old line display the new line. Cursor starts at far left.
--
-- Basically, loop through and find spans where the old and new line are
-- the same. Generate cursorForwardCode ANSI sequences to skip over those
-- spans, unless such a sequence would be longer than the span it's skipping.
--
-- Since ANSI sequences can be present in the line, need to take them
-- into account. Generally, each of the sequences in new has to be included,
-- even if old contained the same sequence:
--
-- > old: GREENfoofoofooREDbarbarbarRESETbaz
-- > new: GREENfoofoofooREDxarbarbaxRESETbaz
-- > ret: GREEN-------->REDx------>yRESET
--
-- (The first GREEN does not effect any output text, so it can be elided.)
-- 
-- Also, despite old having the same second span as new, in the same
-- location, that span has to be re-emitted because its color changed:
-- 
-- > old: GREENfoofooREDbarbarbarbarbar
-- > new: GREENfoofoofooTANbarbarbar
-- > ret: GREEN----->fooTANbarbarbarCLEARREST
--
-- Also note above that the sequence has to clear the rest of the line,
-- since the new line is shorter than the old.
calcLineUpdate :: Text -> Text -> [LineUpdate]
calcLineUpdate :: Text -> Text -> [LineUpdate]
calcLineUpdate Text
old Text
new = 
	[LineUpdate] -> [LineUpdate]
forall a. [a] -> [a]
reverse ([LineUpdate] -> [LineUpdate]) -> [LineUpdate] -> [LineUpdate]
forall a b. (a -> b) -> a -> b
$ (Maybe Char, Text, [LineUpdate], [LineUpdate])
-> (Maybe Char, Text, [LineUpdate], [LineUpdate]) -> [LineUpdate]
go
		(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
old [] [])
		(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
new [] [])
  where
	go :: (Maybe Char, Text, [LineUpdate], [LineUpdate])
-> (Maybe Char, Text, [LineUpdate], [LineUpdate]) -> [LineUpdate]
go (Just Char
_, Text
_, [LineUpdate]
_, [LineUpdate]
_) (Maybe Char
Nothing, Text
_, [LineUpdate]
past, [LineUpdate]
_) = LineUpdate
ClearToEnd LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: [LineUpdate]
past
	go (Maybe Char
Nothing, Text
_, [LineUpdate]
_, [LineUpdate]
_) (Maybe Char
Nothing, Text
_, [LineUpdate]
past, [LineUpdate]
_) = [LineUpdate]
past
	go (Maybe Char
Nothing, Text
_, [LineUpdate]
_, [LineUpdate]
_) (Just Char
n, Text
ns, [LineUpdate]
past, [LineUpdate]
_) =
		Text -> LineUpdate
Display Text
ns LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: Text -> LineUpdate
Display (Char -> Text
T.singleton Char
n) LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: [LineUpdate]
past
	go (Just Char
o, Text
os, [LineUpdate]
_, [LineUpdate]
oinvis) (Just Char
n, Text
ns, [LineUpdate]
past, [LineUpdate]
ninvis)
		| Char
o Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
n Bool -> Bool -> Bool
&& [LineUpdate]
oinvis [LineUpdate] -> [LineUpdate] -> Bool
forall a. Eq a => a -> a -> Bool
== [LineUpdate]
ninvis = (Maybe Char, Text, [LineUpdate], [LineUpdate])
-> (Maybe Char, Text, [LineUpdate], [LineUpdate]) -> [LineUpdate]
go
			(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
os [] [LineUpdate]
oinvis)
			(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
ns (String -> LineUpdate
Skip [Char
o] LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: [LineUpdate]
past) [LineUpdate]
ninvis)
		| Bool
otherwise = (Maybe Char, Text, [LineUpdate], [LineUpdate])
-> (Maybe Char, Text, [LineUpdate], [LineUpdate]) -> [LineUpdate]
go
			(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
os [] [LineUpdate]
oinvis)
			(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
ns (Text -> LineUpdate
Display (Char -> Text
T.singleton Char
n) LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: [LineUpdate]
past) [LineUpdate]
ninvis)

type Past = [LineUpdate]
type Invis = [LineUpdate]

-- Find next character of t that is not a ANSI escape sequence
-- or control char. Any such passed on the way to the character
-- are prepended to past, and added to invis.
--
-- resetSGR is handled specially; it causes all SGRs to be removed from
-- invis, It's still prepended to past.
advanceLine :: Text -> Past -> Invis -> (Maybe Char, Text, Past, Invis)
advanceLine :: Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
t [LineUpdate]
past [LineUpdate]
invis
	| Text -> Bool
T.null Text
t = (Maybe Char
forall a. Maybe a
Nothing, Text
T.empty, [LineUpdate]
past, [LineUpdate]
invis)
	| Bool
otherwise = case HasCallStack => Text -> Char
Text -> Char
T.head Text
t of
		Char
'\ESC' -> case Int -> Text -> Text
T.drop Int
1 Text
t of
			Text
t' | Text -> Bool
T.null Text
t' -> Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine (Int -> Text -> Text
T.drop Int
1 Text
t)
				(String -> LineUpdate
Skip String
"\ESC"LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
past) (String -> LineUpdate
Skip String
"\ESC"LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
invis)
			   | Bool
otherwise -> case HasCallStack => Text -> Char
Text -> Char
T.head Text
t' of
			   	Char
'[' -> (Char -> Bool) -> (Maybe Char, Text, [LineUpdate], [LineUpdate])
skipansi Char -> Bool
endCSI
				Char
']' -> (Char -> Bool) -> (Maybe Char, Text, [LineUpdate], [LineUpdate])
skipansi Char -> Bool
endOSC
				Char
c -> (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c, Int -> Text -> Text
T.drop Int
2 Text
t, String -> LineUpdate
Skip String
"\ESC"LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
past, String -> LineUpdate
Skip String
"\ESC"LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
invis)
		Char
c | Char -> Bool
isControl Char
c -> Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine (Int -> Text -> Text
T.drop Int
1 Text
t) (String -> LineUpdate
Skip [Char
c]LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
past) (String -> LineUpdate
Skip [Char
c]LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
invis)
		  | Bool
otherwise -> (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c, Int -> Text -> Text
T.drop Int
1 Text
t, [LineUpdate]
past, [LineUpdate]
invis)
  where
	skipansi :: (Char -> Bool) -> (Maybe Char, Text, [LineUpdate], [LineUpdate])
skipansi Char -> Bool
toend = case (Char -> Bool) -> Text -> Maybe Int
T.findIndex Char -> Bool
toend (Int -> Text -> Text
T.drop Int
2 Text
t) of
		Just Int
csiend -> 
			let sgr :: LineUpdate
sgr = Text -> LineUpdate
SGR (Int -> Text -> Text
T.take (Int
csiendInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3) Text
t)
			in Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine (Int -> Text -> Text
T.drop (Int
csiendInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3) Text
t)
				(LineUpdate
sgrLineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
past) (LineUpdate -> [LineUpdate] -> [LineUpdate]
addsgr LineUpdate
sgr [LineUpdate]
invis)
		Maybe Int
Nothing -> (Maybe Char
forall a. Maybe a
Nothing, Text
T.empty, [LineUpdate]
past, [LineUpdate]
invis)
	addsgr :: LineUpdate -> [LineUpdate] -> [LineUpdate]
addsgr (SGR Text
sgrt) [LineUpdate]
l
		| Text
sgrt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
resetSGR = (LineUpdate -> Bool) -> [LineUpdate] -> [LineUpdate]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LineUpdate -> Bool) -> LineUpdate -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineUpdate -> Bool
isSGR) [LineUpdate]
l
	addsgr LineUpdate
s [LineUpdate]
l = LineUpdate
sLineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
l

data LineUpdate = Display Text | Skip [Char] | SGR Text | ClearToEnd
	deriving (LineUpdate -> LineUpdate -> Bool
(LineUpdate -> LineUpdate -> Bool)
-> (LineUpdate -> LineUpdate -> Bool) -> Eq LineUpdate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LineUpdate -> LineUpdate -> Bool
== :: LineUpdate -> LineUpdate -> Bool
$c/= :: LineUpdate -> LineUpdate -> Bool
/= :: LineUpdate -> LineUpdate -> Bool
Eq, Int -> LineUpdate -> ShowS
[LineUpdate] -> ShowS
LineUpdate -> String
(Int -> LineUpdate -> ShowS)
-> (LineUpdate -> String)
-> ([LineUpdate] -> ShowS)
-> Show LineUpdate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LineUpdate -> ShowS
showsPrec :: Int -> LineUpdate -> ShowS
$cshow :: LineUpdate -> String
show :: LineUpdate -> String
$cshowList :: [LineUpdate] -> ShowS
showList :: [LineUpdate] -> ShowS
Show)

isSGR :: LineUpdate -> Bool
isSGR :: LineUpdate -> Bool
isSGR (SGR Text
_) = Bool
True
isSGR LineUpdate
_ = Bool
False

genLineUpdate :: [LineUpdate] -> Text
genLineUpdate :: [LineUpdate] -> Text
genLineUpdate [LineUpdate]
l = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (LineUpdate -> Text) -> [LineUpdate] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map LineUpdate -> Text
tot ([LineUpdate] -> [LineUpdate]
optimiseLineUpdate [LineUpdate]
l)
  where
	tot :: LineUpdate -> Text
tot (Display Text
t) = Text
t
	tot (Skip String
s)
		-- length (cursorForwardCode 1) == 4 so there's no point
		-- generating that for a skip of less than 5.
		| Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5 = String -> Text
T.pack String
s
		| Bool
otherwise = String -> Text
T.pack (Int -> String
cursorForwardCode Int
len)
	  where
		len :: Int
len = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
	tot (SGR Text
t) = Text
t
	tot LineUpdate
ClearToEnd = String -> Text
T.pack String
clearFromCursorToLineEndCode

optimiseLineUpdate :: [LineUpdate] -> [LineUpdate]
optimiseLineUpdate :: [LineUpdate] -> [LineUpdate]
optimiseLineUpdate = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go []
  where
	-- elide trailing Skips
	go :: [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go (Skip String
_:[LineUpdate]
rest) [] = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go [LineUpdate]
rest []
	-- elide SGRs at the end of the line, except for the reset SGR
	go (SGR Text
t:[LineUpdate]
rest) [] | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
resetSGR = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go [LineUpdate]
rest []
	go [LineUpdate]
c [] = [LineUpdate] -> [LineUpdate]
forall a. [a] -> [a]
reverse [LineUpdate]
c
	-- combine adjacent SGRs and Skips
	go [LineUpdate]
c (SGR Text
t1:Skip String
s:SGR Text
t2:[LineUpdate]
rest) = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
tryharder [LineUpdate]
c (Text -> LineUpdate
SGR (Text -> Text -> Text
combineSGR Text
t1 Text
t2)LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:String -> LineUpdate
Skip String
sLineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
rest)
	go [LineUpdate]
c (Skip String
s:Skip String
s':[LineUpdate]
rest) = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
tryharder [LineUpdate]
c (String -> LineUpdate
Skip (String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
s')LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
rest)
	go [LineUpdate]
c (SGR Text
t1:SGR Text
t2:[LineUpdate]
rest) = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
tryharder [LineUpdate]
c (Text -> LineUpdate
SGR (Text -> Text -> Text
combineSGR Text
t1 Text
t2)LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
rest)
	go [LineUpdate]
c (LineUpdate
v:[LineUpdate]
rest) = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go (LineUpdate
vLineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
c) [LineUpdate]
rest
	tryharder :: [LineUpdate] -> [LineUpdate] -> [LineUpdate]
tryharder [LineUpdate]
c [LineUpdate]
l = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go [] ([LineUpdate] -> [LineUpdate]
forall a. [a] -> [a]
reverse [LineUpdate]
c [LineUpdate] -> [LineUpdate] -> [LineUpdate]
forall a. [a] -> [a] -> [a]
++ [LineUpdate]
l)

-- Parse and combine 2 ANSI SGR sequences into one.
combineSGR :: Text -> Text -> Text
combineSGR :: Text -> Text -> Text
combineSGR Text
a Text
b = case [Maybe Int] -> [Maybe Int] -> Maybe [Int]
combineSGRCodes (Text -> [Maybe Int]
codes Text
a) (Text -> [Maybe Int]
codes Text
b) of
	Maybe [Int]
Nothing -> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b
	Just [Int]
cs -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"\ESC[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
";" ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show [Int]
cs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"m"
  where
	codes :: Text -> [Maybe Int]
codes = (Text -> Maybe Int) -> [Text] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> [Maybe Int]) -> (Text -> [Text]) -> Text -> [Maybe Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
		(Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
2 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text
Text -> Text
T.init

-- Prefers values from the second sequence when there's a conflict with
-- values from the first sequence.
combineSGRCodes :: [Maybe Int] -> [Maybe Int] -> Maybe [Int]
combineSGRCodes :: [Maybe Int] -> [Maybe Int] -> Maybe [Int]
combineSGRCodes [Maybe Int]
as [Maybe Int]
bs =
	((ConsoleLayer, Int) -> Int) -> [(ConsoleLayer, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (ConsoleLayer, Int) -> Int
forall a b. (a, b) -> b
snd ([(ConsoleLayer, Int)] -> [Int])
-> ([(ConsoleLayer, Int)] -> [(ConsoleLayer, Int)])
-> [(ConsoleLayer, Int)]
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConsoleLayer, Int) -> (ConsoleLayer, Int) -> Bool)
-> [(ConsoleLayer, Int)] -> [(ConsoleLayer, Int)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(ConsoleLayer, Int)
a (ConsoleLayer, Int)
b -> (ConsoleLayer, Int) -> ConsoleLayer
forall a b. (a, b) -> a
fst (ConsoleLayer, Int)
a ConsoleLayer -> ConsoleLayer -> Bool
forall a. Eq a => a -> a -> Bool
== (ConsoleLayer, Int) -> ConsoleLayer
forall a b. (a, b) -> a
fst (ConsoleLayer, Int)
b) ([(ConsoleLayer, Int)] -> [Int])
-> Maybe [(ConsoleLayer, Int)] -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Int -> Maybe (ConsoleLayer, Int))
-> [Maybe Int] -> Maybe [(ConsoleLayer, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Maybe Int -> Maybe (ConsoleLayer, Int)
forall {a}. (Ord a, Num a) => Maybe a -> Maybe (ConsoleLayer, a)
range ([Maybe Int] -> [Maybe Int]
forall a. [a] -> [a]
reverse [Maybe Int]
bs [Maybe Int] -> [Maybe Int] -> [Maybe Int]
forall a. [a] -> [a] -> [a]
++ [Maybe Int] -> [Maybe Int]
forall a. [a] -> [a]
reverse [Maybe Int]
as)
  where
	range :: Maybe a -> Maybe (ConsoleLayer, a)
range Maybe a
Nothing = Maybe (ConsoleLayer, a)
forall a. Maybe a
Nothing
	range (Just a
x)
		| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
30 Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
37 = (ConsoleLayer, a) -> Maybe (ConsoleLayer, a)
forall a. a -> Maybe a
Just (ConsoleLayer
Foreground, a
x)
		| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
40 Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
47 = (ConsoleLayer, a) -> Maybe (ConsoleLayer, a)
forall a. a -> Maybe a
Just (ConsoleLayer
Background, a
x)
		| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
90 Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
97 = (ConsoleLayer, a) -> Maybe (ConsoleLayer, a)
forall a. a -> Maybe a
Just (ConsoleLayer
Foreground, a
x)
		| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
100 Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
107 = (ConsoleLayer, a) -> Maybe (ConsoleLayer, a)
forall a. a -> Maybe a
Just (ConsoleLayer
Background, a
x)
		| Bool
otherwise = Maybe (ConsoleLayer, a)
forall a. Maybe a
Nothing

#endif