{-# 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 qualified System.Console.Terminal.Size as Console
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Text.Read
import Data.List (intercalate, nubBy)
#ifndef mingw32_HOST_OS
import System.Posix.Signals
import System.Posix.Signals.Exts
#endif
import Control.Applicative
import Prelude

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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RegionLayout -> RegionLayout -> Bool
$c/= :: RegionLayout -> RegionLayout -> Bool
== :: RegionLayout -> RegionLayout -> Bool
$c== :: RegionLayout -> RegionLayout -> Bool
Eq)

-- | A handle allowing access to a region of the console.
newtype ConsoleRegion = ConsoleRegion (TVar R)
	deriving (ConsoleRegion -> ConsoleRegion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConsoleRegion -> ConsoleRegion -> Bool
$c/= :: ConsoleRegion -> ConsoleRegion -> Bool
== :: ConsoleRegion -> ConsoleRegion -> Bool
$c== :: 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 = forall a. IO a -> a
unsafePerformIO forall a. IO (TMVar a)
newEmptyTMVarIO

-- | On Unix systems, this TVar is automatically updated when the
-- terminal is resized. On Windows, it is only initialized on program start
-- with the current terminal size.
{-# NOINLINE consoleSize #-}
consoleSize :: TVar (Console.Window Int)
consoleSize :: TVar (Window Int)
consoleSize = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO forall a b. (a -> b) -> a -> b
$ 
	Console.Window { width :: Int
Console.width = Int
80, height :: Int
Console.height = 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 only initialized on program start.
consoleWidth :: STM Int
consoleWidth :: STM Int
consoleWidth = forall {a}. a -> a
munge forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Window a -> a
Console.width forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (Window Int)
consoleSize
  where
#ifndef mingw32_HOST_OS
	munge :: a -> a
munge = 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.
consoleHeight :: STM Int
consoleHeight :: STM Int
consoleHeight = forall a. Window a -> a
Console.height forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (Window Int)
consoleSize

-- | Check if `displayConsoleRegions` is running.
regionDisplayEnabled :: IO Bool
regionDisplayEnabled :: IO Bool
regionDisplayEnabled = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall {a}. a -> a
id

instance LiftRegion IO where
	liftRegion :: forall a. STM a -> IO a
liftRegion = 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 = forall v. Outputable v => v -> RegionContent
fromOutput

instance ToRegionContent Text where
	toRegionContent :: Text -> RegionContent
toRegionContent = 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 = forall v. Outputable v => v -> RegionContent
fromOutput

fromOutput :: Outputable v => v -> RegionContent
fromOutput :: forall v. Outputable v => v -> RegionContent
fromOutput = STM Text -> RegionContent
RegionContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion forall a b. (a -> b) -> a -> b
$
	ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion ConsoleRegion
r forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion forall a b. (a -> b) -> a -> b
$
	ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion ConsoleRegion
r forall a b. (a -> b) -> a -> b
$ \(RegionContent STM Text
a) ->
		forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ STM Text -> RegionContent
RegionContent forall a b. (a -> b) -> a -> b
$ do
			Text
t <- STM Text
a
			forall (m :: * -> *) a. Monad m => a -> m a
return (Text
t forall a. Semigroup a => a -> a -> a
<> 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 <- 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 :: RegionContent
regionContent = RegionContent
rc }
	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 <- forall a. TVar a -> STM a
readTVar TVar R
tv
	[Text]
ls <- R -> Int -> STM [Text]
calcRegionLines R
r Int
width
	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 = forall (m :: * -> *) v b a.
(MonadMask m, MonadIO m) =>
IO v -> (v -> IO b) -> (v -> m a) -> m a
bracketIO
	(forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
openConsoleRegion RegionLayout
ly)
	(forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion forall a b. (a -> b) -> a -> b
$ do
	ConsoleRegion
h <- 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 <- forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar [ConsoleRegion]
regionList
			case Maybe [ConsoleRegion]
ml of
				Just [ConsoleRegion]
l -> forall a. TMVar a -> a -> STM ()
putTMVar TMVar [ConsoleRegion]
regionList (ConsoleRegion
hforall 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
		InLine ConsoleRegion
parent -> ConsoleRegion -> ConsoleRegion -> STM ()
addChild ConsoleRegion
h ConsoleRegion
parent
	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 = forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion forall a b. (a -> b) -> a -> b
$ do
	TVar [ConsoleRegion]
cs <- forall a. a -> STM (TVar a)
newTVar forall a. Monoid a => a
mempty
	let r :: R
r = R
		{ regionContent :: RegionContent
regionContent = STM Text -> RegionContent
RegionContent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
		, regionRender :: Text -> STM Text
regionRender = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> STM (TVar a)
newTVar R
r
	ConsoleRegion -> STM ()
displayChildren ConsoleRegion
h
	forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
setConsoleRegion ConsoleRegion
h v
v
	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) = forall (m :: * -> *).
LiftRegion m =>
ConsoleRegion -> (Text -> STM Text) -> m ()
tuneDisplay ConsoleRegion
p forall a b. (a -> b) -> a -> b
$ \Text
t -> do
	[ConsoleRegion]
children <- forall a. TVar a -> STM a
readTVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. R -> TVar [ConsoleRegion]
regionChildren forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. TVar a -> STM a
readTVar TVar R
tv
	Text
ct <- [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConsoleRegion -> STM Text
getc [ConsoleRegion]
children
	forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
t forall a. Semigroup a => a -> a -> a
<> Text
ct
  where
	getc :: ConsoleRegion -> STM Text
getc (ConsoleRegion TVar R
cv) = do
		R
c <- forall a. TVar a -> STM a
readTVar TVar R
cv
		R -> Text -> STM Text
regionRender R
c 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) = forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion forall a b. (a -> b) -> a -> b
$ do
	Maybe [ConsoleRegion]
v <- forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar [ConsoleRegion]
regionList
	case Maybe [ConsoleRegion]
v of
		Just [ConsoleRegion]
l ->
			let !l' :: [ConsoleRegion]
l' = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= ConsoleRegion
h) [ConsoleRegion]
l
			in forall a. TMVar a -> a -> STM ()
putTMVar TMVar [ConsoleRegion]
regionList [ConsoleRegion]
l'
		Maybe [ConsoleRegion]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
	RegionLayout
ly <- R -> RegionLayout
regionLayout forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar R
tv
	case RegionLayout
ly of
		RegionLayout
Linear -> 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 = forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion forall a b. (a -> b) -> a -> b
$ do
	forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m ()
closeConsoleRegion ConsoleRegion
h
	forall v. Outputable v => StdHandle -> v -> STM ()
bufferOutputSTM StdHandle
StdOut (forall v. Outputable v => v -> Text
toOutput v
v forall a. Semigroup a => a -> a -> a
<> 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) = forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion forall a b. (a -> b) -> a -> b
$
	RegionContent -> STM Text
readRegionContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. R -> RegionContent
regionContent forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion forall a b. (a -> b) -> a -> b
$ do
	R
r <- forall a. TVar a -> STM a
readTVar TVar R
tv
	let rr :: Text -> STM Text
rr = \Text
t -> Text -> STM Text
renderer 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 :: Text -> STM Text
regionRender = Text -> STM Text
rr }
	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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar R
pv
	[ConsoleRegion]
children <- forall a. TVar a -> STM a
readTVar TVar [ConsoleRegion]
cv
	let !children' :: [ConsoleRegion]
children' = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= ConsoleRegion
child) [ConsoleRegion]
children forall a. [a] -> [a] -> [a]
++ [ConsoleRegion
child]
	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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar R
pv
	forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [ConsoleRegion]
cv (forall a. (a -> Bool) -> [a] -> [a]
filter (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 = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
regionDisplayEnabled)
	( m a
a -- displayConsoleRegions is already running
	, forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
lockOutput forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m (Bool, Async (), TSem)
setup forall {m :: * -> *} {a}.
MonadIO m =>
(Bool, Async a, TSem) -> m ()
cleanup (forall a b. a -> b -> a
const m a
a)
	)
  where
	setup :: m (Bool, Async (), TSem)
setup = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
uninterruptibleMask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
		forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar [ConsoleRegion]
regionList []
		TSem
endsignal <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
			TSem
s <- Barrier -> STM TSem
newTSem Barrier
1
			TSem -> STM ()
waitTSem TSem
s
			forall (m :: * -> *) a. Monad m => a -> m a
return TSem
s
		Bool
isterm <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hSupportsANSI Handle
stdout
		forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (forall a. IO a -> IO a
unmask IO ()
trackConsoleWidth)
		Async ()
da <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ Bool -> TSem -> IO ()
displayThread Bool
isterm TSem
endsignal
		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) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ do
		forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ TSem -> STM ()
signalTSem TSem
endsignal
		forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO a
wait Async a
da
		forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar [ConsoleRegion]
regionList
		forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm forall a b. (a -> b) -> a -> b
$
			Maybe (IO ()) -> IO ()
installResizeHandler forall a. Maybe a
Nothing

trackConsoleWidth :: IO ()
trackConsoleWidth :: IO ()
trackConsoleWidth = do
	let getsz :: IO ()
getsz = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). Monad m => m ()
noop (forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> a -> STM ()
writeTVar TVar (Window Int)
consoleSize)
		forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall n. Integral n => IO (Maybe (Window n))
Console.size
	IO ()
getsz
	Maybe (IO ()) -> IO ()
installResizeHandler (forall a. a -> Maybe a
Just IO ()
getsz)

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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. IO (TChan a)
newBroadcastTChanIO

{-# NOINLINE displayChangeBarrier #-}
displayChangeBarrier :: TVar Barrier
displayChangeBarrier :: TVar Barrier
displayChangeBarrier = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ 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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM (TChan a)
dupTChan TChan DisplayChange
displayUpdateNotifier
	TMVar (Barrier, a)
bv <- forall a. IO (TMVar a)
newEmptyTMVarIO
	((), ())
_ <- TMVar (Barrier, a) -> IO ()
setbarrier TMVar (Barrier, a)
bv forall a b. IO a -> IO b -> IO (a, b)
`concurrently` forall {b}. TChan DisplayChange -> TMVar (Barrier, b) -> IO ()
waitchange TChan DisplayChange
c TMVar (Barrier, a)
bv
	forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. STM a -> IO a
atomically (forall a. TMVar a -> STM a
readTMVar TMVar (Barrier, a)
bv)
  where
	setbarrier :: TMVar (Barrier, a) -> IO ()
setbarrier TMVar (Barrier, a)
bv = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
		!Barrier
b <- forall a. Enum a => a -> a
succ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar Barrier
displayChangeBarrier
		a
r <- STM a
a
		forall a. TVar a -> a -> STM ()
writeTVar TVar Barrier
displayChangeBarrier Barrier
b
		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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ 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 <- forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. STM a -> IO a
atomically (forall a. TMVar a -> STM a
readTMVar TMVar (Barrier, b)
bv)
		case DisplayChange
change of
			DisplayChangeBarrier Barrier
b' | Barrier
b' forall a. Ord a => a -> a -> Bool
>= Barrier
b -> 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 <- forall a. STM a -> IO a
atomically STM Int
consoleWidth
	Barrier
origbarrier <- forall a. STM a -> IO a
atomically (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 forall a. Eq a => a -> a -> Bool
== Int
origwidth then forall a. STM a
retry else forall (m :: * -> *) a. Monad m => a -> m a
return Int
w
		let waitbarrierchange :: STM Barrier
waitbarrierchange = do
			Barrier
b <- forall a. TVar a -> STM a
readTVar TVar Barrier
displayChangeBarrier
			if Barrier
b forall a. Eq a => a -> a -> Bool
/= Barrier
origbarrier
				then forall (m :: * -> *) a. Monad m => a -> m a
return Barrier
b
				else forall a. STM a
retry
		let waitanychange :: STM DisplayChange
waitanychange =
			(([ConsoleRegion], [R], [[Text]]) -> DisplayChange
RegionChange 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)
				forall a. STM a -> STM a -> STM a
`orElse`
			(([ConsoleRegion], [R], [[Text]]) -> DisplayChange
RegionListChange forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ConsoleRegion], [R], [[Text]])
-> STM ([ConsoleRegion], [R], [[Text]])
regionListWaiter ([ConsoleRegion], [R], [[Text]])
origsnapshot)
				forall a. STM a -> STM a -> STM a
`orElse`
			(BufferSnapshot -> DisplayChange
BufferChange forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OutputBuffer -> (OutputBuffer, OutputBuffer))
-> STM BufferSnapshot
outputBufferWaiterSTM OutputBuffer -> (OutputBuffer, OutputBuffer)
waitCompleteLines)
				forall a. STM a -> STM a -> STM a
