{-# LANGUAGE BangPatterns, TupleSections, TypeSynonymInstances, FlexibleInstances #-}

-- | 
-- 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 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 (
	-- * Initialization
	displayConsoleRegions,
	ConsoleRegionHandle,
	RegionLayout(..),
	withConsoleRegion,
	openConsoleRegion,
	closeConsoleRegion,
	-- * Region display
	Displayable(..),
	setConsoleRegion,
	appendConsoleRegion,
	finishConsoleRegion,
	-- * STM interface
	--
	-- | These actions can be composed into a STM transaction; 
	-- once the transaction completes the console will be updated
	-- a single time to reflect all the changes made.
	openConsoleRegionSTM,
	newConsoleRegionSTM,
	closeConsoleRegionSTM,
	setConsoleRegionSTM,
	appendConsoleRegionSTM,
	-- * STM regions
	--
	-- | The `Displayable` 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 System.Console.Terminal.Size
	-- > import qualified Data.Text as T
	--
	-- > r <- openConsoleRegion Linear s
	-- > setConsoleRegion r $ do
	-- > 	sz <- readTVar consoleSize
	-- > 	return $ T.pack $ unwords
	-- > 		[ "size:"
	-- >		, show (width sz)
	-- > 		, "x"
	-- >		, show (height sz)
	-- > 		]
	-- >
	RegionContent(..),
	readRegionContent,
	consoleSize,
	Width,
	consoleWidth,
	regionList,
) where

import Data.Monoid
import Data.Maybe
import Data.String
import Data.Char
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Control.Monad
import Control.Applicative
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 System.Posix.Signals
import System.Posix.Signals.Exts
import Text.Read
import Data.List

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.
--
-- > 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 ConsoleRegionHandle
	deriving (Eq)

newtype ConsoleRegionHandle = ConsoleRegionHandle (TVar Region)
	deriving (Eq)

data Region = Region
	{ regionContent :: RegionContent
	, regionLines :: TVar [T.Text] -- ^ cache of regionContent
	, regionLayout :: RegionLayout
	, regionChildren :: Maybe [ConsoleRegionHandle]
	}

data RegionContent
	= RegionContent (TVar T.Text) 
	| RegionContentSTM (STM T.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 [ConsoleRegionHandle]
regionList = unsafePerformIO newEmptyTMVarIO

-- | On unix systems, this TVar is automatically updated when the
-- terminal is resized.
{-# NOINLINE consoleSize #-}
consoleSize :: TVar (Console.Window Int)
consoleSize = unsafePerformIO $ newTVarIO $ 
	Console.Window { Console.width = 80, Console.height = 25}

type Width = Int

-- Get the width from the `consoleSize`
consoleWidth :: STM Width
consoleWidth = Console.width <$> readTVar consoleSize

-- | The RegionList TMVar is left empty when `displayConsoleRegions`
-- is not running.
regionDisplayEnabled :: IO Bool
regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList

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

instance Displayable String where
	toRegionContent = fromOutput

instance Displayable T.Text where
	toRegionContent = fromOutput

fromOutput :: Outputable v => v -> STM RegionContent
fromOutput v = RegionContent <$> newTVar (toOutput v)

-- | 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 Displayable (STM T.Text) where
	toRegionContent = pure . RegionContentSTM

-- | Sets the value to display within a console region.
--
-- 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 etc of all or part of a region.
-- 
-- Other ANSI escape sequences, especially those doing cursor
-- movement, will mess up the layouts of regions. Caveat emptor.
setConsoleRegion :: Displayable v => ConsoleRegionHandle -> v -> IO ()
setConsoleRegion h = atomically . setConsoleRegionSTM h

-- | STM version of `setConsoleRegion`
setConsoleRegionSTM :: Displayable v => ConsoleRegionHandle -> v -> STM ()
setConsoleRegionSTM (ConsoleRegionHandle tv) v = do
	r <- readTVar tv
	width <- consoleWidth
	r' <- modifyRegion r width $ const $ toRegionContent v
	writeTVar tv r'
	case regionLayout r of
		Linear -> return ()
		InLine p -> refreshParent p

-- | Appends the value to whatever was already on display within a console
-- region.
appendConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO ()
appendConsoleRegion h = atomically . appendConsoleRegionSTM h

-- | STM version of `appendConsoleRegion`
appendConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM ()
appendConsoleRegionSTM (ConsoleRegionHandle tv) v = do
	r <- readTVar tv
	width <- consoleWidth
	r' <- modifyRegion r width $ \rc -> case rc of
		RegionContent cv -> do
			modifyTVar' cv (<> toOutput v)
			return rc
		RegionContentSTM a -> return $ RegionContentSTM $ do
			t <- a
			return (t <> toOutput v)
	writeTVar tv r'
	case regionLayout r of
		Linear -> return ()
		InLine p -> refreshParent p

modifyRegion :: Region -> Width -> (RegionContent -> STM RegionContent) -> STM Region
modifyRegion r width f = do
	rc <- f (regionContent r)
	t <- readRegionContent' rc
	writeTVar (regionLines r) (calcRegionLines t width)
	return $ r { regionContent = rc }

-- | Reads the content of a region.
readRegionContent :: ConsoleRegionHandle -> STM T.Text
readRegionContent (ConsoleRegionHandle tv) =
	readRegionContent' . regionContent =<< readTVar tv

readRegionContent' :: RegionContent -> STM T.Text
readRegionContent' (RegionContent t) = readTVar t
readRegionContent' (RegionContentSTM a) = a

resizeRegion :: Width -> ConsoleRegionHandle -> STM (Region, [T.Text])
resizeRegion width (ConsoleRegionHandle tv) = do
	r <- readTVar tv
	t <- readRegionContent' (regionContent r)
	let ls = calcRegionLines t width
	writeTVar (regionLines r) ls
	return (r, 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 -> (ConsoleRegionHandle -> m a) -> m a
withConsoleRegion l = bracketIO (openConsoleRegion l) closeConsoleRegion

-- | Opens a new console region for output.
openConsoleRegion :: RegionLayout -> IO ConsoleRegionHandle
openConsoleRegion ly = atomically $ openConsoleRegionSTM ly T.empty

-- | STM version of `openConsoleRegion`. Allows atomically opening multiple
-- regions at the same time, which guarantees they are adjacent.
--
-- > [r1, r2, r3] <- atomically $
-- >	replicateM 3 (openConsoleRegionSTM Linear T.empty)
openConsoleRegionSTM :: Displayable v => RegionLayout -> v -> STM ConsoleRegionHandle
openConsoleRegionSTM ly v = do
	h <- newConsoleRegionSTM ly T.empty
	case ly of
		Linear -> do
			v <- tryTakeTMVar regionList
			case v of
				Just l -> do putTMVar regionList (h:l)
				-- displayConsoleRegions is not active, so
				-- it's not put on any list, and won't display
				Nothing -> return ()
		InLine parent -> addChild h parent
	setConsoleRegionSTM h v
	return h

-- | Makes a new region, but does not add it to the display.
newConsoleRegionSTM :: Displayable v => RegionLayout -> v -> STM ConsoleRegionHandle
newConsoleRegionSTM ly v = do
	width <- consoleWidth
	rc <- newTVar mempty
	ls <- newTVar $ calcRegionLines mempty width
	let r = Region
		{ regionContent = RegionContent rc
		, regionLines = ls
		, regionLayout = ly
		, regionChildren = Nothing
		}
	h <- ConsoleRegionHandle <$> newTVar r
	setConsoleRegionSTM h v
	return h

-- | Closes a console region. Once closed, the region is removed from the
-- display.
closeConsoleRegion :: ConsoleRegionHandle -> IO ()
closeConsoleRegion = atomically . closeConsoleRegionSTM

closeConsoleRegionSTM :: ConsoleRegionHandle -> STM ()
closeConsoleRegionSTM h@(ConsoleRegionHandle tv) = do
	v <- tryTakeTMVar regionList
	case v of
		Just l ->
			let !l' = filter (/= h) l
			in putTMVar regionList l'
		_ -> return ()
	ly <- regionLayout <$> readTVar tv
	case ly of
		Linear -> return ()
		InLine parent -> removeChild h parent

-- | Closes the console region and displays the passed value in the
-- scrolling area above the active console regions.
finishConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO ()
finishConsoleRegion h = atomically . finishConsoleRegionSTM h

finishConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM ()
finishConsoleRegionSTM h v = do
	closeConsoleRegionSTM h
	bufferOutputSTM StdOut (toOutput v <> fromString "\n")

removeChild :: ConsoleRegionHandle -> ConsoleRegionHandle -> STM ()
removeChild child parent@(ConsoleRegionHandle pv) = do
	modifyTVar' pv $ \p -> case regionChildren p of
		Nothing -> p
		Just l -> p { regionChildren = Just $ filter (/= child) l }
	refreshParent parent

addChild :: ConsoleRegionHandle -> ConsoleRegionHandle -> STM ()
addChild child parent@(ConsoleRegionHandle pv) = do
	modifyTVar' pv $ \p -> p
		{ regionChildren = Just $ child : filter (/= child) (fromMaybe [] (regionChildren p)) }
	refreshParent parent

refreshParent :: ConsoleRegionHandle -> STM ()
refreshParent (ConsoleRegionHandle pv) = do
	p <- readTVar pv
	width <- consoleWidth
	case regionChildren p of
		Nothing -> return ()
		Just l -> do
			cs <- forM l $ \child -> do
				refreshParent child
				readRegionContent child
			let !c = mconcat cs
			rc <- newTVar c
			let p' = p { regionContent = RegionContent rc }
			writeTVar pv p'
			writeTVar (regionLines p) (calcRegionLines c width)

-- | 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`.
--
-- When standard output is not an ANSI capable terminal,
-- console regions are not displayed.
displayConsoleRegions :: (MonadIO m, MonadMask m) => m a -> m a
displayConsoleRegions a = ifM (liftIO regionDisplayEnabled)
	( a -- displayConsoleRegions is already running
	, lockOutput $ bracket setup cleanup (const a)
	)
  where
	setup = liftIO $ do
		atomically $ putTMVar regionList []
		endsignal <- atomically $ do
			s <- newTSem 1
			waitTSem s
			return s
		isterm <- liftIO $ hSupportsANSI stdout
		when isterm trackConsoleWidth
		da <- async $ displayThread isterm endsignal
		return (isterm, da, endsignal)
	cleanup (isterm, da, endsignal) = liftIO $ do
		atomically $ signalTSem endsignal
		void $ wait da
		void $ atomically $ takeTMVar regionList
		when isterm $
			installResizeHandler Nothing

trackConsoleWidth :: IO ()
trackConsoleWidth = do
	let getwidth = maybe noop (atomically . writeTVar consoleSize)
		=<< Console.size
	getwidth
	installResizeHandler (Just getwidth)

data DisplayChange
	= BufferChange [(StdHandle, OutputBuffer)]
	| RegionChange RegionSnapshot
	| TerminalResize Width
	| EndSignal ()

type RegionSnapshot = ([ConsoleRegionHandle], [Region], [[T.Text]])

displayThread :: Bool -> TSem -> IO ()
displayThread isterm endsignal = do
	origwidth <- atomically consoleWidth
	go ([], [], []) origwidth
  where
	go origsnapshot@(orighandles, _origregions, origlines) origwidth = do
		let waitwidthchange = do
			w <- consoleWidth
			if w == origwidth then retry else return w
		change <- atomically $
			(RegionChange <$> regionWaiter origsnapshot origwidth)
				`orElse`
			(RegionChange <$> regionListWaiter origsnapshot)
				`orElse`
			(BufferChange <$> outputBufferWaiterSTM waitCompleteLines)
				`orElse`
			(TerminalResize <$> waitwidthchange)
				`orElse`
			(EndSignal <$> waitTSem endsignal)
		case change of
			RegionChange snapshot@(_, _, newlines) -> do
				when isterm $ do
					changedLines (concat origlines) (concat newlines)
				go snapshot origwidth
			BufferChange buffers -> do
				inAreaAbove isterm (length $ concat origlines) (concat origlines) $
					mapM_ (uncurry emitOutputBuffer) buffers
				go origsnapshot origwidth
			TerminalResize newwidth -> do
				(newregions, lls) <- unzip <$> 
					atomically (mapM (resizeRegion newwidth) orighandles)
				let newlines = map reverse lls
				when isterm $ do
					-- A resize can leave the cursor
					-- in a fairly undefined location,
					-- if it occurred while a screen
					-- draw was in progress. Move the
					-- cursor to top of screen, clear
					-- entire screen, and redisplay.
					setCursorPosition 0 0
					inAreaAbove isterm 0 (concat newlines) $
						return ()
				go (orighandles, newregions, newlines) newwidth
			EndSignal () -> return ()

readRegions :: [ConsoleRegionHandle] -> STM [Region]
readRegions = mapM (\(ConsoleRegionHandle h) -> readTVar h)

-- Wait for any changes to the region list, eg adding or removing a handle.
regionListWaiter :: RegionSnapshot -> STM RegionSnapshot
regionListWaiter (orighandles, _origregions, origlines) = do
	handles <- readTMVar regionList
	if handles == orighandles
		then retry
		else do
			rs <- readRegions handles
			return (handles, rs, origlines)

-- Wait for any changes to any of the regions currently in the region list.
regionWaiter :: RegionSnapshot -> Width -> STM RegionSnapshot
regionWaiter (orighandles, _origregions, origlines) width = do
	rs <- readRegions orighandles
	newlines <- mapM getr (zip rs (origlines ++ repeat [T.empty]))
	unless (newlines /= origlines)
		retry
	return (orighandles, rs, newlines)
  where
	getr (r, ols) = case regionContent r of
		RegionContent _ -> reverse <$> readTVar (regionLines r)
		RegionContentSTM a -> do
			c <- a
			let ls = reverse $ calcRegionLines c width
			when (ls /= ols) $
				writeTVar (regionLines r) ls
			return ls

-- This is not an optimal screen update like curses can do, but it's
-- pretty efficient, most of the time!
changedLines :: [T.Text] -> [T.Text] -> IO ()
changedLines origlines newlines
	| delta == 0 = do
		-- The total number of lines is unchanged, so update
		-- whichever ones have changed, and leave the rest as-is.
		diffUpdate origlines newlines
	| delta > 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 = reverse (take delta newlines)
		displayLines addedlines
		-- Some existing lines may have also changed..
		let scrolledlines = addedlines ++ origlines
		diffUpdate scrolledlines newlines
	| otherwise = do
		-- Some lines were removed. Move up that many lines,
		-- clearing each line, and update any changed lines.
		replicateM_ (abs delta) $ do
			cursorUpLine 1
			clearLine
		diffUpdate (drop (abs delta) origlines) newlines
  where
	delta = length newlines - length origlines

diffUpdate :: [T.Text] -> [T.Text] -> IO ()
diffUpdate old new = updateLines (zip (zip new changed) old)
  where
	changed = map (uncurry (/=)) (zip new old) ++ repeat True

changeOffsets :: [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [] _ c = reverse c
changeOffsets (((new, changed), old):rs) n c
	| changed = changeOffsets rs 1 (((new, n), old):c)
	| otherwise = changeOffsets rs (succ n) 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 :: [((T.Text, Bool), T.Text)] -> IO ()
updateLines l
	| null l' = noop
	| otherwise = do
		forM_ l' $ \((newt, offset), oldt) -> do
			cursorUpLine offset
			T.hPutStr stdout $ 
				genLineUpdate $ calcLineUpdate oldt newt
		cursorDownLine (sum (map (snd . fst) l'))
		setCursorColumn 0
		hFlush stdout
  where
	l' = changeOffsets l 1 []

-- 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 -> [T.Text] -> IO () -> IO ()
inAreaAbove isterm numlines ls outputter = do
	when isterm $ do
		unless (numlines < 1) $
			cursorUpLine $ numlines
		clearFromCursorToScreenEnd
	outputter
	when isterm $ do
		setCursorColumn 0 -- just in case the output lacked a newline
		displayLines (reverse ls)
	hFlush stdout

displayLines :: [T.Text] -> IO ()
displayLines = mapM_ $ \l -> do
	T.hPutStr stdout l
	putChar '\n'

installResizeHandler :: Maybe (IO ()) -> IO ()
installResizeHandler h = void $
	installHandler windowChange (maybe Default Catch h) Nothing

-- | 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"]
calcRegionLines :: T.Text -> Width -> [T.Text]
calcRegionLines t width
	| width < 1 || T.null t = [t] -- even an empty text is 1 line high
	| otherwise = calcRegionLines' width [] [] 0 1 (T.length t) t

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

	skipansi toend isCSI = case T.findIndex toend (T.drop (i+2) t) of
		Just csiend -> calcRegionLines' width collectedlines 
			(addSGR (csiend+2)) (i+2+csiend) (displaysize-1) len t
		Nothing -> reverse (finishline t)
	  where
		addSGR csiend
			| not isCSI = collectedSGR
			| ansicode == resetSGR = []
			| not (T.null ansicode) && T.last ansicode == endSGR =
				ansicode : collectedSGR
			| otherwise = collectedSGR
		  where
			ansicode = T.take (csiend + 1) (T.drop i t)
	finishline l = closeSGR l : collectedlines
	-- Close any open SGR codes at end of line
	closeSGR l
		| null collectedSGR = l
		| otherwise = l <> resetSGR
	-- Continue any open SGR codes from previous line
	contSGR l = mconcat (reverse collectedSGR) <> l

resetSGR :: T.Text
resetSGR = T.pack (setSGRCode [Reset])

endCSI :: Char -> Bool
endCSI c = let o = ord c in o >= 64 && o < 127

endOSC :: Char -> Bool
endOSC c = c == '\BEL'

endSGR :: Char
endSGR = 'm'

-- | 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 :: T.Text -> T.Text -> [LineUpdate]
calcLineUpdate old new = 
	reverse $ go
		(advanceLine old [] [])
		(advanceLine new [] [])
  where
	go (Just _, _, _, _) (Nothing, _, past, _) = ClearToEnd : past
	go (Nothing, _, _, _) (Nothing, _, past, _) = past
	go (Nothing, _, _, _) (Just n, ns, past, _) =
		Display ns : Display (T.singleton n) : past
	go (Just o, os, _, oinvis) (Just n, ns, past, ninvis)
		| o == n && oinvis == ninvis = go
			(advanceLine os [] oinvis)
			(advanceLine ns (Skip [o] : past) ninvis)
		| otherwise = go
			(advanceLine os [] oinvis)
			(advanceLine ns (Display (T.singleton n) : past) 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 :: T.Text -> Past -> Invis -> (Maybe Char, T.Text, Past, Invis)
advanceLine t past invis
	| T.null t = (Nothing, T.empty, past, invis)
	| otherwise = case T.head t of
		'\ESC' -> case T.drop 1 t of
			t' | T.null t' -> advanceLine (T.drop 1 t)
				(Skip "\ESC":past) (Skip "\ESC":invis)
			   | otherwise -> case T.head t' of
			   	'[' -> skipansi endCSI
				']' -> skipansi endOSC
				c -> (Just c, T.drop 2 t, Skip "\ESC":past, Skip "\ESC":invis)
		c | isControl c -> advanceLine (T.drop 1 t) (Skip [c]:past) (Skip [c]:invis)
		  | otherwise -> (Just c, T.drop 1 t, past, invis)
  where
	skipansi toend = case T.findIndex toend (T.drop 2 t) of
		Just csiend -> 
			let sgr = SGR (T.take (csiend+3) t)
			in advanceLine (T.drop (csiend+3) t)
				(sgr:past) (addsgr sgr invis)
		Nothing -> (Nothing, T.empty, past, invis)
	addsgr (SGR sgrt) l
		| sgrt == resetSGR = filter (not . isSGR) l
	addsgr s l = s:l

data LineUpdate = Display T.Text | Skip [Char] | SGR T.Text | ClearToEnd
	deriving (Eq, Show)

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

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

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

-- Parse and combine 2 ANSI SGR sequences into one.
combineSGR :: T.Text -> T.Text -> T.Text
combineSGR a b = case combineSGRCodes (codes a) (codes b) of
	Nothing -> a <> b
	Just cs -> T.pack $ "\ESC[" ++ intercalate ";" (map show cs) ++ "m"
  where
	codes = map (readMaybe . T.unpack) .
		T.split (== ';') . T.drop 2 . 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 as bs =
	map snd . nubBy (\a b -> fst a == fst b) <$> mapM range (reverse bs ++ reverse as)
  where
	range Nothing = Nothing
	range (Just x)
		| x >= 30 && x <= 37 = Just (Foreground, x)
		| x >= 40 && x <= 47 = Just (Background, x)
		| x >= 90 && x <= 97 = Just (Foreground, x)
		| x >= 100 && x <= 107 = Just (Background, x)
		| otherwise = Nothing