module System.Console.Regions (
displayConsoleRegions,
ConsoleRegionHandle,
RegionLayout(..),
withConsoleRegion,
openConsoleRegion,
closeConsoleRegion,
setConsoleRegion,
appendConsoleRegion,
finishConsoleRegion,
openConsoleRegionSTM,
closeConsoleRegionSTM,
setConsoleRegionSTM,
appendConsoleRegionSTM,
updateRegionListSTM,
) where
import Data.Monoid
import Data.Maybe
import Data.String
import Data.Char
import qualified Data.ByteString as B
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 System.Console.Concurrent
import Utility.Monad
import Utility.Exception
data RegionLayout = Linear | InLine ConsoleRegionHandle
deriving (Eq)
newtype ConsoleRegionHandle = ConsoleRegionHandle (TVar Region)
deriving (Eq)
type Width = Int
type Height = Int
data Region = Region
{ regionContent :: B.ByteString
, regionHeight :: (Width -> Height)
, regionLayout :: RegionLayout
, regionChildren :: Maybe [ConsoleRegionHandle]
}
instance Eq Region where
a == b = regionContent a == regionContent b
&& regionLayout a == regionLayout b
type RegionList = TMVar [ConsoleRegionHandle]
regionList :: RegionList
regionList = unsafePerformIO newEmptyTMVarIO
updateRegionListSTM :: ([ConsoleRegionHandle] -> [ConsoleRegionHandle]) -> STM ()
updateRegionListSTM f =
maybe noop (putTMVar regionList . f) =<< tryTakeTMVar regionList
regionDisplayEnabled :: IO Bool
regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList
setConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO ()
setConsoleRegion h = atomically . setConsoleRegionSTM h
setConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM ()
setConsoleRegionSTM (ConsoleRegionHandle tv) v = do
r <- readTVar tv
writeTVar tv (modifyRegion r (const (toOutput v)))
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
writeTVar tv (modifyRegion r (<> toOutput v))
case regionLayout r of
Linear -> return ()
InLine p -> refreshParent p
modifyRegion :: Region -> (B.ByteString -> B.ByteString) -> Region
modifyRegion r f = r { regionContent = c, regionHeight = calcRegionHeight c }
where
!c = f (regionContent r)
withConsoleRegion :: (MonadIO m, MonadMask m) => RegionLayout -> (ConsoleRegionHandle -> m a) -> m a
withConsoleRegion l = bracketIO (openConsoleRegion l) closeConsoleRegion
openConsoleRegion :: RegionLayout -> IO ConsoleRegionHandle
openConsoleRegion = atomically . openConsoleRegionSTM
openConsoleRegionSTM :: RegionLayout -> STM ConsoleRegionHandle
openConsoleRegionSTM ly = do
let r = Region
{ regionContent = mempty
, regionHeight = calcRegionHeight mempty
, regionLayout = ly
, regionChildren = Nothing
}
h <- ConsoleRegionHandle <$> newTVar r
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
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 parent@(ConsoleRegionHandle pv) = do
p <- readTVar pv
case regionChildren p of
Nothing -> return ()
Just l -> do
cs <- forM l $ \child@(ConsoleRegionHandle cv) -> do
refreshParent child
regionContent <$> readTVar cv
let p' = p { regionContent = mconcat cs }
writeTVar pv p'
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
cwidth <- atomically newEmptyTMVar
when isterm $
trackConsoleWidth cwidth
da <- async $ displayThread isterm cwidth 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 :: TMVar Width -> IO ()
trackConsoleWidth cwidth = do
let getwidth = do
v <- Console.size
case v of
Nothing -> return ()
Just (Console.Window _height width) ->
atomically $ void $ do
void $ tryTakeTMVar cwidth
putTMVar cwidth width
getwidth
installResizeHandler $ Just getwidth
data DisplayChange
= BufferChange [(StdHandle, OutputBuffer)]
| RegionChange RegionSnapshot
| TerminalResize (Maybe Width)
| EndSignal ()
type RegionSnapshot = ([ConsoleRegionHandle], [Region], Maybe Width)
displayThread :: Bool -> TMVar Width -> TSem -> IO ()
displayThread isterm cwidth endsignal = do
origwidth <- atomically $ tryReadTMVar cwidth
go ([], [], origwidth)
where
go origsnapshot@(orighandles, origregions, origwidth) = do
let waitwidthchange = do
v <- tryReadTMVar cwidth
if v == origwidth then retry else return v
change <- atomically $
(RegionChange <$> regionWaiter origsnapshot)
`orElse`
(RegionChange <$> regionListWaiter origsnapshot)
`orElse`
(BufferChange <$> outputBufferWaiterSTM waitCompleteLines)
`orElse`
(TerminalResize <$> waitwidthchange)
`orElse`
(EndSignal <$> waitTSem endsignal)
case change of
RegionChange snapshot@(_, regions, _) -> do
when isterm $
changedRegions origregions regions
go snapshot
BufferChange buffers -> do
inAreaAbove isterm origregions $
mapM_ (uncurry emitOutputBuffer) buffers
go origsnapshot
TerminalResize width -> do
when isterm $
inAreaAbove isterm origregions $
return ()
go (orighandles, origregions, width)
EndSignal () -> return ()
readRegions :: [ConsoleRegionHandle] -> STM [Region]
readRegions = mapM (\(ConsoleRegionHandle h) -> readTVar h)
regionListWaiter :: RegionSnapshot -> STM RegionSnapshot
regionListWaiter (orighandles, _origregions, origwidth) = do
handles <- readTMVar regionList
if handles == orighandles
then retry
else (handles,,origwidth) <$> readRegions handles
regionWaiter :: RegionSnapshot -> STM RegionSnapshot
regionWaiter (orighandles, origregions, origwidth) = do
rs <- readRegions orighandles
if rs == origregions
then retry
else return (orighandles, rs, origwidth)
changedRegions :: [Region] -> [Region] -> IO ()
changedRegions origregions regions
| delta == 0 = do
diffUpdate origregions regions
| delta > 0 = do
let newregions = reverse (take delta regions)
displayRegions newregions
hFlush stdout
let scrolledregions = newregions ++ origregions
diffUpdate scrolledregions regions
| otherwise = do
replicateM_ (abs delta) $ do
cursorUpLine 1
clearLine
diffUpdate (drop (abs delta) origregions) regions
where
delta = length regions length origregions
diffUpdate :: [Region] -> [Region] -> IO ()
diffUpdate origregions regions = updateRegions (zip regions changed)
where
changed = map (uncurry (/=)) (zip regions origregions) ++ repeat True
updateRegions :: [(Region, Bool)] -> IO ()
updateRegions l
| null l' = noop
| otherwise = do
forM_ l' $ \(r, offset) -> do
cursorUpLine offset
clearLine
B.hPut stdout (regionContent r)
hFlush stdout
cursorDownLine (sum (map snd l'))
setCursorColumn 0
hFlush stdout
where
l' = changeOffsets l 1 []
changeOffsets :: [(r, Bool)] -> Int -> [(r, Int)] -> [(r, Int)]
changeOffsets [] _ c = reverse c
changeOffsets ((r, changed):rs) n c
| changed = changeOffsets rs 1 ((r, n):c)
| otherwise = changeOffsets rs (succ n) c
inAreaAbove :: Bool -> [Region] -> IO () -> IO ()
inAreaAbove isterm regions outputter = do
when isterm $ do
unless (null regions) $
cursorUpLine (length regions)
clearFromCursorToScreenEnd
outputter
when isterm $ do
setCursorColumn 0
displayRegions (reverse regions)
hFlush stdout
displayRegions :: [Region] -> IO ()
displayRegions = mapM_ $ \r -> do
B.hPut stdout (regionContent r)
putChar '\n'
installResizeHandler :: Maybe (IO ()) -> IO ()
installResizeHandler h = void $
installHandler windowChange (maybe Default Catch h) Nothing
calcRegionHeight :: B.ByteString -> Width -> Height
calcRegionHeight b width = sum $ map (calcLineHeight width) (B.split wnl b)
where
wnl = fromIntegral (ord '\n')
calcLineHeight :: Width -> B.ByteString -> Height
calcLineHeight width b
| width < 1 || B.null b = 1
| otherwise =
let (q,r) = (B.length b countInvisibleBytes b) `quotRem` width
in q + if r > 0 then 1 else 0
countInvisibleBytes :: B.ByteString -> Int
countInvisibleBytes = go 0 . breakesc
where
go c (beforeesc, b)
| B.length b <= 1 = B.length b + c'
| headis csi (B.drop 1 b) = countseq breakcsi
| headis osc (B.drop 1 b) = countseq breakosc
| otherwise = go (c'+1) (breakesc (B.drop 1 b))
where
c' = c + countControlChars beforeesc
countseq breaker =
let (inseq, b') = breaker (B.drop 2 b)
in go (c'+1+1+B.length inseq+1) (breakesc (B.drop 1 b'))
esc = fromIntegral (ord '\ESC')
bel = fromIntegral (ord '\BEL')
breakesc = B.break (== esc)
headis c b = B.head b ==c
csi = fromIntegral (ord '[')
csiend c = c >= 64 && c < 127
breakcsi = B.break csiend
osc = fromIntegral (ord ']')
breakosc = B.break (== bel)
countControlChars :: B.ByteString -> Int
countControlChars = length . filter iscontrol8 . B.unpack
where
iscontrol8 c = c < 32 || c == 127