`orElse`
			(Int -> DisplayChange
TerminalResize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Int
waitwidthchange)
				forall a. STM a -> STM a -> STM a
`orElse`
			(TSem -> STM ()
waitTSem TSem
endsignal forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure DisplayChange
Shutdown)
				forall a. STM a -> STM a -> STM a
`orElse`
			-- Must come last, so the changes above are
			-- processed before barriers.
			(Barrier -> DisplayChange
DisplayChangeBarrier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Barrier
waitbarrierchange)
		(DisplayChange
change, Int
height) <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ (,)
			forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM DisplayChange
waitanychange
			forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM Int
consoleHeight
		let onscreen :: [[a]] -> [a]
onscreen = forall a. Int -> [a] -> [a]
take (Int
height forall a. Num a => a -> a -> a
- Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
			forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm forall a b. (a -> b) -> a -> b
$
				[Text] -> [Text] -> IO ()
changedLines (forall {a}. [[a]] -> [a]
onscreen [[Text]]
origlines) (forall {a}. [[a]] -> [a]
onscreen [[Text]]
newlines)
			forall (m :: * -> *) a. Monad m => a -> m a
return 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' = forall {a}. [[a]] -> [a]
onscreen [[Text]]
origlines
				Bool -> Int -> [Text] -> IO () -> IO ()
inAreaAbove Bool
isterm (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
origlines') [Text]
origlines' forall a b. (a -> b) -> a -> b
$
					StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer StdHandle
h OutputBuffer
buf
				forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a. STM a -> IO a
atomically (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> ConsoleRegion -> STM [Text]
resizeRegion Int
newwidth) [ConsoleRegion]
orighandles)
				forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm forall a b. (a -> b) -> a -> b
$ do
					[Text] -> IO ()
resizeRecovery (forall {a}. [[a]] -> [a]
onscreen [[Text]]
newlines)
				forall (m :: * -> *) a. Monad m => a -> m a
return 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 ->
				forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
			DisplayChangeBarrier Barrier
b ->
				forall (m :: * -> *) a. Monad m => a -> m a
return 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
		forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan DisplayChange
displayUpdateNotifier DisplayChange
change
		IO ()
next

readRegions :: [ConsoleRegion] -> STM [R]
readRegions :: [ConsoleRegion] -> STM [R]
readRegions = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(ConsoleRegion TVar R
h) -> 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 <- forall a. TMVar a -> STM a
readTMVar TMVar [ConsoleRegion]
regionList
	if [ConsoleRegion]
handles forall a. Eq a => a -> a -> Bool
== [ConsoleRegion]
orighandles
		then forall a. STM a
retry
		else do
			[R]
rs <- [ConsoleRegion] -> STM [R]
readRegions [ConsoleRegion]
handles
			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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM R -> STM [Text]
getr [R]
rs
	forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Text]]
