module System.Console.Regions (
displayConsoleRegions,
ConsoleRegionHandle,
RegionLayout(..),
withConsoleRegion,
openConsoleRegion,
closeConsoleRegion,
Displayable(..),
setConsoleRegion,
appendConsoleRegion,
finishConsoleRegion,
openConsoleRegionSTM,
newConsoleRegionSTM,
closeConsoleRegionSTM,
setConsoleRegionSTM,
appendConsoleRegionSTM,
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
data RegionLayout = Linear | InLine ConsoleRegionHandle
deriving (Eq)
newtype ConsoleRegionHandle = ConsoleRegionHandle (TVar Region)
deriving (Eq)
data Region = Region
{ regionContent :: RegionContent
, regionLines :: TVar [T.Text]
, regionLayout :: RegionLayout
, regionChildren :: Maybe [ConsoleRegionHandle]
}
data RegionContent
= RegionContent (TVar T.Text)
| RegionContentSTM (STM T.Text)
regionList :: TMVar [ConsoleRegionHandle]
regionList = unsafePerformIO newEmptyTMVarIO
consoleSize :: TVar (Console.Window Int)
consoleSize = unsafePerformIO $ newTVarIO $
Console.Window { Console.width = 80, Console.height = 25}
type Width = Int
consoleWidth :: STM Width
consoleWidth = Console.width <$> readTVar consoleSize
regionDisplayEnabled :: IO Bool
regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList
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)
instance Displayable (STM T.Text) where
toRegionContent = pure . RegionContentSTM
setConsoleRegion :: Displayable v => ConsoleRegionHandle -> v -> IO ()
setConsoleRegion h = atomically . setConsoleRegionSTM h
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
appendConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO ()
appendConsoleRegion h = atomically . appendConsoleRegionSTM h
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 }
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)
withConsoleRegion :: (MonadIO m, MonadMask m) => RegionLayout -> (ConsoleRegionHandle -> m a) -> m a
withConsoleRegion l = bracketIO (openConsoleRegion l) closeConsoleRegion
openConsoleRegion :: RegionLayout -> IO ConsoleRegionHandle
openConsoleRegion ly = atomically $ openConsoleRegionSTM ly 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)
Nothing -> return ()
InLine parent -> addChild h parent
setConsoleRegionSTM h v
return h
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
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
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)
displayConsoleRegions :: (MonadIO m, MonadMask m) => m a -> m a
displayConsoleRegions a = ifM (liftIO regionDisplayEnabled)
( a
, 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
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)
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)
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
changedLines :: [T.Text] -> [T.Text] -> IO ()
changedLines origlines newlines
| delta == 0 = do
diffUpdate origlines newlines
| delta > 0 = do
let addedlines = reverse (take delta newlines)
displayLines addedlines
let scrolledlines = addedlines ++ origlines
diffUpdate scrolledlines newlines
| otherwise = do
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
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 []
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
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
calcRegionLines :: T.Text -> Width -> [T.Text]
calcRegionLines t width
| width < 1 || T.null t = [t]
| 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)
| 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
| 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) (displaysize1) 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
closeSGR l
| null collectedSGR = l
| otherwise = l <> resetSGR
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'
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]
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)
| 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
go (Skip _:rest) [] = go rest []
go (SGR t:rest) [] | t /= resetSGR = go rest []
go c [] = reverse c
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)
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
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