newlines forall a. Eq a => a -> a -> Bool
/= [[Text]]
origlines)
		forall a. STM a
retry
	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 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 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 = forall a. [a] -> [a]
reverse (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 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.
		forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a. Num a => a -> a
abs Int
delta) forall a b. (a -> b) -> a -> b
$ do
			Int -> IO ()
setCursorColumn Int
0
			Int -> IO ()
cursorUp Int
1
			IO ()
clearLine
		[Text] -> [Text] -> IO ()
diffUpdate (forall a. Int -> [a] -> [a]
drop (forall a. Num a => a -> a
abs Int
delta) [Text]
origlines) [Text]
newlines
  where
	delta :: Int
delta = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
newlines forall a. Num a => a -> a -> a
- 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 (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
new [Bool]
changed) [Text]
old)
  where
	changed :: [Bool]
changed = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(/=)) (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
new [Text]
old) forall a. [a] -> [a] -> [a]
++ 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 = 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 = 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)forall a. a -> [a] -> [a]
:[((r, Int), r)]
c)
	| Bool
otherwise = forall r.
[((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [((r, Bool), r)]
rs (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
	| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((Text, Int), Text)]
l' = forall (m :: * -> *). Monad m => m ()
noop
	| Bool
otherwise = do
		forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((Text, Int), Text)]
l' 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 forall a b. (a -> b) -> a -> b
$
				[LineUpdate] -> Text
genLineUpdate 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 (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [((Text, Int), Text)]
l'))
		Int -> IO ()
setCursorColumn Int
0
  where
	l' :: [((Text, Int), Text)]
l' = 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 forall a b. (a -> b) -> a -> b
$
		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
	forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm forall a b. (a -> b) -> a -> b
$ do
		forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
numlines forall a. Ord a => a -> a -> Bool
< Int
1) forall a b. (a -> b) -> a -> b
$ do
			Int -> IO ()
setCursorColumn Int
0
			Int -> IO ()
cursorUp 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
	forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm forall a b. (a -> b) -> a -> b
$ do
		Int -> IO ()
setCursorColumn Int
0 -- just in case the output lacked a newline
		[Text] -> IO ()
displayLines (forall a. [a] -> [a]
reverse [Text]
ls)

displayLines :: [Text] -> IO ()
displayLines :: [Text] -> IO ()
displayLines = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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
installResizeHandler :: Maybe (IO ()) -> IO ()
installResizeHandler Maybe (IO ())
h = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
	Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
windowChange (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Handler
Default IO () -> Handler
Catch Maybe (IO ())
h) forall a. Maybe a
Nothing
#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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RegionContent -> STM Text
readRegionContent (R -> RegionContent
regionContent R
r)
	forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse 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 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 forall a. Ord a => a -> a -> Bool
>= Int
len = if Int
i forall a. Ord a => a -> a -> Bool
> Int
0
		then forall a. [a] -> [a]
reverse (Text -> [Text]
finishline Text
t)
		else forall a. [a] -> [a]
reverse [Text]
collectedlines
	| Char
t1 forall a. Eq a => a -> a -> Bool
== Char
'\n' = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width (Text -> [Text]
finishline forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== Char
'\ESC' Bool -> Bool -> Bool
&& Int
iforall a. Num a => a -> a -> a
+Int
1 forall a. Ord a => a -> a -> Bool
< Int
len = case Text -> Int -> Char
T.index Text
t (Int
iforall 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
iforall 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
iforall a. Num a => a -> a -> a
+Int
1) Int
displaysize Int
len Text
t
	| Int
displaysize 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
iforall a. Num a => a -> a -> a
+Int
1) (Int
displaysizeforall a. Num a => a -> a -> a
+Int
1) Int
len Text
t
  where
	t1 :: Char
t1 = Text -> Int -> Char
T.index Text
t Int
i
	(Text
currline, Text
rest) = Int -> Text -> (Text, Text)
T.splitAt (Int
iforall 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
iforall 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
csiendforall a. Num a => a -> a -> a
+Int
2)) (Int
iforall a. Num a => a -> a -> a
+Int
2forall a. Num a => a -> a -> a
+Int
csiend) (Int
displaysizeforall a. Num a => a -> a -> a
-Int
1) Int
len Text
t
		Maybe Int
Nothing -> 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 forall a. Eq a => a -> a -> Bool
== Text
resetSGR = []
			| Bool -> Bool
not (Text -> Bool
T.null Text
ansicode) Bool -> Bool -> Bool
&& Text -> Char
T.last Text
ansicode forall a. Eq a => a -> a -> Bool
== Char
endSGR =
				Text
ansicode forall a. a -> [a] -> [a]
: [Text]
collectedSGR
			| Bool
otherwise = [Text]
collectedSGR
		  where
			ansicode :: Text
ansicode = Int -> Text -> Text
T.take (Int
csiend 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 forall a. a -> [a] -> [a]
: [Text]
collectedlines
	-- Close any open SGR codes at end of line
	closeSGR :: Text -> Text
closeSGR Text
l
		| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
collectedSGR = Text
l
		| Bool
otherwise = Text
l forall a. Semigroup a => a -> a -> a
<> Text
resetSGR
	-- Continue any open SGR codes from previous line
	contSGR :: Text -> Text
contSGR Text
l = forall a. Monoid a => [a] -> a
mconcat (forall a. [a] -> [a]
reverse [Text]
collectedSGR) 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 forall a. Ord a => a -> a -> Bool
>= Int
64 Bool -> Bool -> Bool
&& Int
o forall a. Ord a => a -> a -> Bool
< Int
127

endOSC :: Char -> Bool
endOSC :: Char -> Bool
endOSC Char
c = Char
c 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 = 
	forall a. [a] -> [a]
reverse 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 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 forall a. a -> [a] -> [a]
: Text -> LineUpdate
Display (Char -> Text
T.singleton Char
n) 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 forall a. Eq a => a -> a -> Bool
== Char
n Bool -> Bool -> Bool
&& [LineUpdate]
oinvis 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] 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) 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 = (forall a. Maybe a
Nothing, Text
T.empty, [LineUpdate]
past, [LineUpdate]
invis)
	| Bool
otherwise = case 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"forall a. a -> [a] -> [a]
:[LineUpdate]
past) (String -> LineUpdate
Skip String
"\ESC"forall a. a -> [a] -> [a]
:[LineUpdate]
invis)
			   | Bool
otherwise -> case 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 -> (forall a. a -> Maybe a
Just Char
c, Int -> Text -> Text
T.drop Int
2 Text
t, String -> LineUpdate
Skip String
"\ESC"forall a. a -> [a] -> [a]
:[LineUpdate]
past, String -> LineUpdate
Skip String
"\ESC"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]forall a. a -> [a] -> [a]
:[LineUpdate]
past) (String -> LineUpdate
Skip [Char
c]forall a. a -> [a] -> [a]
:[LineUpdate]
invis)
		  | Bool
otherwise -> (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
csiendforall 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
csiendforall a. Num a => a -> a -> a
+Int
3) Text
t)
				(LineUpdate
sgrforall a. a -> [a] -> [a]
:[LineUpdate]
past) (LineUpdate -> [LineUpdate] -> [LineUpdate]
addsgr LineUpdate
sgr [LineUpdate]
invis)
		Maybe Int
Nothing -> (forall a. Maybe a
Nothing, Text
T.empty, [LineUpdate]
past, [LineUpdate]
invis)
	addsgr :: LineUpdate -> [LineUpdate] -> [LineUpdate]
addsgr (SGR Text
sgrt) [LineUpdate]
l
		| Text
sgrt forall a. Eq a => a -> a -> Bool
== Text
resetSGR = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineUpdate -> Bool
isSGR) [LineUpdate]
l
	addsgr LineUpdate
s [LineUpdate]
l = LineUpdate
sforall a. a -> [a] -> [a]
:[LineUpdate]
l

data LineUpdate = Display Text | Skip [Char] | SGR Text | ClearToEnd
	deriving (LineUpdate -> LineUpdate -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineUpdate -> LineUpdate -> Bool
$c/= :: LineUpdate -> LineUpdate -> Bool
== :: LineUpdate -> LineUpdate -> Bool
$c== :: LineUpdate -> LineUpdate -> Bool
Eq, Int -> LineUpdate -> ShowS
[LineUpdate] -> ShowS
LineUpdate -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LineUpdate] -> ShowS
$cshowList :: [LineUpdate] -> ShowS
show :: LineUpdate -> String
$cshow :: LineUpdate -> String
showsPrec :: Int -> LineUpdate -> ShowS
$cshowsPrec :: Int -> 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 forall a b. (a -> b) -> a -> b
$ 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 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 = 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 forall a. Eq a => a -> a -> Bool
/= Text
resetSGR = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go [LineUpdate]
rest []
	go [LineUpdate]
c [] = 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)forall a. a -> [a] -> [a]
:String -> LineUpdate
Skip String
sforall 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
sforall a. [a] -> [a] -> [a]
++String
s')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)forall a. a -> [a] -> [a]
:[LineUpdate]
rest)
	go [LineUpdate]
c (LineUpdate
v:[LineUpdate]
rest) = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go (LineUpdate
vforall a. a -> [a] -> [a]
:[LineUpdate]
c) [LineUpdate]
rest
	tryharder :: [LineUpdate] -> [LineUpdate] -> [LineUpdate]
tryharder [LineUpdate]
c [LineUpdate]
l = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go [] (forall a. [a] -> [a]
reverse [LineUpdate]
c 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 forall a. Semigroup a => a -> a -> a
<> Text
b
	Just [Int]
cs -> String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"\ESC[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
";" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Int]
cs) forall a. [a] -> [a] -> [a]
++ String
"m"
  where
	codes :: Text -> [Maybe Int]
codes = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
		(Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
';') forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
	forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(ConsoleLayer, Int)
a (ConsoleLayer, Int)
b -> forall a b. (a, b) -> a
fst (ConsoleLayer, Int)
a forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (ConsoleLayer, Int)
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. (Ord a, Num a) => Maybe a -> Maybe (ConsoleLayer, a)
range (forall a. [a] -> [a]
reverse [Maybe Int]
bs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [Maybe Int]
as)
  where
	range :: Maybe a -> Maybe (ConsoleLayer, a)
range Maybe a
Nothing = forall a. Maybe a
Nothing
	range (Just a
x)
		| a
x forall a. Ord a => a -> a -> Bool
>= a
30 Bool -> Bool -> Bool
&& a
x forall a. Ord a => a -> a -> Bool
<= a
37 = forall a. a -> Maybe a
Just (ConsoleLayer
Foreground, a
x)
		| a
x forall a. Ord a => a -> a -> Bool
>= a
40 Bool -> Bool -> Bool
&& a
x forall a. Ord a => a -> a -> Bool
<= a
47 = forall a. a -> Maybe a
Just (ConsoleLayer
Background, a
x)
		| a
x forall a. Ord a => a -> a -> Bool
>= a
90 Bool -> Bool -> Bool
&& a
x forall a. Ord a => a -> a -> Bool
<= a
97 = forall a. a -> Maybe a
Just (ConsoleLayer
Foreground, a
x)
		| a
x forall a. Ord a => a -> a -> Bool
>= a
100 Bool -> Bool -> Bool
&& a
x forall a. Ord a => a -> a -> Bool
<= a
107 = forall a. a -> Maybe a
Just (ConsoleLayer
Background, a
x)
		| Bool
otherwise = forall a. Maybe a
Nothing

#endif